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 => 49;
   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 ### extra tests for a few specific bugs
  80 {
  81     fileparse_set_fstype 'DOS';
  82     # perl5.003_18 gives C:/perl/.\
  83     is((fileparse 'C:/perl/lib')[1], 'C:/perl/');
  84     # perl5.003_18 gives C:\perl\
  85     is(dirname('C:\\perl\\lib\\'), 'C:\\perl');
  86
  87     fileparse_set_fstype 'UNIX';
  88     # perl5.003_18 gives '.'
  89     is(dirname('/perl/'), '/');
  90     # perl5.003_18 gives '/perl/lib'
  91     is(dirname('/perl/lib//'), '/perl');
  92 }
  93
  94 ### rt.perl.org 22236
  95 {
  96     is(basename('a/'), 'a');
  97     is(basename('/usr/lib//'), 'lib');
  98
  99     fileparse_set_fstype 'MSWin32';
 100     is(basename('a\\'), 'a');
 101     is(basename('\\usr\\lib\\\\'), 'lib');
 102 }
 103
 104
 105 ### rt.cpan.org 36477
 106 {
 107     fileparse_set_fstype('Unix');
 108     is(dirname('/'), '/');
 109     is(basename('/'), '/');
 110
 111     fileparse_set_fstype('DOS');
 112     is(dirname('\\'), '\\');
 113     is(basename('\\'), '\\');
 114 }
 115
 116
 117 ### basename(1) sez: "The suffix is not stripped if it is identical to the
 118 ### remaining characters in string"
 119 {
 120     fileparse_set_fstype('Unix');
 121     is(basename('.foo'), '.foo');
 122     is(basename('.foo', '.foo'),     '.foo');
 123     is(basename('.foo.bar', '.foo'), '.foo.bar');
 124     is(basename('.foo.bar', '.bar'), '.foo');
 125 }
 126
 127
 128 ### Test tainting
 129 {
 130     #   The empty tainted value, for tainting strings
 131     my $TAINT = substr($^X, 0, 0);
 132
 133     # How to identify taint when you see it
 134     sub any_tainted (@) {
 135         return ! eval { eval("#" . substr(join("", @_), 0, 0)); 1 };
 136     }
 137
 138     sub tainted ($) {
 139         any_tainted @_;
 140     }
 141
 142     sub all_tainted (@) {
 143         for (@_) { return 0 unless tainted $_ }
 144         1;
 145     }
 146
 147     fileparse_set_fstype 'Unix';
 148     ok tainted(dirname($TAINT.'/perl/lib//'));
 149     ok all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+'));
 150 }