contrib/perl5/t/lib/basename.t

   1 #!./perl -T
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 use File::Basename qw(fileparse basename dirname);
   9
  10 print "1..36\n";
  11
  12 # import correctly?
  13 print +(defined(&basename) && !defined(&fileparse_set_fstype) ?
  14         '' : 'not '),"ok 1\n";
  15
  16 # set fstype -- should replace non-null default
  17 print +(length(File::Basename::fileparse_set_fstype('unix')) ?
  18         '' : 'not '),"ok 2\n";
  19
  20 # Unix syntax tests
  21 ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7','\.book\d+');
  22 if ($base eq 'draft' and $path eq '/virgil/aeneid/' and $type eq '.book7') {
  23   print "ok 3\n";
  24 }
  25 else {
  26   print "not ok 3       |$base|$path|$type|\n";
  27 }
  28 print +(basename('/arma/virumque.cano') eq 'virumque.cano' ?
  29         '' : 'not '),"ok 4\n";
  30 print +(dirname('/arma/virumque.cano') eq '/arma' ? '' : 'not '),"ok 5\n";
  31 print +(dirname('arma/') eq '.' ? '' : 'not '),"ok 6\n";
  32 print +(dirname('/') eq '/' ? '' : 'not '),"ok 7\n";
  33
  34
  35 # set fstype -- should replace non-null default
  36 print +(File::Basename::fileparse_set_fstype('VMS') eq 'unix' ?
  37         '' : 'not '),"ok 8\n";
  38
  39 # VMS syntax tests
  40 ($base,$path,$type) = fileparse('virgil:[aeneid]draft.book7','\.book\d+');
  41 if ($base eq 'draft' and $path eq 'virgil:[aeneid]' and $type eq '.book7') {
  42   print "ok 9\n";
  43 }
  44 else {
  45   print "not ok 9       |$base|$path|$type|\n";
  46 }
  47 print +(basename('arma:[virumque]cano.trojae') eq 'cano.trojae' ?
  48         '' : 'not '),"ok 10\n";
  49 print +(dirname('arma:[virumque]cano.trojae') eq 'arma:[virumque]' ?
  50         '' : 'not '),"ok 11\n";
  51 print +(dirname('arma:<virumque>cano.trojae') eq 'arma:<virumque>' ?
  52         '' : 'not '),"ok 12\n";
  53 print +(dirname('arma:virumque.cano') eq 'arma:' ? '' : 'not '),"ok 13\n";
  54 $ENV{DEFAULT} = '' unless exists $ENV{DEFAULT};
  55 print +(dirname('virumque.cano') eq $ENV{DEFAULT} ? '' : 'not '),"ok 14\n";
  56 print +(dirname('arma/') eq '.' ? '' : 'not '),"ok 15\n";
  57
  58 # set fstype -- should replace non-null default
  59 print +(File::Basename::fileparse_set_fstype('MSDOS') eq 'VMS' ?
  60         '' : 'not '),"ok 16\n";
  61
  62 # MSDOS syntax tests
  63 ($base,$path,$type) = fileparse('C:\\virgil\\aeneid\\draft.book7','\.book\d+');
  64 if ($base eq 'draft' and $path eq 'C:\\virgil\\aeneid\\' and $type eq '.book7') {
  65   print "ok 17\n";
  66 }
  67 else {
  68   print "not ok 17      |$base|$path|$type|\n";
  69 }
  70 print +(basename('A:virumque\\cano.trojae') eq 'cano.trojae' ?
  71         '' : 'not '),"ok 18\n";
  72 print +(dirname('A:\\virumque\\cano.trojae') eq 'A:\\virumque' ?
  73         '' : 'not '),"ok 19\n";
  74 print +(dirname('A:\\') eq 'A:\\' ? '' : 'not '),"ok 20\n";
  75 print +(dirname('arma\\') eq '.' ? '' : 'not '),"ok 21\n";
  76
  77 # Yes "/" is a legal path separator under MSDOS
  78 basename("lib/File/Basename.pm") eq "Basename.pm" or print "not ";
  79 print "ok 22\n";
  80
  81
  82
  83 # set fstype -- should replace non-null default
  84 print +(File::Basename::fileparse_set_fstype('MacOS') eq 'MSDOS' ?
  85         '' : 'not '),"ok 23\n";
  86
  87 # MacOS syntax tests
  88 ($base,$path,$type) = fileparse('virgil:aeneid:draft.book7','\.book\d+');
  89 if ($base eq 'draft' and $path eq 'virgil:aeneid:' and $type eq '.book7') {
  90   print "ok 24\n";
  91 }
  92 else {
  93   print "not ok 24      |$base|$path|$type|\n";
  94 }
  95 print +(basename(':arma:virumque:cano.trojae') eq 'cano.trojae' ?
  96         '' : 'not '),"ok 25\n";
  97 print +(dirname(':arma:virumque:cano.trojae') eq ':arma:virumque:' ?
  98         '' : 'not '),"ok 26\n";
  99 print +(dirname('arma:') eq 'arma:' ? '' : 'not '),"ok 27\n";
 100 print +(dirname(':') eq ':' ? '' : 'not '),"ok 28\n";
 101
 102
 103 # Check quoting of metacharacters in suffix arg by basename()
 104 print +(basename(':arma:virumque:cano.trojae','.trojae') eq 'cano' ?
 105         '' : 'not '),"ok 29\n";
 106 print +(basename(':arma:virumque:cano_trojae','.trojae') eq 'cano_trojae' ?
 107         '' : 'not '),"ok 30\n";
 108
 109 # extra tests for a few specific bugs
 110
 111 File::Basename::fileparse_set_fstype 'MSDOS';
 112 # perl5.003_18 gives C:/perl/.\
 113 print +((fileparse 'C:/perl/lib')[1] eq 'C:/perl/' ? '' : 'not '), "ok 31\n";
 114 # perl5.003_18 gives C:\perl\
 115 print +(dirname('C:\\perl\\lib\\') eq 'C:\\perl' ? '' : 'not '), "ok 32\n";
 116
 117 File::Basename::fileparse_set_fstype 'UNIX';
 118 # perl5.003_18 gives '.'
 119 print +(dirname('/perl/') eq '/' ? '' : 'not '), "ok 33\n";
 120 # perl5.003_18 gives '/perl/lib'
 121 print +(dirname('/perl/lib//') eq '/perl' ? '' : 'not '), "ok 34\n";
 122
 123 #   The empty tainted value, for tainting strings
 124 my $TAINT = substr($^X, 0, 0);
 125 # How to identify taint when you see it
 126 sub any_tainted (@) {
 127     not eval { join("",@_), kill 0; 1 };
 128 }
 129 sub tainted ($) {
 130     any_tainted @_;
 131 }
 132 sub all_tainted (@) {
 133     for (@_) { return 0 unless tainted $_ }
 134     1;
 135 }
 136
 137 print +(tainted(dirname($TAINT.'/perl/lib//')) ? '' : 'not '), "ok 35\n";
 138 print +(all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+'))
 139                 ? '' : 'not '), "ok 36\n";