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 => 64;
   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     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 SKIP: {
 158     skip "A perl without taint support", 2
 159         if not ${^TAINT};
 160     #   The empty tainted value, for tainting strings
 161     my $TAINT = substr($^X, 0, 0);
 162
 163     # How to identify taint when you see it
 164     sub any_tainted (@) {
 165         return ! eval { eval("#" . substr(join("", @_), 0, 0)); 1 };
 166     }
 167
 168     sub tainted ($) {
 169         any_tainted @_;
 170     }
 171
 172     sub all_tainted (@) {
 173         for (@_) { return 0 unless tainted $_ }
 174         1;
 175     }
 176
 177     fileparse_set_fstype 'Unix';
 178     ok tainted(dirname($TAINT.'/perl/lib//'));
 179     ok all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+'));
 180 }