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 => 53;
   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     is(dirname('/'), '/');
  30 }
  31
  32
  33 ### Testing VMS
  34 {
  35     is(fileparse_set_fstype('VMS'), 'Unix', 'set fstype to VMS');
  36
  37     my($base,$path,$type) = fileparse('virgil:[aeneid]draft.book7',
  38                                       qr{\.book\d+});
  39     is($base, 'draft');
  40     is($path, 'virgil:[aeneid]');
  41     is($type, '.book7');
  42
  43     is(basename('arma:[virumque]cano.trojae'), 'cano.trojae');
  44     is(dirname('arma:[virumque]cano.trojae'),  'arma:[virumque]');
  45     is(dirname('arma:<virumque>cano.trojae'),  'arma:<virumque>');
  46     is(dirname('arma:virumque.cano'), 'arma:');
  47
  48     {
  49         local $ENV{DEFAULT} = '' unless exists $ENV{DEFAULT};
  50         is(dirname('virumque.cano'), $ENV{DEFAULT});
  51         is(dirname('arma/'), '.');
  52     }
  53 }
  54
  55
  56 ### Testing DOS
  57 {
  58     is(fileparse_set_fstype('DOS'), 'VMS', 'set fstype to DOS');
  59
  60     my($base,$path,$type) = fileparse('C:\\virgil\\aeneid\\draft.book7',
  61                                       '\.book\d+');
  62     is($base, 'draft');
  63     is($path, 'C:\\virgil\\aeneid\\');
  64     is($type, '.book7');
  65
  66     is(basename('A:virumque\\cano.trojae'),  'cano.trojae');
  67     is(dirname('A:\\virumque\\cano.trojae'), 'A:\\virumque');
  68     is(dirname('A:\\'), 'A:\\');
  69     is(dirname('arma\\'), '.');
  70
  71     # Yes "/" is a legal path separator under DOS
  72     is(basename("lib/File/Basename.pm"), "Basename.pm");
  73
  74     # $^O for DOS is "dos" not "MSDOS" but "MSDOS" is left in for
  75     # backward bug compat.
  76     is(fileparse_set_fstype('MSDOS'), 'DOS');
  77     is( dirname("\\foo\\bar\\baz"), "\\foo\\bar" );
  78 }
  79
  80
  81 ### Testing MacOS
  82 {
  83     is(fileparse_set_fstype('MacOS'), 'MSDOS', 'set fstype to MacOS');
  84
  85     my($base,$path,$type) = fileparse('virgil:aeneid:draft.book7',
  86                                       '\.book\d+');
  87     is($base, 'draft');
  88     is($path, 'virgil:aeneid:');
  89     is($type, '.book7');
  90
  91     is(basename(':arma:virumque:cano.trojae'), 'cano.trojae');
  92     is(dirname(':arma:virumque:cano.trojae'),  ':arma:virumque:');
  93     is(dirname(':arma:virumque:'), ':arma:');
  94     is(dirname(':arma:virumque'), ':arma:');
  95     is(dirname(':arma:'), ':');
  96     is(dirname(':arma'),  ':');
  97     is(dirname('arma:'), 'arma:');
  98     is(dirname('arma'), ':');
  99     is(dirname(':'), ':');
 100
 101
 102     # Check quoting of metacharacters in suffix arg by basename()
 103     is(basename(':arma:virumque:cano.trojae','.trojae'), 'cano');
 104     is(basename(':arma:virumque:cano_trojae','.trojae'), 'cano_trojae');
 105 }
 106
 107
 108 ### extra tests for a few specific bugs
 109 {
 110     fileparse_set_fstype 'DOS';
 111     # perl5.003_18 gives C:/perl/.\
 112     is((fileparse 'C:/perl/lib')[1], 'C:/perl/');
 113     # perl5.003_18 gives C:\perl\
 114     is(dirname('C:\\perl\\lib\\'), 'C:\\perl');
 115
 116     fileparse_set_fstype 'UNIX';
 117     # perl5.003_18 gives '.'
 118     is(dirname('/perl/'), '/');
 119     # perl5.003_18 gives '/perl/lib'
 120     is(dirname('/perl/lib//'), '/perl');
 121 }
 122
 123
 124 ### Test tainting
 125 {
 126     #   The empty tainted value, for tainting strings
 127     my $TAINT = substr($^X, 0, 0);
 128
 129     # How to identify taint when you see it
 130     sub any_tainted (@) {
 131         return ! eval { eval("#" . substr(join("", @_), 0, 0)); 1 };
 132     }
 133
 134     sub tainted ($) {
 135         any_tainted @_;
 136     }
 137
 138     sub all_tainted (@) {
 139         for (@_) { return 0 unless tainted $_ }
 140         1;
 141     }
 142
 143     ok tainted(dirname($TAINT.'/perl/lib//'));
 144     ok all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+'));
 145 }