Commit | Line | Data |
e7204fba |
1 | #!./perl -Tw |
78201403 |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
20822f61 |
5 | @INC = '../lib'; |
78201403 |
6 | } |
7 | |
e7204fba |
8 | use Test::More 'no_plan'; |
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'; |
18 | |
19 | my($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7', |
20 | qr'\.book\d+'); |
21 | is($base, 'draft'); |
22 | is($path, '/virgil/aeneid/'); |
23 | is($type, '.book7'); |
24 | |
25 | is(basename('/arma/virumque.cano'), 'virumque.cano'); |
26 | is(dirname ('/arma/virumque.cano'), '/arma'); |
27 | is(dirname('arma/'), '.'); |
28 | is(dirname('/'), '/'); |
29 | } |
78201403 |
30 | |
78201403 |
31 | |
e7204fba |
32 | ### Testing VMS |
33 | { |
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 | |
e7204fba |
55 | ### Testing MSDOS |
56 | { |
57 | is(fileparse_set_fstype('MSDOS'), 'VMS', 'set fstype to MSDOS'); |
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 | |
e7204fba |
70 | # Yes "/" is a legal path separator under MSDOS |
71 | is(basename("lib/File/Basename.pm"), "Basename.pm"); |
78201403 |
72 | } |
e7204fba |
73 | |
74 | |
75 | ### Testing MacOS |
76 | { |
77 | is(fileparse_set_fstype('MacOS'), 'MSDOS', 'set fstype to MacOS'); |
78 | |
79 | my($base,$path,$type) = fileparse('virgil:aeneid:draft.book7', |
80 | '\.book\d+'); |
81 | is($base, 'draft'); |
82 | is($path, 'virgil:aeneid:'); |
83 | is($type, '.book7'); |
84 | |
85 | is(basename(':arma:virumque:cano.trojae'), 'cano.trojae'); |
86 | is(dirname(':arma:virumque:cano.trojae'), ':arma:virumque:'); |
87 | is(dirname(':arma:virumque:'), ':arma:'); |
88 | is(dirname(':arma:virumque'), ':arma:'); |
89 | is(dirname(':arma:'), ':'); |
90 | is(dirname(':arma'), ':'); |
91 | is(dirname('arma:'), 'arma:'); |
92 | is(dirname('arma'), ':'); |
93 | is(dirname(':'), ':'); |
94 | |
95 | |
96 | # Check quoting of metacharacters in suffix arg by basename() |
97 | is(basename(':arma:virumque:cano.trojae','.trojae'), 'cano'); |
98 | is(basename(':arma:virumque:cano_trojae','.trojae'), 'cano_trojae'); |
b3eb6a9b |
99 | } |
e7204fba |
100 | |
101 | |
102 | ### extra tests for a few specific bugs |
103 | { |
104 | fileparse_set_fstype 'MSDOS'; |
105 | # perl5.003_18 gives C:/perl/.\ |
106 | is((fileparse 'C:/perl/lib')[1], 'C:/perl/'); |
107 | # perl5.003_18 gives C:\perl\ |
108 | is(dirname('C:\\perl\\lib\\'), 'C:\\perl'); |
109 | |
110 | fileparse_set_fstype 'UNIX'; |
111 | # perl5.003_18 gives '.' |
112 | is(dirname('/perl/'), '/'); |
113 | # perl5.003_18 gives '/perl/lib' |
114 | is(dirname('/perl/lib//'), '/perl'); |
b3eb6a9b |
115 | } |
116 | |
e7204fba |
117 | |
118 | ### Test tainting |
119 | { |
120 | # The empty tainted value, for tainting strings |
121 | my $TAINT = substr($^X, 0, 0); |
122 | |
123 | # How to identify taint when you see it |
124 | sub any_tainted (@) { |
125 | return ! eval { eval("#" . substr(join("", @_), 0, 0)); 1 }; |
126 | } |
127 | |
128 | sub tainted ($) { |
129 | any_tainted @_; |
130 | } |
131 | |
132 | sub all_tainted (@) { |
133 | for (@_) { return 0 unless tainted $_ } |
134 | 1; |
135 | } |
136 | |
137 | ok tainted(dirname($TAINT.'/perl/lib//')); |
138 | ok all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+')); |
139 | } |