1#!./perl -Tw 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6} 7 8use Test::More tests => 64; 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 ok length fileparse_set_fstype('unix'), 'set fstype to unix'; 18 is( fileparse_set_fstype(), 'Unix', 'get fstype' ); 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} 30 31 32### Testing VMS 33{ 34 is(fileparse_set_fstype('VMS'), 'Unix', 'set fstype to VMS'); 35 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'); 41 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:'); 46 47 { 48 local $ENV{DEFAULT} = '' unless exists $ENV{DEFAULT}; 49 is(dirname('virumque.cano'), $ENV{DEFAULT}); 50 is(dirname('arma/'), '.'); 51 } 52} 53 54 55### Testing DOS 56{ 57 is(fileparse_set_fstype('DOS'), 'VMS', 'set fstype to DOS'); 58 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'); 64 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\\'), '.'); 69 70 # Yes "/" is a legal path separator under DOS 71 is(basename("lib/File/Basename.pm"), "Basename.pm"); 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" ); 77} 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'); 104} 105 106 107### extra tests for a few specific bugs 108{ 109 fileparse_set_fstype 'DOS'; 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'); 120} 121 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 132 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 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 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 175 fileparse_set_fstype 'Unix'; 176 ok tainted(dirname($TAINT.'/perl/lib//')); 177 ok all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+')); 178} 179