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