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