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 'no_plan';
   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     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 }
  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 MSDOS
  56 {
  57     is(fileparse_set_fstype('MSDOS'), 'VMS', 'set fstype to MSDOS');
  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 MSDOS
  71     is(basename("lib/File/Basename.pm"), "Basename.pm");
  72 }
  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');
  99 }
 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');
 115 }
 116
 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 }