home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / perl / 5.8.8 / File / Basename.pm next >
Encoding:
Perl POD Document  |  2006-07-07  |  11.0 KB  |  399 lines

  1. =head1 NAME
  2.  
  3. File::Basename - Parse file paths into directory, filename and suffix.
  4.  
  5. =head1 SYNOPSIS
  6.  
  7.     use File::Basename;
  8.  
  9.     ($name,$path,$suffix) = fileparse($fullname,@suffixlist);
  10.     $name = fileparse($fullname,@suffixlist);
  11.  
  12.     $basename = basename($fullname,@suffixlist);
  13.     $dirname  = dirname($fullname);
  14.  
  15.  
  16. =head1 DESCRIPTION
  17.  
  18. These routines allow you to parse file paths into their directory, filename
  19. and suffix.
  20.  
  21. B<NOTE>: C<dirname()> and C<basename()> emulate the behaviours, and
  22. quirks, of the shell and C functions of the same name.  See each
  23. function's documentation for details.  If your concern is just parsing
  24. paths it is safer to use L<File::Spec>'s C<splitpath()> and
  25. C<splitdir()> methods.
  26.  
  27. It is guaranteed that
  28.  
  29.     # Where $path_separator is / for Unix, \ for Windows, etc...
  30.     dirname($path) . $path_separator . basename($path);
  31.  
  32. is equivalent to the original path for all systems but VMS.
  33.  
  34.  
  35. =cut
  36.  
  37.  
  38. package File::Basename;
  39.  
  40. # A bit of juggling to insure that C<use re 'taint';> always works, since
  41. # File::Basename is used during the Perl build, when the re extension may
  42. # not be available.
  43. BEGIN {
  44.   unless (eval { require re; })
  45.     { eval ' sub re::import { $^H |= 0x00100000; } ' } # HINT_RE_TAINT
  46.   import re 'taint';
  47. }
  48.  
  49.  
  50. use strict;
  51. use 5.006;
  52. use warnings;
  53. our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase);
  54. require Exporter;
  55. @ISA = qw(Exporter);
  56. @EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
  57. $VERSION = "2.74";
  58.  
  59. fileparse_set_fstype($^O);
  60.  
  61.  
  62. =over 4
  63.  
  64. =item C<fileparse>
  65.  
  66.     my($filename, $directories, $suffix) = fileparse($path);
  67.     my($filename, $directories, $suffix) = fileparse($path, @suffixes);
  68.     my $filename                         = fileparse($path, @suffixes);
  69.  
  70. The C<fileparse()> routine divides a file path into its $directories, $filename
  71. and (optionally) the filename $suffix.
  72.  
  73. $directories contains everything up to and including the last
  74. directory separator in the $path including the volume (if applicable).
  75. The remainder of the $path is the $filename.
  76.  
  77.      # On Unix returns ("baz", "/foo/bar/", "")
  78.      fileparse("/foo/bar/baz");
  79.  
  80.      # On Windows returns ("baz", "C:\foo\bar\", "")
  81.      fileparse("C:\foo\bar\baz");
  82.  
  83.      # On Unix returns ("", "/foo/bar/baz/", "")
  84.      fileparse("/foo/bar/baz/");
  85.  
  86. If @suffixes are given each element is a pattern (either a string or a
  87. C<qr//>) matched against the end of the $filename.  The matching
  88. portion is removed and becomes the $suffix.
  89.  
  90.      # On Unix returns ("baz", "/foo/bar", ".txt")
  91.      fileparse("/foo/bar/baz", qr/\.[^.]*/);
  92.  
  93. If type is non-Unix (see C<fileparse_set_fstype()>) then the pattern
  94. matching for suffix removal is performed case-insensitively, since
  95. those systems are not case-sensitive when opening existing files.
  96.  
  97. You are guaranteed that C<$directories . $filename . $suffix> will
  98. denote the same location as the original $path.
  99.  
  100. =cut
  101.  
  102.  
  103. sub fileparse {
  104.   my($fullname,@suffices) = @_;
  105.  
  106.   unless (defined $fullname) {
  107.       require Carp;
  108.       Carp::croak("fileparse(): need a valid pathname");
  109.   }
  110.  
  111.   my $orig_type = '';
  112.   my($type,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);
  113.  
  114.   my($taint) = substr($fullname,0,0);  # Is $fullname tainted?
  115.  
  116.   if ($type eq "VMS" and $fullname =~ m{/} ) {
  117.     # We're doing Unix emulation
  118.     $orig_type = $type;
  119.     $type = 'Unix';
  120.   }
  121.  
  122.   my($dirpath, $basename);
  123.  
  124.   if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 Epoc)) {
  125.     ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s);
  126.     $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/;
  127.   }
  128.   elsif ($type eq "OS2") {
  129.     ($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s);
  130.     $dirpath = './' unless $dirpath;    # Can't be 0
  131.     $dirpath .= '/' unless $dirpath =~ m#[\\/]\z#;
  132.   }
  133.   elsif ($type eq "MacOS") {
  134.     ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s);
  135.     $dirpath = ':' unless $dirpath;
  136.   }
  137.   elsif ($type eq "AmigaOS") {
  138.     ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s);
  139.     $dirpath = './' unless $dirpath;
  140.   }
  141.   elsif ($type eq 'VMS' ) {
  142.     ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s);
  143.     $dirpath ||= '';  # should always be defined
  144.   }
  145.   else { # Default to Unix semantics.
  146.     ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#s);
  147.     if ($orig_type eq 'VMS' and $fullname =~ m:^(/[^/]+/000000(/|$))(.*):) {
  148.       # dev:[000000] is top of VMS tree, similar to Unix '/'
  149.       # so strip it off and treat the rest as "normal"
  150.       my $devspec  = $1;
  151.       my $remainder = $3;
  152.       ($dirpath,$basename) = ($remainder =~ m#^(.*/)?(.*)#s);
  153.       $dirpath ||= '';  # should always be defined
  154.       $dirpath = $devspec.$dirpath;
  155.     }
  156.     $dirpath = './' unless $dirpath;
  157.   }
  158.       
  159.  
  160.   my $tail   = '';
  161.   my $suffix = '';
  162.   if (@suffices) {
  163.     foreach $suffix (@suffices) {
  164.       my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
  165.       if ($basename =~ s/$pat//s) {
  166.         $taint .= substr($suffix,0,0);
  167.         $tail = $1 . $tail;
  168.       }
  169.     }
  170.   }
  171.  
  172.   # Ensure taint is propgated from the path to its pieces.
  173.   $tail .= $taint;
  174.   wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail)
  175.             : ($basename .= $taint);
  176. }
  177.  
  178.  
  179.  
  180. =item C<basename>
  181.  
  182.     my $filename = basename($path);
  183.     my $filename = basename($path, @suffixes);
  184.  
  185. This function is provided for compatibility with the Unix shell command 
  186. C<basename(1)>.  It does B<NOT> always return the file name portion of a
  187. path as you might expect.  To be safe, if you want the file name portion of
  188. a path use C<fileparse()>.
  189.  
  190. C<basename()> returns the last level of a filepath even if the last
  191. level is clearly directory.  In effect, it is acting like C<pop()> for
  192. paths.  This differs from C<fileparse()>'s behaviour.
  193.  
  194.     # Both return "bar"
  195.     basename("/foo/bar");
  196.     basename("/foo/bar/");
  197.  
  198. @suffixes work as in C<fileparse()> except all regex metacharacters are
  199. quoted.
  200.  
  201.     # These two function calls are equivalent.
  202.     my $filename = basename("/foo/bar/baz.txt",  ".txt");
  203.     my $filename = fileparse("/foo/bar/baz.txt", qr/\Q.txt\E/);
  204.  
  205. Also note that in order to be compatible with the shell command,
  206. C<basename()> does not strip off a suffix if it is identical to the
  207. remaining characters in the filename.
  208.  
  209. =cut
  210.  
  211.  
  212. sub basename {
  213.   my($path) = shift;
  214.  
  215.   # From BSD basename(1)
  216.   # The basename utility deletes any prefix ending with the last slash `/'
  217.   # character present in string (after first stripping trailing slashes)
  218.   _strip_trailing_sep($path);
  219.  
  220.   my($basename, $dirname, $suffix) = fileparse( $path, map("\Q$_\E",@_) );
  221.  
  222.   # From BSD basename(1)
  223.   # The suffix is not stripped if it is identical to the remaining 
  224.   # characters in string.
  225.   if( length $suffix and !length $basename ) {
  226.       $basename = $suffix;
  227.   }
  228.   
  229.   # Ensure that basename '/' == '/'
  230.   if( !length $basename ) {
  231.       $basename = $dirname;
  232.   }
  233.  
  234.   return $basename;
  235. }
  236.  
  237.  
  238.  
  239. =item C<dirname>
  240.  
  241. This function is provided for compatibility with the Unix shell
  242. command C<dirname(1)> and has inherited some of its quirks.  In spite of
  243. its name it does B<NOT> always return the directory name as you might
  244. expect.  To be safe, if you want the directory name of a path use
  245. C<fileparse()>.
  246.  
  247. Only on VMS (where there is no ambiguity between the file and directory
  248. portions of a path) and AmigaOS (possibly due to an implementation quirk in
  249. this module) does C<dirname()> work like C<fileparse($path)>, returning just the
  250. $directories.
  251.  
  252.     # On VMS and AmigaOS
  253.     my $directories = dirname($path);
  254.  
  255. When using Unix or MSDOS syntax this emulates the C<dirname(1)> shell function
  256. which is subtly different from how C<fileparse()> works.  It returns all but
  257. the last level of a file path even if the last level is clearly a directory.
  258. In effect, it is not returning the directory portion but simply the path one
  259. level up acting like C<chop()> for file paths.
  260.  
  261. Also unlike C<fileparse()>, C<dirname()> does not include a trailing slash on
  262. its returned path.
  263.  
  264.     # returns /foo/bar.  fileparse() would return /foo/bar/
  265.     dirname("/foo/bar/baz");
  266.  
  267.     # also returns /foo/bar despite the fact that baz is clearly a 
  268.     # directory.  fileparse() would return /foo/bar/baz/
  269.     dirname("/foo/bar/baz/");
  270.  
  271.     # returns '.'.  fileparse() would return 'foo/'
  272.     dirname("foo/");
  273.  
  274. Under VMS, if there is no directory information in the $path, then the
  275. current default device and directory is used.
  276.  
  277. =cut
  278.  
  279.  
  280. sub dirname {
  281.     my $path = shift;
  282.  
  283.     my($type) = $Fileparse_fstype;
  284.  
  285.     if( $type eq 'VMS' and $path =~ m{/} ) {
  286.         # Parse as Unix
  287.         local($File::Basename::Fileparse_fstype) = '';
  288.         return dirname($path);
  289.     }
  290.  
  291.     my($basename, $dirname) = fileparse($path);
  292.  
  293.     if ($type eq 'VMS') { 
  294.         $dirname ||= $ENV{DEFAULT};
  295.     }
  296.     elsif ($type eq 'MacOS') {
  297.     if( !length($basename) && $dirname !~ /^[^:]+:\z/) {
  298.             _strip_trailing_sep($dirname);
  299.         ($basename,$dirname) = fileparse $dirname;
  300.     }
  301.     $dirname .= ":" unless $dirname =~ /:\z/;
  302.     }
  303.     elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { 
  304.         _strip_trailing_sep($dirname);
  305.         unless( length($basename) ) {
  306.         ($basename,$dirname) = fileparse $dirname;
  307.         _strip_trailing_sep($dirname);
  308.     }
  309.     }
  310.     elsif ($type eq 'AmigaOS') {
  311.         if ( $dirname =~ /:\z/) { return $dirname }
  312.         chop $dirname;
  313.         $dirname =~ s#[^:/]+\z## unless length($basename);
  314.     }
  315.     else {
  316.         _strip_trailing_sep($dirname);
  317.         unless( length($basename) ) {
  318.         ($basename,$dirname) = fileparse $dirname;
  319.         _strip_trailing_sep($dirname);
  320.     }
  321.     }
  322.  
  323.     $dirname;
  324. }
  325.  
  326.  
  327. # Strip the trailing path separator.
  328. sub _strip_trailing_sep  {
  329.     my $type = $Fileparse_fstype;
  330.  
  331.     if ($type eq 'MacOS') {
  332.         $_[0] =~ s/([^:]):\z/$1/s;
  333.     }
  334.     elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { 
  335.         $_[0] =~ s/([^:])[\\\/]*\z/$1/;
  336.     }
  337.     else {
  338.         $_[0] =~ s{(.)/*\z}{$1}s;
  339.     }
  340. }
  341.  
  342.  
  343. =item C<fileparse_set_fstype>
  344.  
  345.   my $type = fileparse_set_fstype();
  346.   my $previous_type = fileparse_set_fstype($type);
  347.  
  348. Normally File::Basename will assume a file path type native to your current
  349. operating system (ie. /foo/bar style on Unix, \foo\bar on Windows, etc...).
  350. With this function you can override that assumption.
  351.  
  352. Valid $types are "MacOS", "VMS", "AmigaOS", "OS2", "RISCOS",
  353. "MSWin32", "DOS" (also "MSDOS" for backwards bug compatibility),
  354. "Epoc" and "Unix" (all case-insensitive).  If an unrecognized $type is
  355. given "Unix" will be assumed.
  356.  
  357. If you've selected VMS syntax, and the file specification you pass to
  358. one of these routines contains a "/", they assume you are using Unix
  359. emulation and apply the Unix syntax rules instead, for that function
  360. call only.
  361.  
  362. =back
  363.  
  364. =cut
  365.  
  366.  
  367. BEGIN {
  368.  
  369. my @Ignore_Case = qw(MacOS VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc);
  370. my @Types = (@Ignore_Case, qw(Unix));
  371.  
  372. sub fileparse_set_fstype {
  373.     my $old = $Fileparse_fstype;
  374.  
  375.     if (@_) {
  376.         my $new_type = shift;
  377.  
  378.         $Fileparse_fstype = 'Unix';  # default
  379.         foreach my $type (@Types) {
  380.             $Fileparse_fstype = $type if $new_type =~ /^$type/i;
  381.         }
  382.  
  383.         $Fileparse_igncase = 
  384.           (grep $Fileparse_fstype eq $_, @Ignore_Case) ? 1 : 0;
  385.     }
  386.  
  387.     return $old;
  388. }
  389.  
  390. }
  391.  
  392.  
  393. 1;
  394.  
  395.  
  396. =head1 SEE ALSO
  397.  
  398. L<dirname(1)>, L<basename(1)>, L<File::Spec>
  399.