$basename = basename($fullname,@suffixlist);
$dirname = dirname($fullname);
- ($name,$path,$suffix) = fileparse("lib/File/Basename.pm","\.pm");
+ ($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");
"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
+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
+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",
separator in the input file specification. The remainder of the input
file specification is then divided into B<name> and B<suffix> based on
the optional patterns you specify in C<@suffixlist>. Each element of
-this list is interpreted as a regular expression, and is matched
+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<name>. If this succeeds, the matching portion of
B<name> is removed and prepended to B<suffix>. By proper use of
C<@suffixlist>, you can remove file types or versions for examination.
=head1 EXAMPLES
-Using UNIX file syntax:
+Using Unix file syntax:
($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
- '\.book\d+');
+ qr{\.book\d+});
would yield
Similarly, using VMS syntax:
($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh',
- '\..*');
+ qr{\..*});
would yield
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).
+programmer compatibility with the Unix shell command basename(1).
=item C<dirname>
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
+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<lib/>, fileparse()
considers the directory name to be F<lib/>, while dirname() considers the
## use strict;
-use re 'taint';
+# A bit of juggling to insure that C<use re 'taint';> 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);
-use vars qw($VERSION $Fileparse_fstype $Fileparse_igncase);
-$VERSION = "2.6";
+$VERSION = "2.71";
# fileparse_set_fstype() - specify OS-based rules used in future
sub fileparse {
my($fullname,@suffices) = @_;
+ 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,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s);
$dirpath ||= ''; # should always be defined
}
}
- if ($fstype =~ /^MS(DOS|Win32)/i) {
- ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/);
- $dirpath .= '.\\' unless $dirpath =~ /[\\\/]$/;
+ if ($fstype =~ /^MS(DOS|Win32)|epoc/i) {
+ ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s);
+ $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/;
}
- elsif ($fstype =~ /^MacOS/i) {
- ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/);
+ 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 =~ /^AmigaOS/i) {
- ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/);
+ ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s);
$dirpath = './' unless $dirpath;
}
elsif ($fstype !~ /^VMS/i) { # default to Unix
- ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#);
- if ($^O eq 'VMS' and $fullname =~ m:/[^/]+/000000/?:) {
+ ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#s);
+ if ($^O eq 'VMS' and $fullname =~ m:^(/[^/]+/000000(/|$))(.*):) {
# dev:[000000] is top of VMS tree, similar to Unix '/'
- ($basename,$dirpath) = ('',$fullname);
+ # 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;
}
$tail = '';
foreach $suffix (@suffices) {
my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
- if ($basename =~ s/$pat//) {
+ if ($basename =~ s/$pat//s) {
$taint .= substr($suffix,0,0);
$tail = $1 . $tail;
}
}
$tail .= $taint if defined $tail; # avoid warning if $tail == undef
- wantarray ? ($basename . $taint, $dirpath . $taint, $tail)
- : $basename . $taint;
+ wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail)
+ : ($basename .= $taint);
}
if ($_[0] =~ m#/#) { $fstype = '' }
else { return $dirname || $ENV{DEFAULT} }
}
- if ($fstype =~ /MacOS/i) { return $dirname }
- elsif ($fstype =~ /MSDOS/i) {
- $dirname =~ s/([^:])[\\\/]*$/$1/;
- unless( length($basename) ) {
+ if ($fstype =~ /MacOS/i) {
+ if( !length($basename) && $dirname !~ /^[^:]+:\z/) {
+ $dirname =~ s/([^:]):\z/$1/s;
($basename,$dirname) = fileparse $dirname;
- $dirname =~ s/([^:])[\\\/]*$/$1/;
}
+ $dirname .= ":" unless $dirname =~ /:\z/;
}
- elsif ($fstype =~ /MSWin32/i) {
- $dirname =~ s/([^:])[\\\/]*$/$1/;
+ elsif ($fstype =~ /MS(DOS|Win32)|os2/i) {
+ $dirname =~ s/([^:])[\\\/]*\z/$1/;
unless( length($basename) ) {
($basename,$dirname) = fileparse $dirname;
- $dirname =~ s/([^:])[\\\/]*$/$1/;
+ $dirname =~ s/([^:])[\\\/]*\z/$1/;
}
}
elsif ($fstype =~ /AmigaOS/i) {
- if ( $dirname =~ /:$/) { return $dirname }
+ if ( $dirname =~ /:\z/) { return $dirname }
chop $dirname;
- $dirname =~ s#[^:/]+$## unless length($basename);
+ $dirname =~ s#[^:/]+\z## unless length($basename);
}
- else {
- $dirname =~ s:(.)/*$:$1:;
+ else {
+ $dirname =~ s:(.)/*\z:$1:s;
unless( length($basename) ) {
local($File::Basename::Fileparse_fstype) = $fstype;
($basename,$dirname) = fileparse $dirname;
- $dirname =~ s:(.)/*$:$1:;
+ $dirname =~ s:(.)/*\z:$1:s;
}
}
projects / p5sagit/p5-mst-13.2.git / blobdiff