home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / lib / basename.t < prev    next >
Text File  |  1999-07-20  |  5KB  |  140 lines
  1. #!./perl -T
  2.  
  3. BEGIN {
  4.     chdir 't' if -d 't';
  5.     unshift @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";
  140.