X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FFile%2FBasename.pm;h=887c7bae4a9fb13cbae95bf12172c86e72665661;hb=a8bf0cad84ba0e8477c2b4b1b02a57dbd376a155;hp=5e09ae4977bc299d83d6a9047e48292dfb02d712;hpb=748a93069b3d16374a9859d1456065dd3ae11394;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index 5e09ae4..887c7ba 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -1,99 +1,235 @@ package File::Basename; -require 5.000; -use Config; +=head1 NAME + +fileparse - split a pathname into pieces + +basename - extract just the filename from a path + +dirname - extract just the directory from a path + +=head1 SYNOPSIS + + use File::Basename; + + ($name,$path,$suffix) = fileparse($fullname,@suffixlist); + $name = fileparse($fullname,@suffixlist); + fileparse_set_fstype($os_string); + $basename = basename($fullname,@suffixlist); + $dirname = dirname($fullname); + + ($name,$path,$suffix) = fileparse("lib/File/Basename.pm",qr{\.pm}); + fileparse_set_fstype("VMS"); + $basename = basename("lib/File/Basename.pm",".pm"); + $dirname = dirname("lib/File/Basename.pm"); + +=head1 DESCRIPTION + +These routines allow you to parse file specifications into useful +pieces using the syntax of different operating systems. + +=over 4 + +=item fileparse_set_fstype + +You select the syntax via the routine fileparse_set_fstype(). + +If the argument passed to it contains one of the substrings +"VMS", "MSDOS", "MacOS", "AmigaOS" or "MSWin32", the file specification +syntax of that operating system is used in future calls to +fileparse(), basename(), and dirname(). If it contains none of +these substrings, Unix syntax is used. This pattern matching is +case-insensitive. If you've selected VMS syntax, and the file +specification you pass to one of these routines contains a "/", +they assume you are using Unix emulation and apply the Unix syntax +rules instead, for that function call only. + +If the argument passed to it contains one of the substrings "VMS", +"MSDOS", "MacOS", "AmigaOS", "os2", "MSWin32" or "RISCOS", then the pattern +matching for suffix removal is performed without regard for case, +since those systems are not case-sensitive when opening existing files +(though some of them preserve case on file creation). + +If you haven't called fileparse_set_fstype(), the syntax is chosen +by examining the builtin variable C<$^O> according to these rules. + +=item fileparse + +The fileparse() routine divides a file specification into three +parts: a leading B, a file B, and a B. The +B contains everything up to and including the last directory +separator in the input file specification. The remainder of the input +file specification is then divided into B and B based on +the optional patterns you specify in C<@suffixlist>. Each element of +this list can be a qr-quoted pattern (or a string which is interpreted +as a regular expression), and is matched +against the end of B. If this succeeds, the matching portion of +B is removed and prepended to B. By proper use of +C<@suffixlist>, you can remove file types or versions for examination. + +You are guaranteed that if you concatenate B, B, and +B together in that order, the result will denote the same +file as the input file specification. + +In scalar context, fileparse() returns only the B part of the filename. + +=back + +=head1 EXAMPLES + +Using Unix file syntax: + + ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7', + qr{\.book\d+}); + +would yield + + $base eq 'draft' + $path eq '/virgil/aeneid/', + $type eq '.book7' + +Similarly, using VMS syntax: + + ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh', + qr{\..*}); + +would yield + + $name eq 'Rhetoric' + $dir eq 'Doc_Root:[Help]' + $type eq '.Rnh' + +=over + +=item C + +The basename() routine returns the first element of the list produced +by calling fileparse() with the same arguments, except that it always +quotes metacharacters in the given suffixes. It is provided for +programmer compatibility with the Unix shell command basename(1). + +=item C + +The dirname() routine returns the directory portion of the input file +specification. When using VMS or MacOS syntax, this is identical to the +second element of the list produced by calling fileparse() with the same +input file specification. (Under VMS, if there is no directory information +in the input file specification, then the current default device and +directory are returned.) When using Unix or MSDOS syntax, the return +value conforms to the behavior of the Unix shell command dirname(1). This +is usually the same as the behavior of fileparse(), but differs in some +cases. For example, for the input file specification F, fileparse() +considers the directory name to be F, while dirname() considers the +directory name to be F<.>). + +=back + +=cut + + +## use strict; +# A bit of juggling to insure that C always works, since +# File::Basename is used during the Perl build, when the re extension may +# not be available. +BEGIN { + unless (eval { require re; }) + { eval ' sub re::import { $^H |= 0x00100000; } ' } # HINT_RE_TAINT + import re 'taint'; +} + + + +use 5.006; +use warnings; +our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase); require Exporter; @ISA = qw(Exporter); @EXPORT = qw(fileparse fileparse_set_fstype basename dirname); +$VERSION = "2.73"; + # fileparse_set_fstype() - specify OS-based rules used in future # calls to routines in this package # -# Currently recognized values: VMS, MSDOS, MacOS -# Any other name uses Unix-style rules +# Currently recognized values: VMS, MSDOS, MacOS, AmigaOS, os2, RISCOS +# Any other name uses Unix-style rules and is case-sensitive sub fileparse_set_fstype { - my($old) = $Fileparse_fstype; - $Fileparse_fstype = $_[0] if $_[0]; - $old; + my @old = ($Fileparse_fstype, $Fileparse_igncase); + if (@_) { + $Fileparse_fstype = $_[0]; + $Fileparse_igncase = ($_[0] =~ /^(?:MacOS|VMS|AmigaOS|os2|RISCOS|MSWin32|MSDOS)/i); + } + wantarray ? @old : $old[0]; } # fileparse() - parse file specification # -# calling sequence: -# ($filename,$prefix,$tail) = &basename_pat($filespec,@excludelist); -# where $filespec is the file specification to be parsed, and -# @excludelist is a list of patterns which should be removed -# from the end of $filename. -# $filename is the part of $filespec after $prefix (i.e. the -# name of the file). The elements of @excludelist -# are compared to $filename, and if an -# $prefix is the path portion $filespec, up to and including -# the end of the last directory name -# $tail any characters removed from $filename because they -# matched an element of @excludelist. -# -# fileparse() first removes the directory specification from $filespec, -# according to the syntax of the OS (code is provided below to handle -# VMS, Unix, MSDOS and MacOS; you can pick the one you want using -# fileparse_set_fstype(), or you can accept the default, which is -# based on the information in the %Config array). It then compares -# each element of @excludelist to $filename, and if that element is a -# suffix of $filename, it is removed from $filename and prepended to -# $tail. By specifying the elements of @excludelist in the right order, -# you can 'nibble back' $filename to extract the portion of interest -# to you. -# -# For example, on a system running Unix, -# ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7', -# '\.book\d+'); -# would yield $base == 'draft', -# $path == '/virgil/aeneid/' (note trailing slash) -# $tail == '.book7'. -# Similarly, on a system running VMS, -# ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh','\..*'); -# would yield $name == 'Rhetoric'; -# $dir == 'Doc_Root:[Help]', and -# $type == '.Rnh'. -# -# Version 2.2 13-Oct-1994 Charles Bailey bailey@genetics.upenn.edu +# Version 2.4 27-Sep-1996 Charles Bailey bailey@genetics.upenn.edu sub fileparse { my($fullname,@suffices) = @_; - my($fstype) = $Fileparse_fstype; - my($dirpath,$tail,$suffix,$idx); + unless (defined $fullname) { + require Carp; + Carp::croak("fileparse(): need a valid pathname"); + } + my($fstype,$igncase) = ($Fileparse_fstype, $Fileparse_igncase); + my($dirpath,$tail,$suffix,$basename); + my($taint) = substr($fullname,0,0); # Is $fullname tainted? if ($fstype =~ /^VMS/i) { if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation else { - ($dirpath,$basename) = ($fullname =~ /(.*[:>\]])?(.*)/); - $dirpath = $ENV{'DEFAULT'} unless $dirpath; + ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s); + $dirpath ||= ''; # should always be defined } } - if ($fstype =~ /^MSDOS/i) { - ($dirpath,$basename) = ($fullname =~ /(.*\\)?(.*)/); - $dirpath = '.' unless $dirpath; + if ($fstype =~ /^MS(DOS|Win32)|epoc/i) { + ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s); + $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/; + } + elsif ($fstype =~ /^os2/i) { + ($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s); + $dirpath = './' unless $dirpath; # Can't be 0 + $dirpath .= '/' unless $dirpath =~ m#[\\/]\z#; + } + elsif ($fstype =~ /^MacOS/si) { + ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s); + $dirpath = ':' unless $dirpath; } - elsif ($fstype =~ /^MAC/i) { - ($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/); + elsif ($fstype =~ /^AmigaOS/i) { + ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s); + $dirpath = './' unless $dirpath; } elsif ($fstype !~ /^VMS/i) { # default to Unix - ($dirpath,$basename) = ($fullname =~ m#(.*/)?(.*)#); - $dirpath = '.' unless $dirpath; + ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#s); + if ($^O eq 'VMS' and $fullname =~ m:^(/[^/]+/000000(/|$))(.*):) { + # dev:[000000] is top of VMS tree, similar to Unix '/' + # so strip it off and treat the rest as "normal" + my $devspec = $1; + my $remainder = $3; + ($dirpath,$basename) = ($remainder =~ m#^(.*/)?(.*)#s); + $dirpath ||= ''; # should always be defined + $dirpath = $devspec.$dirpath; + } + $dirpath = './' unless $dirpath; } if (@suffices) { + $tail = ''; foreach $suffix (@suffices) { - if ($basename =~ /($suffix)$/) { + my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$"; + if ($basename =~ s/$pat//s) { + $taint .= substr($suffix,0,0); $tail = $1 . $tail; - $basename = $`; } } } - wantarray ? ($basename,$dirpath,$tail) : $basename; - + $tail .= $taint if defined $tail; # avoid warning if $tail == undef + wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail) + : ($basename .= $taint); } @@ -103,7 +239,7 @@ sub basename { my($name) = shift; (fileparse($name, map("\Q$_\E",@_)))[0]; } - + # dirname() - returns device and directory portion of file specification # Behavior matches that of Unix dirname(1) exactly for Unix and MSDOS @@ -118,25 +254,39 @@ sub dirname { if ($fstype =~ /VMS/i) { if ($_[0] =~ m#/#) { $fstype = '' } - else { return $dirname } + else { return $dirname || $ENV{DEFAULT} } } - if ($fstype =~ /MacOS/i) { return $dirname } - elsif ($fstype =~ /MSDOS/i) { - if ( $dirname =~ /:\\$/) { return $dirname } - chop $dirname; - $dirname =~ s:[^\\]+$:: unless $basename; - $dirname = '.' unless $dirname; + if ($fstype =~ /MacOS/i) { + if( !length($basename) && $dirname !~ /^[^:]+:\z/) { + $dirname =~ s/([^:]):\z/$1/s; + ($basename,$dirname) = fileparse $dirname; + } + $dirname .= ":" unless $dirname =~ /:\z/; } - else { - if ( $dirname eq '/') { return $dirname } + elsif ($fstype =~ /MS(DOS|Win32)|os2/i) { + $dirname =~ s/([^:])[\\\/]*\z/$1/; + unless( length($basename) ) { + ($basename,$dirname) = fileparse $dirname; + $dirname =~ s/([^:])[\\\/]*\z/$1/; + } + } + elsif ($fstype =~ /AmigaOS/i) { + if ( $dirname =~ /:\z/) { return $dirname } chop $dirname; - $dirname =~ s:[^/]+$:: unless $basename; - $dirname = '.' unless $dirname; + $dirname =~ s#[^:/]+\z## unless length($basename); + } + else { + $dirname =~ s:(.)/*\z:$1:s; + unless( length($basename) ) { + local($File::Basename::Fileparse_fstype) = $fstype; + ($basename,$dirname) = fileparse $dirname; + $dirname =~ s:(.)/*\z:$1:s; + } } $dirname; } -$Fileparse_fstype = $Config{'osname'}; +fileparse_set_fstype $^O; 1;