lib/File/Basename.t

   1 #!./perl -Tw
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 use Test::More tests => 65;
   9
  10 BEGIN { use_ok 'File::Basename' }
  11
  12 # import correctly?
  13 can_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
 163 SKIP: {
 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 }