home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 5 / Skunkware 5.iso / lib / perl5 / File / Basename.pm next >
Encoding:
Perl POD Document  |  1995-07-03  |  4.5 KB  |  139 lines
  1. package File::Basename;
  2.  
  3. require 5.000;
  4. use Config;
  5. require Exporter;
  6. @ISA = qw(Exporter);
  7. @EXPORT = qw(fileparse set_fileparse_fstype basename dirname);
  8.  
  9. #   fileparse_set_fstype() - specify OS-based rules used in future
  10. #                            calls to routines in this package
  11. #
  12. #   Currently recognized values: VMS, MSDOS, MacOS
  13. #       Any other name uses Unix-style rules
  14.  
  15. sub fileparse_set_fstype {
  16.   $Fileparse_fstype = $_[0];
  17. }
  18.  
  19. #   fileparse() - parse file specification
  20. #
  21. #   calling sequence:
  22. #     ($filename,$prefix,$tail) = &basename_pat($filespec,@excludelist);
  23. #     where  $filespec    is the file specification to be parsed, and
  24. #            @excludelist is a list of patterns which should be removed
  25. #                         from the end of $filename.
  26. #            $filename    is the part of $filespec after $prefix (i.e. the
  27. #                         name of the file).  The elements of @excludelist
  28. #                         are compared to $filename, and if an  
  29. #            $prefix     is the path portion $filespec, up to and including
  30. #                        the end of the last directory name
  31. #            $tail        any characters removed from $filename because they
  32. #                         matched an element of @excludelist.
  33. #
  34. #   fileparse() first removes the directory specification from $filespec,
  35. #   according to the syntax of the OS (code is provided below to handle
  36. #   VMS, Unix, MSDOS and MacOS; you can pick the one you want using
  37. #   fileparse_set_fstype(), or you can accept the default, which is
  38. #   based on the information in the %Config array).  It then compares
  39. #   each element of @excludelist to $filename, and if that element is a
  40. #   suffix of $filename, it is removed from $filename and prepended to
  41. #   $tail.  By specifying the elements of @excludelist in the right order,
  42. #   you can 'nibble back' $filename to extract the portion of interest
  43. #   to you.
  44. #
  45. #   For example, on a system running Unix,
  46. #   ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
  47. #                                       '\.book\d+');
  48. #   would yield $base == 'draft',
  49. #               $path == '/virgil/aeneid', and
  50. #               $tail == '.book7'.
  51. #   Similarly, on a system running VMS,
  52. #   ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh','\..*');
  53. #   would yield $name == 'Rhetoric';
  54. #               $dir == 'Doc_Root:[Help]', and
  55. #               $type == '.Rnh'.
  56. #
  57. #   Version 2.2  13-Oct-1994  Charles Bailey  bailey@genetics.upenn.edu 
  58.  
  59.  
  60. sub fileparse {
  61.   my($fullname,@suffices) = @_;
  62.   my($fstype) = $Fileparse_fstype;
  63.   my($dirpath,$tail,$suffix,$idx);
  64.  
  65.   if ($fstype =~ /^VMS/i) {
  66.     if ($fullname =~ m#/#) { $fstype = '' }  # We're doing Unix emulation
  67.     else {
  68.       ($dirpath,$basename) = ($fullname =~ /(.*[:>\]])?(.*)/);
  69.       $dirpath = $ENV{'PATH'} unless $dirpath;
  70.     }
  71.   }
  72.   if ($fstype =~ /^MSDOS/i) {
  73.     ($dirpath,$basename) = ($fullname =~ /(.*\\)?(.*)/);
  74.     $dirpath = '.' unless $dirpath;
  75.   }
  76.   elsif ($fstype =~ /^MAC/i) {
  77.     ($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/);
  78.   }
  79.   else {  # default to Unix
  80.     ($dirpath,$basename) = ($fullname =~ m#(.*/)?(.*)#);
  81.     $dirpath = '.' unless $dirpath;
  82.   }
  83.  
  84.   if (@suffices) {
  85.     foreach $suffix (@suffices) {
  86.       if ($basename =~ /($suffix)$/) {
  87.         $tail = $1 . $tail;
  88.         $basename = $`;
  89.       }
  90.     }
  91.   }
  92.  
  93.   ($basename,$dirpath,$tail);
  94.  
  95. }
  96.  
  97.  
  98. #   basename() - returns first element of list returned by fileparse()
  99.  
  100. sub basename {
  101.   (fileparse(@_))[0];
  102. }
  103.   
  104.  
  105. #    dirname() - returns device and directory portion of file specification
  106. #        Behavior matches that of Unix dirname(1) exactly for Unix and MSDOS
  107. #        filespecs.  This differs from the second element of the list returned
  108. #        by fileparse() in that the trailing '/' (Unix) or '\' (MSDOS) (and
  109. #        the last directory name if the filespec ends in a '/' or '\'), is lost.
  110.  
  111. sub dirname {
  112.     my($basename,$dirname) = fileparse($_[0]);
  113.     my($fstype) = $Fileparse_fstype;
  114.  
  115.     if ($fstype =~ /VMS/i) { 
  116.         if (m#/#) { $fstype = '' }
  117.         else { return $dirname }
  118.     }
  119.     if ($fstype =~ /MacOS/i) { return $dirname }
  120.     elsif ($fstype =~ /MSDOS/i) { 
  121.         if ( $dirname =~ /:\\$/) { return $dirname }
  122.         chop $dirname;
  123.         $dirname =~ s:[^/]+$:: unless $basename;
  124.         $dirname = '.' unless $dirname;
  125.     }
  126.     else { 
  127.         if ( $dirname eq '/') { return $dirname }
  128.         chop $dirname;
  129.         $dirname =~ s:[^/]+$:: unless $basename;
  130.         $dirname = '.' unless $dirname;
  131.     }
  132.  
  133.     $dirname;
  134. }
  135.  
  136. $Fileparse_fstype = $Config{'osname'};
  137.  
  138. 1;
  139.