diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/File')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Basename.pm | 18 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/CheckTree.pm | 240 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Copy.pm | 156 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/DosGlob.pm | 6 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Fetch.pm | 62 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Find.pm | 14 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Glob.pm | 2 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec.pm | 2 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm | 15 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm | 8 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Functions.pm | 24 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Mac.pm | 8 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/OS2.pm | 10 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Unix.pm | 76 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/VMS.pm | 23 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Win32.pm | 13 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Temp.pm | 1613 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Which.pm | 281 |
18 files changed, 1351 insertions, 1220 deletions
diff --git a/Master/tlpkg/tlperl/lib/File/Basename.pm b/Master/tlpkg/tlperl/lib/File/Basename.pm index ad98d24d194..4b4fe95cfd7 100644 --- a/Master/tlpkg/tlperl/lib/File/Basename.pm +++ b/Master/tlpkg/tlperl/lib/File/Basename.pm @@ -54,7 +54,7 @@ our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase); require Exporter; @ISA = qw(Exporter); @EXPORT = qw(fileparse fileparse_set_fstype basename dirname); -$VERSION = "2.84"; +$VERSION = "2.85"; fileparse_set_fstype($^O); @@ -64,14 +64,14 @@ fileparse_set_fstype($^O); =item C<fileparse> X<fileparse> - my($filename, $directories, $suffix) = fileparse($path); - my($filename, $directories, $suffix) = fileparse($path, @suffixes); - my $filename = fileparse($path, @suffixes); + my($filename, $dirs, $suffix) = fileparse($path); + my($filename, $dirs, $suffix) = fileparse($path, @suffixes); + my $filename = fileparse($path, @suffixes); -The C<fileparse()> routine divides a file path into its $directories, $filename +The C<fileparse()> routine divides a file path into its $dirs, $filename and (optionally) the filename $suffix. -$directories contains everything up to and including the last +$dirs contains everything up to and including the last directory separator in the $path including the volume (if applicable). The remainder of the $path is the $filename. @@ -95,7 +95,7 @@ If type is non-Unix (see L</fileparse_set_fstype>) then the pattern matching for suffix removal is performed case-insensitively, since those systems are not case-sensitive when opening existing files. -You are guaranteed that C<$directories . $filename . $suffix> will +You are guaranteed that C<$dirs . $filename . $suffix> will denote the same location as the original $path. =cut @@ -250,10 +250,10 @@ C<fileparse()>. Only on VMS (where there is no ambiguity between the file and directory portions of a path) and AmigaOS (possibly due to an implementation quirk in this module) does C<dirname()> work like C<fileparse($path)>, returning just the -$directories. +$dirs. # On VMS and AmigaOS - my $directories = dirname($path); + my $dirs = dirname($path); When using Unix or MSDOS syntax this emulates the C<dirname(1)> shell function which is subtly different from how C<fileparse()> works. It returns all but diff --git a/Master/tlpkg/tlperl/lib/File/CheckTree.pm b/Master/tlpkg/tlperl/lib/File/CheckTree.pm deleted file mode 100644 index 8107c7ac689..00000000000 --- a/Master/tlpkg/tlperl/lib/File/CheckTree.pm +++ /dev/null @@ -1,240 +0,0 @@ -package File::CheckTree; - -use 5.006; -use Cwd; -use Exporter; -use File::Spec; -use warnings; -use strict; - -use if $] > 5.017, 'deprecate'; - -our $VERSION = '4.42'; -our @ISA = qw(Exporter); -our @EXPORT = qw(validate); - -=head1 NAME - -File::CheckTree - run many filetest checks on a tree - -=head1 SYNOPSIS - - use File::CheckTree; - - $num_warnings = validate( q{ - /vmunix -e || die - /boot -e || die - /bin cd - csh -ex - csh !-ug - sh -ex - sh !-ug - /usr -d || warn "What happened to $file?\n" - }); - -=head1 DESCRIPTION - -The validate() routine takes a single multiline string consisting of -directives, each containing a filename plus a file test to try on it. -(The file test may also be a "cd", causing subsequent relative filenames -to be interpreted relative to that directory.) After the file test -you may put C<|| die> to make it a fatal error if the file test fails. -The default is C<|| warn>. The file test may optionally have a "!' prepended -to test for the opposite condition. If you do a cd and then list some -relative filenames, you may want to indent them slightly for readability. -If you supply your own die() or warn() message, you can use $file to -interpolate the filename. - -Filetests may be bunched: "-rwx" tests for all of C<-r>, C<-w>, and C<-x>. -Only the first failed test of the bunch will produce a warning. - -The routine returns the number of warnings issued. - -=head1 AUTHOR - -File::CheckTree was derived from lib/validate.pl which was -written by Larry Wall. -Revised by Paul Grassie <F<grassie@perl.com>> in 2002. - -=head1 HISTORY - -File::CheckTree used to not display fatal error messages. -It used to count only those warnings produced by a generic C<|| warn> -(and not those in which the user supplied the message). In addition, -the validate() routine would leave the user program in whatever -directory was last entered through the use of "cd" directives. -These bugs were fixed during the development of perl 5.8. -The first fixed version of File::CheckTree was 4.2. - -=cut - -my $Warnings; - -sub validate { - my ($starting_dir, $file, $test, $cwd, $oldwarnings); - - $starting_dir = cwd; - - $cwd = ""; - $Warnings = 0; - - foreach my $check (split /\n/, $_[0]) { - my ($testlist, @testlist); - - # skip blanks/comments - next if $check =~ /^\s*#/ || $check =~ /^\s*$/; - - # Todo: - # should probably check for invalid directives and die - # but earlier versions of File::CheckTree did not do this either - - # split a line like "/foo -r || die" - # so that $file is "/foo", $test is "-r || die" - # (making special allowance for quoted filenames). - if ($check =~ m/^\s*"([^"]+)"\s+(.*?)\s*$/ or - $check =~ m/^\s*'([^']+)'\s+(.*?)\s*$/ or - $check =~ m/^\s*(\S+?)\s+(\S.*?)\s*$/) - { - ($file, $test) = ($1,$2); - } - else { - die "Malformed line: '$check'"; - }; - - # change a $test like "!-ug || die" to "!-Z || die", - # capturing the bundled tests (e.g. "ug") in $2 - if ($test =~ s/ ^ (!?-) (\w{2,}) \b /$1Z/x) { - $testlist = $2; - # split bundled tests, e.g. "ug" to 'u', 'g' - @testlist = split(//, $testlist); - } - else { - # put in placeholder Z for stand-alone test - @testlist = ('Z'); - } - - # will compare these two later to stop on 1st warning w/in a bundle - $oldwarnings = $Warnings; - - foreach my $one (@testlist) { - # examples of $test: "!-Z || die" or "-w || warn" - my $this = $test; - - # expand relative $file to full pathname if preceded by cd directive - $file = File::Spec->catfile($cwd, $file) - if $cwd && !File::Spec->file_name_is_absolute($file); - - # put filename in after the test operator - $this =~ s/(-\w\b)/$1 "\$file"/g; - - # change the "-Z" representing a bundle with the $one test - $this =~ s/-Z/-$one/; - - # if it's a "cd" directive... - if ($this =~ /^cd\b/) { - # add "|| die ..." - $this .= ' || die "cannot cd to $file\n"'; - # expand "cd" directive with directory name - $this =~ s/\bcd\b/chdir(\$cwd = '$file')/; - } - else { - # add "|| warn" as a default disposition - $this .= ' || warn' unless $this =~ /\|\|/; - - # change a generic ".. || die" or ".. || warn" - # to call valmess instead of die/warn directly - # valmess will look up the error message from %Val_Message - $this =~ s/ ^ ( (\S+) \s+ \S+ ) \s* \|\| \s* (die|warn) \s* $ - /$1 || valmess('$3', '$2', \$file)/x; - } - - { - # count warnings, either from valmess or '-r || warn "my msg"' - # also, call any pre-existing signal handler for __WARN__ - my $orig_sigwarn = $SIG{__WARN__}; - local $SIG{__WARN__} = sub { - ++$Warnings; - if ( $orig_sigwarn ) { - $orig_sigwarn->(@_); - } - else { - warn "@_"; - } - }; - - # do the test - eval $this; - - # re-raise an exception caused by a "... || die" test - if (my $err = $@) { - # in case of any cd directives, return from whence we came - if ($starting_dir ne cwd) { - chdir($starting_dir) || die "$starting_dir: $!"; - } - die $err; - } - } - - # stop on 1st warning within a bundle of tests - last if $Warnings > $oldwarnings; - } - } - - # in case of any cd directives, return from whence we came - if ($starting_dir ne cwd) { - chdir($starting_dir) || die "chdir $starting_dir: $!"; - } - - return $Warnings; -} - -my %Val_Message = ( - 'r' => "is not readable by uid $>.", - 'w' => "is not writable by uid $>.", - 'x' => "is not executable by uid $>.", - 'o' => "is not owned by uid $>.", - 'R' => "is not readable by you.", - 'W' => "is not writable by you.", - 'X' => "is not executable by you.", - 'O' => "is not owned by you.", - 'e' => "does not exist.", - 'z' => "does not have zero size.", - 's' => "does not have non-zero size.", - 'f' => "is not a plain file.", - 'd' => "is not a directory.", - 'l' => "is not a symbolic link.", - 'p' => "is not a named pipe (FIFO).", - 'S' => "is not a socket.", - 'b' => "is not a block special file.", - 'c' => "is not a character special file.", - 'u' => "does not have the setuid bit set.", - 'g' => "does not have the setgid bit set.", - 'k' => "does not have the sticky bit set.", - 'T' => "is not a text file.", - 'B' => "is not a binary file." -); - -sub valmess { - my ($disposition, $test, $file) = @_; - my $ferror; - - if ($test =~ / ^ (!?) -(\w) \s* $ /x) { - my ($neg, $ftype) = ($1, $2); - - $ferror = "$file $Val_Message{$ftype}"; - - if ($neg eq '!') { - $ferror =~ s/ is not / should not be / || - $ferror =~ s/ does not / should not / || - $ferror =~ s/ not / /; - } - } - else { - $ferror = "Can't do $test $file.\n"; - } - - die "$ferror\n" if $disposition eq 'die'; - warn "$ferror\n"; -} - -1; diff --git a/Master/tlpkg/tlperl/lib/File/Copy.pm b/Master/tlpkg/tlperl/lib/File/Copy.pm index 19a5838c0a8..95fb4e18f34 100644 --- a/Master/tlpkg/tlperl/lib/File/Copy.pm +++ b/Master/tlpkg/tlperl/lib/File/Copy.pm @@ -22,7 +22,7 @@ sub syscopy; sub cp; sub mv; -$VERSION = '2.26'; +$VERSION = '2.30'; require Exporter; @ISA = qw(Exporter); @@ -41,44 +41,6 @@ sub carp { goto &Carp::carp; } -# Look up the feature settings on VMS using VMS::Feature when available. - -my $use_vms_feature = 0; -BEGIN { - if ($^O eq 'VMS') { - if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { - $use_vms_feature = 1; - } - } -} - -# Need to look up the UNIX report mode. This may become a dynamic mode -# in the future. -sub _vms_unix_rpt { - my $unix_rpt; - if ($use_vms_feature) { - $unix_rpt = VMS::Feature::current("filename_unix_report"); - } else { - my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; - $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; - } - return $unix_rpt; -} - -# Need to look up the EFS character set mode. This may become a dynamic -# mode in the future. -sub _vms_efs { - my $efs; - if ($use_vms_feature) { - $efs = VMS::Feature::current("efs_charset"); - } else { - my $env_efs = $ENV{'DECC$EFS_CHARSET'} || ''; - $efs = $env_efs =~ /^[ET1]/i; - } - return $efs; -} - - sub _catname { my($from, $to) = @_; if (not defined &basename) { @@ -158,50 +120,21 @@ sub copy { && !($from_a_handle && $^O eq 'NetWare') ) { - my $copy_to = $to; - - if ($^O eq 'VMS' && -e $from) { - - if (! -d $to && ! -d $from) { - - my $vms_efs = _vms_efs(); - my $unix_rpt = _vms_unix_rpt(); - my $unix_mode = 0; - my $from_unix = 0; - $from_unix = 1 if ($from =~ /^\.\.?$/); - my $from_vms = 0; - $from_vms = 1 if ($from =~ m#[\[<\]]#); - - # Need to know if we are in Unix mode. - if ($from_vms == $from_unix) { - $unix_mode = $unix_rpt; - } else { - $unix_mode = $from_unix; - } - - # VMS has sticky defaults on extensions, which means that - # if there is a null extension on the destination file, it - # will inherit the extension of the source file - # So add a '.' for a null extension. - - # In unix_rpt mode, the trailing dot should not be added. - - if ($vms_efs) { - $copy_to = $to; - } else { - $copy_to = VMS::Filespec::vmsify($to); - } - my ($vol, $dirs, $file) = File::Spec->splitpath($copy_to); - $file = $file . '.' - unless (($file =~ /(?<!\^)\./) || $unix_rpt); - $copy_to = File::Spec->catpath($vol, $dirs, $file); - - # Get rid of the old versions to be like UNIX - 1 while unlink $copy_to; - } + if ($^O eq 'VMS' && -e $from + && ! -d $to && ! -d $from) { + + # VMS natively inherits path components from the source of a + # copy, but we want the Unixy behavior of inheriting from + # the current working directory. Also, default in a trailing + # dot for null file types. + + $to = VMS::Filespec::rmsexpand(VMS::Filespec::vmsify($to), '.'); + + # Get rid of the old versions to be like UNIX + 1 while unlink $to; } - return syscopy($from, $copy_to) || 0; + return syscopy($from, $to) || 0; } my $closefrom = 0; @@ -331,49 +264,21 @@ sub _move { unlink $to; } - my $rename_to = $to; - if (-$^O eq 'VMS' && -e $from) { - - if (! -d $to && ! -d $from) { - - my $vms_efs = _vms_efs(); - my $unix_rpt = _vms_unix_rpt(); - my $unix_mode = 0; - my $from_unix = 0; - $from_unix = 1 if ($from =~ /^\.\.?$/); - my $from_vms = 0; - $from_vms = 1 if ($from =~ m#[\[<\]]#); - - # Need to know if we are in Unix mode. - if ($from_vms == $from_unix) { - $unix_mode = $unix_rpt; - } else { - $unix_mode = $from_unix; - } - - # VMS has sticky defaults on extensions, which means that - # if there is a null extension on the destination file, it - # will inherit the extension of the source file - # So add a '.' for a null extension. - - # In unix_rpt mode, the trailing dot should not be added. - - if ($vms_efs) { - $rename_to = $to; - } else { - $rename_to = VMS::Filespec::vmsify($to); - } - my ($vol, $dirs, $file) = File::Spec->splitpath($rename_to); - $file = $file . '.' - unless (($file =~ /(?<!\^)\./) || $unix_rpt); - $rename_to = File::Spec->catpath($vol, $dirs, $file); + if ($^O eq 'VMS' && -e $from + && ! -d $to && ! -d $from) { + + # VMS natively inherits path components from the source of a + # copy, but we want the Unixy behavior of inheriting from + # the current working directory. Also, default in a trailing + # dot for null file types. + + $to = VMS::Filespec::rmsexpand(VMS::Filespec::vmsify($to), '.'); # Get rid of the old versions to be like UNIX - 1 while unlink $rename_to; - } + 1 while unlink $to; } - return 1 if rename $from, $rename_to; + return 1 if rename $from, $to; # Did rename return an error even though it succeeded, because $to # is on a remote NFS file system, and NFS lost the server's ack? @@ -435,9 +340,9 @@ File::Copy - Copy files or filehandles use File::Copy; - copy("file1","file2") or die "Copy failed: $!"; + copy("sourcefile","destinationfile") or die "Copy failed: $!"; copy("Copy.pm",\*STDOUT); - move("/dev1/fileA","/dev2/fileB"); + move("/dev1/sourcefile","/dev2/destinationfile"); use File::Copy "cp"; @@ -461,8 +366,11 @@ argument may be a string, a FileHandle reference or a FileHandle glob. Obviously, if the first argument is a filehandle of some sort, it will be read from, and if it is a file I<name> it will be opened for reading. Likewise, the second argument will be -written to (and created if need be). Trying to copy a file on top -of itself is an error. +written to. If the second argument does not exist but the parent +directory does exist, then it will be created. Trying to copy +a file into a non-existent directory is an error. +Trying to copy a file on top of itself is also an error. +C<copy> will not overwrite read-only files. If the destination (second argument) already exists and is a directory, and the source (first argument) is not a filehandle, then the source diff --git a/Master/tlpkg/tlperl/lib/File/DosGlob.pm b/Master/tlpkg/tlperl/lib/File/DosGlob.pm index c90bebb2780..9d40a363470 100644 --- a/Master/tlpkg/tlperl/lib/File/DosGlob.pm +++ b/Master/tlpkg/tlperl/lib/File/DosGlob.pm @@ -6,7 +6,7 @@ package File::DosGlob; -our $VERSION = '1.10'; +our $VERSION = '1.12'; use strict; use warnings; @@ -156,7 +156,7 @@ sub glob { } #print "Sould have "GOT" vs "Got"!\n"; #FIXME: There should be checking for this. - # How or what should be done about failure is beond me. + # How or what should be done about failure is beyond me. } if ( $#appendpat != -1 ) { @@ -257,7 +257,7 @@ glob() =head1 BUGS Should probably be built into the core, and needs to stop -pandering to DOS habits. Needs a dose of optimizium too. +pandering to DOS habits. Needs a dose of optimization too. =head1 AUTHOR diff --git a/Master/tlpkg/tlperl/lib/File/Fetch.pm b/Master/tlpkg/tlperl/lib/File/Fetch.pm index 37f7bc6ca9e..7d6a263e2bf 100644 --- a/Master/tlpkg/tlperl/lib/File/Fetch.pm +++ b/Master/tlpkg/tlperl/lib/File/Fetch.pm @@ -19,27 +19,30 @@ use Locale::Maketext::Simple Style => 'gettext'; use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT $BLACKLIST $METHOD_FAIL $VERSION $METHODS - $FTP_PASSIVE $TIMEOUT $DEBUG $WARN + $FTP_PASSIVE $TIMEOUT $DEBUG $WARN $FORCEIPV4 ]; -$VERSION = '0.38'; +$VERSION = '0.48'; $VERSION = eval $VERSION; # avoid warnings with development releases $PREFER_BIN = 0; # XXX TODO implement $FROM_EMAIL = 'File-Fetch@example.com'; $USER_AGENT = "File::Fetch/$VERSION"; $BLACKLIST = [qw|ftp|]; +push @$BLACKLIST, qw|lftp| if $^O eq 'dragonfly'; $METHOD_FAIL = { }; $FTP_PASSIVE = 1; $TIMEOUT = 0; $DEBUG = 0; $WARN = 1; +$FORCEIPV4 = 0; ### methods available to fetch the file depending on the scheme $METHODS = { http => [ qw|lwp httptiny wget curl lftp fetch httplite lynx iosock| ], ftp => [ qw|lwp netftp wget curl lftp fetch ncftp ftp| ], file => [ qw|lwp lftp file| ], - rsync => [ qw|rsync| ] + rsync => [ qw|rsync| ], + git => [ qw|git| ], }; ### silly warnings ### @@ -87,7 +90,7 @@ File::Fetch - A generic file fetching mechanism File::Fetch is a generic file fetching mechanism. It allows you to fetch any file pointed to by a C<ftp>, C<http>, -C<file>, or C<rsync> uri by a number of different means. +C<file>, C<git> or C<rsync> uri by a number of different means. See the C<HOW IT WORKS> section further down for details. @@ -1194,6 +1197,8 @@ sub _curl_fetch { ### these long opts are self explanatory - I like that -jmb my $cmd = [ $curl, '-q' ]; + push(@$cmd, '-4') if $^O eq 'netbsd' && $FORCEIPV4; # only seen this on NetBSD so far + push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT; push(@$cmd, '--silent') unless $DEBUG; @@ -1402,6 +1407,52 @@ sub _rsync_fetch { } +### use git to fetch files +sub _git_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + my $git; + unless ( $git = can_run('git') ) { + $METHOD_FAIL->{'git'} = 1; + return; + } + + my $cmd = [ $git, 'clone' ]; + + #push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT; + + push(@$cmd, '--quiet') unless $DEBUG; + + ### DO NOT quote things for IPC::Run, it breaks stuff. + push @$cmd, $self->uri, $to; + + ### with IPC::Cmd > 0.41, this is fixed in teh library, + ### and there's no need for special casing any more. + ### DO NOT quote things for IPC::Run, it breaks stuff. + # $IPC::Cmd::USE_IPC_RUN + # ? ($to, $self->uri) + # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE); + + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { + + return $self->_error(loc("Command %1 failed: %2", + "@$cmd" || '', $captured || '')); + } + + return $to; + +} + ################################# # # Error code @@ -1454,6 +1505,7 @@ for what schemes, if available: http => LWP, HTTP::Lite, wget, curl, lftp, fetch, lynx, iosock ftp => LWP, Net::FTP, wget, curl, lftp, fetch, ncftp, ftp rsync => rsync + git => git If you'd like to disable the use of one or more of these utilities and/or modules, see the C<$BLACKLIST> variable further down. @@ -1470,6 +1522,8 @@ three platforms. C<iosock> is a very limited L<IO::Socket::INET> based mechanism for retrieving C<http> schemed urls. It doesn't follow redirects for instance. +C<git> only supports C<git://> style urls. + A special note about fetching files from an ftp uri: By default, all ftp connections are done in passive mode. To change diff --git a/Master/tlpkg/tlperl/lib/File/Find.pm b/Master/tlpkg/tlperl/lib/File/Find.pm index d1dbc522584..6cfdb59aef3 100644 --- a/Master/tlpkg/tlperl/lib/File/Find.pm +++ b/Master/tlpkg/tlperl/lib/File/Find.pm @@ -3,7 +3,7 @@ use 5.006; use strict; use warnings; use warnings::register; -our $VERSION = '1.23'; +our $VERSION = '1.27'; require Exporter; require Cwd; @@ -299,7 +299,7 @@ situations. You can disable these warnings by putting the statement no warnings 'File::Find'; -in the appropriate scope. See L<perllexwarn> for more info about lexical +in the appropriate scope. See L<warnings> for more info about lexical warnings. =head1 CAVEAT @@ -488,7 +488,7 @@ sub _find_opt { $cwd = VMS::Filespec::unixpath($cwd); # Apparently this is not expected to have a trailing space. - # To attempt to make VMS/UNIX conversions mostly reversable, + # To attempt to make VMS/UNIX conversions mostly reversible, # a trailing slash is needed. The run-time functions ignore the # resulting double slash, but it causes the perl tests to fail. $cwd =~ s#/\z##; @@ -809,7 +809,7 @@ sub _find_dir($$$) { else { $tmp = join('/',('..') x ($CdLvl-$Level)); } - die "Can't cd to $tmp from $dir_name" + die "Can't cd to $tmp from $dir_name: $!" unless chdir ($tmp); $CdLvl = $Level; } @@ -982,14 +982,16 @@ sub _find_dir_symlnk($$$) { # ignore if invalid symlink unless (defined $new_loc) { if (!defined -l _ && $dangling_symlinks) { + $fullname = undef; if (ref $dangling_symlinks eq 'CODE') { $dangling_symlinks->($FN, $dir_pref); } else { warnings::warnif "$dir_pref$FN is a dangling symbolic link\n"; } } - - $fullname = undef; + else { + $fullname = $loc_pref . $FN; + } $name = $dir_pref . $FN; $_ = ($no_chdir ? $name : $FN); { $wanted_callback->() }; diff --git a/Master/tlpkg/tlperl/lib/File/Glob.pm b/Master/tlpkg/tlperl/lib/File/Glob.pm index f144b5179dc..2b39dce6a8e 100644 --- a/Master/tlpkg/tlperl/lib/File/Glob.pm +++ b/Master/tlpkg/tlperl/lib/File/Glob.pm @@ -37,7 +37,7 @@ pop @{$EXPORT_TAGS{bsd_glob}}; # no "glob" @EXPORT_OK = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob'); -$VERSION = '1.20_01'; +$VERSION = '1.23'; sub import { require Exporter; diff --git a/Master/tlpkg/tlperl/lib/File/Spec.pm b/Master/tlpkg/tlperl/lib/File/Spec.pm index 6062c015179..01a616eaedc 100644 --- a/Master/tlpkg/tlperl/lib/File/Spec.pm +++ b/Master/tlpkg/tlperl/lib/File/Spec.pm @@ -3,7 +3,7 @@ package File::Spec; use strict; use vars qw(@ISA $VERSION); -$VERSION = '3.40'; +$VERSION = '3.48_01'; $VERSION =~ tr/_//; my %module = (MacOS => 'Mac', diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm b/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm index b27f7b15f19..b9e3703bf46 100644 --- a/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm +++ b/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.40'; +$VERSION = '3.48_01'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); @@ -92,15 +92,20 @@ from the following list: $ENV{'TEMP'} C:/temp -Since Perl 5.8.0, if running under taint mode, and if the environment +If running under taint mode, and if the environment variables are tainted, they are not used. =cut -my $tmpdir; sub tmpdir { - return $tmpdir if defined $tmpdir; - $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp' ); + my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TMP TEMP'); + return $cached if defined $cached; + $_[0]->_cache_tmpdir( + $_[0]->_tmpdir( + $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp' + ), + qw 'TMPDIR TMP TEMP' + ); } =item case_tolerant diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm b/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm index e7faa16086a..e5928b83558 100644 --- a/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm +++ b/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm @@ -3,7 +3,7 @@ package File::Spec::Epoc; use strict; use vars qw($VERSION @ISA); -$VERSION = '3.40'; +$VERSION = '3.48_01'; $VERSION =~ tr/_//; require File::Spec::Unix; @@ -20,10 +20,10 @@ File::Spec::Epoc - methods for Epoc file specs =head1 DESCRIPTION See File::Spec::Unix for a documentation of the methods provided -there. This package overrides the implementation of these methods, not +there. This package overrides the implementation of these methods, not the semantics. -This package is still work in progress ;-) +This package is still a work in progress. ;-) =cut @@ -38,7 +38,7 @@ sub case_tolerant { =item canonpath() No physical check on the filesystem, but a logical cleanup of a -path. On UNIX eliminated successive slashes and successive "/.". +path. On UNIX eliminated successive slashes and successive "/.". =back diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm b/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm index f5b9046aa5e..451f5bd735f 100644 --- a/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm +++ b/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm @@ -5,7 +5,7 @@ use strict; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); -$VERSION = '3.40'; +$VERSION = '3.48_01'; $VERSION =~ tr/_//; require Exporter; @@ -37,10 +37,30 @@ require Exporter; %EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] ); +require File::Spec::Unix; +my %udeps = ( + canonpath => [], + catdir => [qw(canonpath)], + catfile => [qw(canonpath catdir)], + case_tolerant => [], + curdir => [], + devnull => [], + rootdir => [], + updir => [], +); + foreach my $meth (@EXPORT, @EXPORT_OK) { my $sub = File::Spec->can($meth); no strict 'refs'; - *{$meth} = sub {&$sub('File::Spec', @_)}; + if (exists($udeps{$meth}) && $sub == File::Spec::Unix->can($meth) && + !(grep { + File::Spec->can($_) != File::Spec::Unix->can($_) + } @{$udeps{$meth}}) && + defined(&{"File::Spec::Unix::_fn_$meth"})) { + *{$meth} = \&{"File::Spec::Unix::_fn_$meth"}; + } else { + *{$meth} = sub {&$sub('File::Spec', @_)}; + } } diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm b/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm index 7f42171bc92..b0aacecf5a4 100644 --- a/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm +++ b/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.40'; +$VERSION = '3.48_01'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); @@ -374,10 +374,10 @@ directory on your startup volume. =cut -my $tmpdir; sub tmpdir { - return $tmpdir if defined $tmpdir; - $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR} ); + my $cached = $_[0]->_cached_tmpdir('TMPDIR'); + return $cached if defined $cached; + $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR} ), 'TMPDIR'); } =item updir diff --git a/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm b/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm index 7f60d68927a..7de0f891cb1 100644 --- a/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm +++ b/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.40'; +$VERSION = '3.48_01'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); @@ -35,11 +35,13 @@ sub _cwd { return Cwd::sys_cwd(); } -my $tmpdir; sub tmpdir { - return $tmpdir if defined $tmpdir; + my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TEMP TMP'); + return $cached if defined $cached; my @d = @ENV{qw(TMPDIR TEMP TMP)}; # function call could autovivivy - $tmpdir = $_[0]->_tmpdir( @d, '/tmp', '/' ); + $_[0]->_cache_tmpdir( + $_[0]->_tmpdir( @d, '/tmp', '/' ), qw 'TMPDIR TEMP TMP' + ); } sub catdir { diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm b/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm index a1a91b42607..c813cc170df 100644 --- a/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm +++ b/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm @@ -3,9 +3,21 @@ package File::Spec::Unix; use strict; use vars qw($VERSION); -$VERSION = '3.40'; +$VERSION = '3.48_01'; +my $xs_version = $VERSION; $VERSION =~ tr/_//; +unless (defined &canonpath) { + eval { + if ( $] >= 5.006 ) { + require XSLoader; + XSLoader::load("Cwd", $xs_version); + } else { + require Cwd; + } + }; +} + =head1 NAME File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules @@ -40,7 +52,7 @@ actually traverse the filesystem cleaning up paths like this. =cut -sub canonpath { +sub _pp_canonpath { my ($self,$path) = @_; return unless defined $path; @@ -69,6 +81,7 @@ sub canonpath { $path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx return "$node$path"; } +*canonpath = \&_pp_canonpath unless defined &canonpath; =item catdir() @@ -80,11 +93,12 @@ trailing slash :-) =cut -sub catdir { +sub _pp_catdir { my $self = shift; $self->canonpath(join('/', @_, '')); # '' because need a trailing '/' } +*catdir = \&_pp_catdir unless defined &catdir; =item catfile @@ -93,7 +107,7 @@ complete path ending with a filename =cut -sub catfile { +sub _pp_catfile { my $self = shift; my $file = $self->canonpath(pop @_); return $file unless @_; @@ -101,6 +115,7 @@ sub catfile { $dir .= "/" unless substr($dir,-1) eq "/"; return $dir.$file; } +*catfile = \&_pp_catfile unless defined &catfile; =item curdir @@ -109,6 +124,7 @@ Returns a string representation of the current directory. "." on UNIX. =cut sub curdir { '.' } +use constant _fn_curdir => "."; =item devnull @@ -117,6 +133,7 @@ Returns a string representation of the null device. "/dev/null" on UNIX. =cut sub devnull { '/dev/null' } +use constant _fn_devnull => "/dev/null"; =item rootdir @@ -125,6 +142,7 @@ Returns a string representation of the root directory. "/" on UNIX. =cut sub rootdir { '/' } +use constant _fn_rootdir => "/"; =item tmpdir @@ -140,21 +158,33 @@ is tainted, it is not used. =cut -my $tmpdir; +my ($tmpdir, %tmpenv); +# Cache and return the calculated tmpdir, recording which env vars +# determined it. +sub _cache_tmpdir { + @tmpenv{@_[2..$#_]} = @ENV{@_[2..$#_]}; + return $tmpdir = $_[1]; +} +# Retrieve the cached tmpdir, checking first whether relevant env vars have +# changed and invalidated the cache. +sub _cached_tmpdir { + shift; + local $^W; + return if grep $ENV{$_} ne $tmpenv{$_}, @_; + return $tmpdir; +} sub _tmpdir { - return $tmpdir if defined $tmpdir; my $self = shift; my @dirlist = @_; - { - no strict 'refs'; - if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0 - require Scalar::Util; - @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; - } - elsif ($] < 5.007) { # No ${^TAINT} before 5.8 - @dirlist = grep { eval { eval('1'.substr $_,0,0) } } @dirlist; - } + my $taint = do { no strict 'refs'; ${"\cTAINT"} }; + if ($taint) { # Check for taint mode on perl >= 5.8.0 + require Scalar::Util; + @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; + } + elsif ($] < 5.007) { # No ${^TAINT} before 5.8 + @dirlist = grep { eval { eval('1'.substr $_,0,0) } } @dirlist; } + foreach (@dirlist) { next unless defined && -d && -w _; $tmpdir = $_; @@ -162,12 +192,22 @@ sub _tmpdir { } $tmpdir = $self->curdir unless defined $tmpdir; $tmpdir = defined $tmpdir && $self->canonpath($tmpdir); + if ( !$self->file_name_is_absolute($tmpdir) ) { + # See [perl #120593] for the full details + # If possible, return a full path, rather than '.' or 'lib', but + # jump through some hoops to avoid returning a tainted value. + ($tmpdir) = grep { + $taint ? ! Scalar::Util::tainted($_) : + $] < 5.007 ? eval { eval('1'.substr $_,0,0) } : 1 + } $self->rel2abs($tmpdir), $tmpdir; + } return $tmpdir; } sub tmpdir { - return $tmpdir if defined $tmpdir; - $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ); + my $cached = $_[0]->_cached_tmpdir('TMPDIR'); + return $cached if defined $cached; + $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ), 'TMPDIR'); } =item updir @@ -177,6 +217,7 @@ Returns a string representation of the parent directory. ".." on UNIX. =cut sub updir { '..' } +use constant _fn_updir => ".."; =item no_upwards @@ -198,6 +239,7 @@ is not or is significant when comparing file specifications. =cut sub case_tolerant { 0 } +use constant _fn_case_tolerant => 0; =item file_name_is_absolute diff --git a/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm b/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm index 6af1ac0b3d1..3072fabb6ab 100644 --- a/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm +++ b/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.40'; +$VERSION = '3.48_01'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); @@ -27,7 +27,7 @@ there. This package overrides the implementation of these methods, not the semantics. The default behavior is to allow either VMS or Unix syntax on input and to -return VMS syntax on output unless Unix syntax has been explicity requested +return VMS syntax on output unless Unix syntax has been explicitly requested via the C<DECC$FILENAME_UNIX_REPORT> CRTL feature. =over 4 @@ -271,21 +271,22 @@ from the following list or '' if none are writable: sys$scratch: $ENV{TMPDIR} -Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR} +If running under taint mode, and if $ENV{TMPDIR} is tainted, it is not used. =cut -my $tmpdir; sub tmpdir { my $self = shift @_; + my $tmpdir = $self->_cached_tmpdir('TMPDIR'); return $tmpdir if defined $tmpdir; if ($self->_unix_rpt) { $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR}); - return $tmpdir; } - - $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); + else { + $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); + } + $self->_cache_tmpdir($tmpdir, 'TMPDIR'); } =item updir (override) @@ -335,14 +336,14 @@ sub file_name_is_absolute { $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file}; return scalar($file =~ m!^/!s || $file =~ m![<\[][^.\-\]>]! || - $file =~ /:[^<\[]/); + $file =~ /^[A-Za-z0-9_\$\-\~]+(?<!\^):/); } =item splitpath (override) - ($volume,$directories,$file) = File::Spec->splitpath( $path ); - ($volume,$directories,$file) = File::Spec->splitpath( $path, - $no_file ); + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, + $no_file ); Passing a true value for C<$no_file> indicates that the path being split only contains directory components, even on systems where you diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm b/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm index ae74a265931..6c063b5fdb6 100644 --- a/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm +++ b/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm @@ -5,7 +5,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.40'; +$VERSION = '3.48_01'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); @@ -62,13 +62,13 @@ from the following list: The SYS:/temp is preferred in Novell NetWare and the C:\system\temp for Symbian (the File::Spec::Win32 is used also for those platforms). -Since Perl 5.8.0, if running under taint mode, and if the environment +If running under taint mode, and if the environment variables are tainted, they are not used. =cut -my $tmpdir; sub tmpdir { + my $tmpdir = $_[0]->_cached_tmpdir(qw(TMPDIR TEMP TMP)); return $tmpdir if defined $tmpdir; $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ), 'SYS:/temp', @@ -76,6 +76,7 @@ sub tmpdir { 'C:/temp', '/tmp', '/' ); + $_[0]->_cache_tmpdir($tmpdir, qw(TMPDIR TEMP TMP)); } =item case_tolerant @@ -188,9 +189,9 @@ sub canonpath { =item splitpath - ($volume,$directories,$file) = File::Spec->splitpath( $path ); - ($volume,$directories,$file) = File::Spec->splitpath( $path, - $no_file ); + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, + $no_file ); Splits a path into volume, directory, and filename portions. Assumes that the last file is a path unless the path ends in '\\', '\\.', '\\..' diff --git a/Master/tlpkg/tlperl/lib/File/Temp.pm b/Master/tlpkg/tlperl/lib/File/Temp.pm index ac57c260c8f..817c6d90c6b 100644 --- a/Master/tlpkg/tlperl/lib/File/Temp.pm +++ b/Master/tlpkg/tlperl/lib/File/Temp.pm @@ -1,150 +1,17 @@ package File::Temp; +# ABSTRACT: return name and handle of a temporary file safely +our $VERSION = '0.2304'; # VERSION -=head1 NAME - -File::Temp - return name and handle of a temporary file safely - -=begin __INTERNALS - -=head1 PORTABILITY - -This section is at the top in order to provide easier access to -porters. It is not expected to be rendered by a standard pod -formatting tool. Please skip straight to the SYNOPSIS section if you -are not trying to port this module to a new platform. - -This module is designed to be portable across operating systems and it -currently supports Unix, VMS, DOS, OS/2, Windows and Mac OS -(Classic). When porting to a new OS there are generally three main -issues that have to be solved: - -=over 4 - -=item * - -Can the OS unlink an open file? If it can not then the -C<_can_unlink_opened_file> method should be modified. - -=item * - -Are the return values from C<stat> reliable? By default all the -return values from C<stat> are compared when unlinking a temporary -file using the filename and the handle. Operating systems other than -unix do not always have valid entries in all fields. If utility function -C<File::Temp::unlink0> fails then the C<stat> comparison should be -modified accordingly. - -=item * - -Security. Systems that can not support a test for the sticky bit -on a directory can not use the MEDIUM and HIGH security tests. -The C<_can_do_level> method should be modified accordingly. - -=back - -=end __INTERNALS - -=head1 SYNOPSIS - - use File::Temp qw/ tempfile tempdir /; - - $fh = tempfile(); - ($fh, $filename) = tempfile(); - - ($fh, $filename) = tempfile( $template, DIR => $dir); - ($fh, $filename) = tempfile( $template, SUFFIX => '.dat'); - ($fh, $filename) = tempfile( $template, TMPDIR => 1 ); - - binmode( $fh, ":utf8" ); - - $dir = tempdir( CLEANUP => 1 ); - ($fh, $filename) = tempfile( DIR => $dir ); - -Object interface: - - require File::Temp; - use File::Temp (); - use File::Temp qw/ :seekable /; - - $fh = File::Temp->new(); - $fname = $fh->filename; - - $fh = File::Temp->new(TEMPLATE => $template); - $fname = $fh->filename; - - $tmp = File::Temp->new( UNLINK => 0, SUFFIX => '.dat' ); - print $tmp "Some data\n"; - print "Filename is $tmp\n"; - $tmp->seek( 0, SEEK_END ); - -The following interfaces are provided for compatibility with -existing APIs. They should not be used in new code. - -MkTemp family: - - use File::Temp qw/ :mktemp /; - - ($fh, $file) = mkstemp( "tmpfileXXXXX" ); - ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix); - - $tmpdir = mkdtemp( $template ); - - $unopened_file = mktemp( $template ); - -POSIX functions: - - use File::Temp qw/ :POSIX /; - - $file = tmpnam(); - $fh = tmpfile(); - ($fh, $file) = tmpnam(); - -Compatibility functions: - - $unopened_file = File::Temp::tempnam( $dir, $pfx ); - -=head1 DESCRIPTION - -C<File::Temp> can be used to create and open temporary files in a safe -way. There is both a function interface and an object-oriented -interface. The File::Temp constructor or the tempfile() function can -be used to return the name and the open filehandle of a temporary -file. The tempdir() function can be used to create a temporary -directory. - -The security aspect of temporary file creation is emphasized such that -a filehandle and filename are returned together. This helps guarantee -that a race condition can not occur where the temporary file is -created by another process between checking for the existence of the -file and its opening. Additional security levels are provided to -check, for example, that the sticky bit is set on world writable -directories. See L<"safe_level"> for more information. - -For compatibility with popular C library functions, Perl implementations of -the mkstemp() family of functions are provided. These are, mkstemp(), -mkstemps(), mkdtemp() and mktemp(). - -Additionally, implementations of the standard L<POSIX|POSIX> -tmpnam() and tmpfile() functions are provided if required. - -Implementations of mktemp(), tmpnam(), and tempnam() are provided, -but should be used with caution since they return only a filename -that was valid when function was called, so cannot guarantee -that the file will not exist by the time the caller opens the filename. - -Filehandles returned by these functions support the seekable methods. - -=cut - -# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls -# People would like a version on 5.004 so give them what they want :-) -use 5.004; +# Toolchain targets v5.8.1, but we'll try to support back to v5.6 anyway. +# It might be possible to make this v5.5, but many v5.6isms are creeping +# into the code and tests. +use 5.006; use strict; use Carp; use File::Spec 0.8; use Cwd (); -use File::Path qw/ rmtree /; +use File::Path 2.06 qw/ rmtree /; use Fcntl 1.03; use IO::Seekable; # For SEEK_* use Errno; @@ -162,19 +29,19 @@ eval { require Carp::Heavy; }; require Symbol if $] < 5.006; ### For the OO interface -use base qw/ IO::Handle IO::Seekable /; +use parent 0.221 qw/ IO::Handle IO::Seekable /; use overload '""' => "STRINGIFY", '0+' => "NUMIFY", fallback => 1; # use 'our' on v5.6.0 -use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL); +use vars qw(@EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL); $DEBUG = 0; $KEEP_ALL = 0; # We are exporting functions -use base qw/Exporter/; +use Exporter 5.57 'import'; # 5.57 lets us import 'import' # Export list - to allow fine tuning of export table @@ -205,10 +72,6 @@ use base qw/Exporter/; # add contents of these tags to @EXPORT Exporter::export_tags('POSIX','mktemp','seekable'); -# Version number - -$VERSION = '0.23'; - # This is a list of characters that can be used in random filenames my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z @@ -890,7 +753,7 @@ sub _can_do_level { foreach my $file (@files) { # close the filehandle without checking its state # in order to make real sure that this is closed - # if its already closed then I dont care about the answer + # if its already closed then I don't care about the answer # probably a better way to do this close($file->[0]); # file handle is [0] @@ -1017,53 +880,6 @@ sub _parse_args { return( \@template, \%args ); } -=head1 OBJECT-ORIENTED INTERFACE - -This is the primary interface for interacting with -C<File::Temp>. Using the OO interface a temporary file can be created -when the object is constructed and the file can be removed when the -object is no longer required. - -Note that there is no method to obtain the filehandle from the -C<File::Temp> object. The object itself acts as a filehandle. The object -isa C<IO::Handle> and isa C<IO::Seekable> so all those methods are -available. - -Also, the object is configured such that it stringifies to the name of the -temporary file and so can be compared to a filename directly. It numifies -to the C<refaddr> the same as other handles and so can be compared to other -handles with C<==>. - - $fh eq $filename # as a string - $fh != \*STDOUT # as a number - -=over 4 - -=item B<new> - -Create a temporary file object. - - my $tmp = File::Temp->new(); - -by default the object is constructed as if C<tempfile> -was called without options, but with the additional behaviour -that the temporary file is removed by the object destructor -if UNLINK is set to true (the default). - -Supported arguments are the same as for C<tempfile>: UNLINK -(defaulting to true), DIR, EXLOCK and SUFFIX. Additionally, the filename -template is specified using the TEMPLATE option. The OPEN option -is not supported (the file is always opened). - - $tmp = File::Temp->new( TEMPLATE => 'tempXXXXX', - DIR => 'mydir', - SUFFIX => '.dat'); - -Arguments are case insensitive. - -Can call croak() if an error occurs. - -=cut sub new { my $proto = shift; @@ -1101,23 +917,6 @@ sub new { return $fh; } -=item B<newdir> - -Create a temporary directory using an object oriented interface. - - $dir = File::Temp->newdir(); - -By default the directory is deleted when the object goes out of scope. - -Supports the same options as the C<tempdir> function. Note that directories -created with this method default to CLEANUP => 1. - - $dir = File::Temp->newdir( $template, %options ); - -A template may be specified either with a leading template or -with a TEMPLATE argument. - -=cut sub newdir { my $self = shift; @@ -1142,17 +941,6 @@ sub newdir { }, "File::Temp::Dir"; } -=item B<filename> - -Return the name of the temporary file associated with this object -(if the object was created using the "new" constructor). - - $filename = $tmp->filename; - -This method is called automatically when the object is used as -a string. - -=cut sub filename { my $self = shift; @@ -1171,25 +959,6 @@ sub NUMIFY { return refaddr($_[0]); } -=item B<dirname> - -Return the name of the temporary directory associated with this -object (if the object was created using the "newdir" constructor). - - $dirname = $tmpdir->dirname; - -This method is called automatically when the object is used in string context. - -=item B<unlink_on_destroy> - -Control whether the file is unlinked when the object goes out of scope. -The file is removed if this value is true and $KEEP_ALL is not. - - $fh->unlink_on_destroy( 1 ); - -Default is for the file to be removed. - -=cut sub unlink_on_destroy { my $self = shift; @@ -1199,29 +968,6 @@ sub unlink_on_destroy { return ${*$self}{UNLINK}; } -=item B<DESTROY> - -When the object goes out of scope, the destructor is called. This -destructor will attempt to unlink the file (using L<unlink1|"unlink1">) -if the constructor was called with UNLINK set to 1 (the default state -if UNLINK is not specified). - -No error is given if the unlink fails. - -If the object has been passed to a child process during a fork, the -file will be deleted when the object goes out of scope in the parent. - -For a temporary directory object the directory will be removed unless -the CLEANUP argument was used in the constructor (and set to false) or -C<unlink_on_destroy> was modified after creation. Note that if a temp -directory is your current directory, it cannot be removed - a warning -will be given in this case. C<chdir()> out of the directory before -letting the object go out of scope. - -If the global variable $KEEP_ALL is true, the file or directory -will not be removed. - -=cut sub DESTROY { local($., $@, $!, $^E, $?); @@ -1255,107 +1001,6 @@ sub DESTROY { } } -=back - -=head1 FUNCTIONS - -This section describes the recommended interface for generating -temporary files and directories. - -=over 4 - -=item B<tempfile> - -This is the basic function to generate temporary files. -The behaviour of the file can be changed using various options: - - $fh = tempfile(); - ($fh, $filename) = tempfile(); - -Create a temporary file in the directory specified for temporary -files, as specified by the tmpdir() function in L<File::Spec>. - - ($fh, $filename) = tempfile($template); - -Create a temporary file in the current directory using the supplied -template. Trailing `X' characters are replaced with random letters to -generate the filename. At least four `X' characters must be present -at the end of the template. - - ($fh, $filename) = tempfile($template, SUFFIX => $suffix) - -Same as previously, except that a suffix is added to the template -after the `X' translation. Useful for ensuring that a temporary -filename has a particular extension when needed by other applications. -But see the WARNING at the end. - - ($fh, $filename) = tempfile($template, DIR => $dir); - -Translates the template as before except that a directory name -is specified. - - ($fh, $filename) = tempfile($template, TMPDIR => 1); - -Equivalent to specifying a DIR of "File::Spec->tmpdir", writing the file -into the same temporary directory as would be used if no template was -specified at all. - - ($fh, $filename) = tempfile($template, UNLINK => 1); - -Return the filename and filehandle as before except that the file is -automatically removed when the program exits (dependent on -$KEEP_ALL). Default is for the file to be removed if a file handle is -requested and to be kept if the filename is requested. In a scalar -context (where no filename is returned) the file is always deleted -either (depending on the operating system) on exit or when it is -closed (unless $KEEP_ALL is true when the temp file is created). - -Use the object-oriented interface if fine-grained control of when -a file is removed is required. - -If the template is not specified, a template is always -automatically generated. This temporary file is placed in tmpdir() -(L<File::Spec>) unless a directory is specified explicitly with the -DIR option. - - $fh = tempfile( DIR => $dir ); - -If called in scalar context, only the filehandle is returned and the -file will automatically be deleted when closed on operating systems -that support this (see the description of tmpfile() elsewhere in this -document). This is the preferred mode of operation, as if you only -have a filehandle, you can never create a race condition by fumbling -with the filename. On systems that can not unlink an open file or can -not mark a file as temporary when it is opened (for example, Windows -NT uses the C<O_TEMPORARY> flag) the file is marked for deletion when -the program ends (equivalent to setting UNLINK to 1). The C<UNLINK> -flag is ignored if present. - - (undef, $filename) = tempfile($template, OPEN => 0); - -This will return the filename based on the template but -will not open this file. Cannot be used in conjunction with -UNLINK set to true. Default is to always open the file -to protect from possible race conditions. A warning is issued -if warnings are turned on. Consider using the tmpnam() -and mktemp() functions described elsewhere in this document -if opening the file is not required. - -If the operating system supports it (for example BSD derived systems), the -filehandle will be opened with O_EXLOCK (open with exclusive file lock). -This can sometimes cause problems if the intention is to pass the filename -to another system that expects to take an exclusive lock itself (such as -DBD::SQLite) whilst ensuring that the tempfile is not reused. In this -situation the "EXLOCK" option can be passed to tempfile. By default EXLOCK -will be true (this retains compatibility with earlier releases). - - ($fh, $filename) = tempfile($template, EXLOCK => 0); - -Options can be combined as required. - -Will croak() if there is an error. - -=cut sub tempfile { if ( @_ && $_[0] eq 'File::Temp' ) { @@ -1486,68 +1131,6 @@ sub tempfile { } -=item B<tempdir> - -This is the recommended interface for creation of temporary -directories. By default the directory will not be removed on exit -(that is, it won't be temporary; this behaviour can not be changed -because of issues with backwards compatibility). To enable removal -either use the CLEANUP option which will trigger removal on program -exit, or consider using the "newdir" method in the object interface which -will allow the directory to be cleaned up when the object goes out of -scope. - -The behaviour of the function depends on the arguments: - - $tempdir = tempdir(); - -Create a directory in tmpdir() (see L<File::Spec|File::Spec>). - - $tempdir = tempdir( $template ); - -Create a directory from the supplied template. This template is -similar to that described for tempfile(). `X' characters at the end -of the template are replaced with random letters to construct the -directory name. At least four `X' characters must be in the template. - - $tempdir = tempdir ( DIR => $dir ); - -Specifies the directory to use for the temporary directory. -The temporary directory name is derived from an internal template. - - $tempdir = tempdir ( $template, DIR => $dir ); - -Prepend the supplied directory name to the template. The template -should not include parent directory specifications itself. Any parent -directory specifications are removed from the template before -prepending the supplied directory. - - $tempdir = tempdir ( $template, TMPDIR => 1 ); - -Using the supplied template, create the temporary directory in -a standard location for temporary files. Equivalent to doing - - $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir); - -but shorter. Parent directory specifications are stripped from the -template itself. The C<TMPDIR> option is ignored if C<DIR> is set -explicitly. Additionally, C<TMPDIR> is implied if neither a template -nor a directory are supplied. - - $tempdir = tempdir( $template, CLEANUP => 1); - -Create a temporary directory using the supplied template, but -attempt to remove it (and all files inside it) when the program -exits. Note that an attempt will be made to remove all files from -the directory even if they were not created by this module (otherwise -why ask to clean it up?). The directory removal is made with -the rmtree() function from the L<File::Path|File::Path> module. -Of course, if the template is not specified, the temporary directory -will be created in tmpdir() and will also be removed at program exit. - -Will croak() if there is an error. - -=cut # ' @@ -1649,31 +1232,6 @@ sub tempdir { } -=back - -=head1 MKTEMP FUNCTIONS - -The following functions are Perl implementations of the -mktemp() family of temp file generation system calls. - -=over 4 - -=item B<mkstemp> - -Given a template, returns a filehandle to the temporary file and the name -of the file. - - ($fh, $name) = mkstemp( $template ); - -In scalar context, just the filehandle is returned. - -The template may be any filename with some number of X's appended -to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced -with unique alphanumeric combinations. - -Will croak() if there is an error. - -=cut @@ -1702,21 +1260,6 @@ sub mkstemp { } -=item B<mkstemps> - -Similar to mkstemp(), except that an extra argument can be supplied -with a suffix to be appended to the template. - - ($fh, $name) = mkstemps( $template, $suffix ); - -For example a template of C<testXXXXXX> and suffix of C<.dat> -would generate a file similar to F<testhGji_w.dat>. - -Returns just the filehandle alone when called in scalar context. - -Will croak() if there is an error. - -=cut sub mkstemps { @@ -1746,20 +1289,6 @@ sub mkstemps { } -=item B<mkdtemp> - -Create a directory from a template. The template must end in -X's that are replaced by the routine. - - $tmpdir_name = mkdtemp($template); - -Returns the name of the temporary directory created. - -Directory must be removed by the caller. - -Will croak() if there is an error. - -=cut #' # for emacs @@ -1791,18 +1320,6 @@ sub mkdtemp { } -=item B<mktemp> - -Returns a valid temporary filename but does not guarantee -that the file will not be opened by someone else. - - $unopened_file = mktemp($template); - -Template is the same as that required by mkstemp(). - -Will croak() if there is an error. - -=cut sub mktemp { @@ -1823,48 +1340,6 @@ sub mktemp { return $tmpname; } -=back - -=head1 POSIX FUNCTIONS - -This section describes the re-implementation of the tmpnam() -and tmpfile() functions described in L<POSIX> -using the mkstemp() from this module. - -Unlike the L<POSIX|POSIX> implementations, the directory used -for the temporary file is not specified in a system include -file (C<P_tmpdir>) but simply depends on the choice of tmpdir() -returned by L<File::Spec|File::Spec>. On some implementations this -location can be set using the C<TMPDIR> environment variable, which -may not be secure. -If this is a problem, simply use mkstemp() and specify a template. - -=over 4 - -=item B<tmpnam> - -When called in scalar context, returns the full name (including path) -of a temporary file (uses mktemp()). The only check is that the file does -not already exist, but there is no guarantee that that condition will -continue to apply. - - $file = tmpnam(); - -When called in list context, a filehandle to the open file and -a filename are returned. This is achieved by calling mkstemp() -after constructing a suitable template. - - ($fh, $file) = tmpnam(); - -If possible, this form should be used to prevent possible -race conditions. - -See L<File::Spec/tmpdir> for information on the choice of temporary -directory for a particular operating system. - -Will croak() if there is an error. - -=cut sub tmpnam { @@ -1885,22 +1360,6 @@ sub tmpnam { } -=item B<tmpfile> - -Returns the filehandle of a temporary file. - - $fh = tmpfile(); - -The file is removed when the filehandle is closed or when the program -exits. No access to the filename is provided. - -If the temporary file can not be created undef is returned. -Currently this command will probably not work when the temporary -directory is on an NFS file system. - -Will croak() if there is an error. - -=cut sub tmpfile { @@ -1916,36 +1375,6 @@ sub tmpfile { } -=back - -=head1 ADDITIONAL FUNCTIONS - -These functions are provided for backwards compatibility -with common tempfile generation C library functions. - -They are not exported and must be addressed using the full package -name. - -=over 4 - -=item B<tempnam> - -Return the name of a temporary file in the specified directory -using a prefix. The file is guaranteed not to exist at the time -the function was called, but such guarantees are good for one -clock tick only. Always use the proper form of C<sysopen> -with C<O_CREAT | O_EXCL> if you must open such a filename. - - $filename = File::Temp::tempnam( $dir, $prefix ); - -Equivalent to running mktemp() with $dir/$prefixXXXXXXXX -(using unix file convention as an example) - -Because this function uses mktemp(), it can suffer from race conditions. - -Will croak() if there is an error. - -=cut sub tempnam { @@ -1963,61 +1392,6 @@ sub tempnam { } -=back - -=head1 UTILITY FUNCTIONS - -Useful functions for dealing with the filehandle and filename. - -=over 4 - -=item B<unlink0> - -Given an open filehandle and the associated filename, make a safe -unlink. This is achieved by first checking that the filename and -filehandle initially point to the same file and that the number of -links to the file is 1 (all fields returned by stat() are compared). -Then the filename is unlinked and the filehandle checked once again to -verify that the number of links on that file is now 0. This is the -closest you can come to making sure that the filename unlinked was the -same as the file whose descriptor you hold. - - unlink0($fh, $path) - or die "Error unlinking file $path safely"; - -Returns false on error but croaks() if there is a security -anomaly. The filehandle is not closed since on some occasions this is -not required. - -On some platforms, for example Windows NT, it is not possible to -unlink an open file (the file must be closed first). On those -platforms, the actual unlinking is deferred until the program ends and -good status is returned. A check is still performed to make sure that -the filehandle and filename are pointing to the same thing (but not at -the time the end block is executed since the deferred removal may not -have access to the filehandle). - -Additionally, on Windows NT not all the fields returned by stat() can -be compared. For example, the C<dev> and C<rdev> fields seem to be -different. Also, it seems that the size of the file returned by stat() -does not always agree, with C<stat(FH)> being more accurate than -C<stat(filename)>, presumably because of caching issues even when -using autoflush (this is usually overcome by waiting a while after -writing to the tempfile before attempting to C<unlink0> it). - -Finally, on NFS file systems the link count of the file handle does -not always go to zero immediately after unlinking. Currently, this -command is expected to fail on NFS disks. - -This function is disabled if the global variable $KEEP_ALL is true -and an unlink on open file is supported. If the unlink is to be deferred -to the END block, the file is still registered for removal. - -This function should not be called if you are using the object oriented -interface since the it will interfere with the object destructor deleting -the file. - -=cut sub unlink0 { @@ -2058,30 +1432,6 @@ sub unlink0 { return 1; } -=item B<cmpstat> - -Compare C<stat> of filehandle with C<stat> of provided filename. This -can be used to check that the filename and filehandle initially point -to the same file and that the number of links to the file is 1 (all -fields returned by stat() are compared). - - cmpstat($fh, $path) - or die "Error comparing handle with file"; - -Returns false if the stat information differs or if the link count is -greater than 1. Calls croak if there is a security anomaly. - -On certain platforms, for example Windows, not all the fields returned by stat() -can be compared. For example, the C<dev> and C<rdev> fields seem to be -different in Windows. Also, it seems that the size of the file -returned by stat() does not always agree, with C<stat(FH)> being more -accurate than C<stat(filename)>, presumably because of caching issues -even when using autoflush (this is usually overcome by waiting a while -after writing to the tempfile before attempting to C<unlink0> it). - -Not exported by default. - -=cut sub cmpstat { @@ -2154,27 +1504,6 @@ sub cmpstat { return 1; } -=item B<unlink1> - -Similar to C<unlink0> except after file comparison using cmpstat, the -filehandle is closed prior to attempting to unlink the file. This -allows the file to be removed without using an END block, but does -mean that the post-unlink comparison of the filehandle state provided -by C<unlink0> is not available. - - unlink1($fh, $path) - or die "Error closing and unlinking file"; - -Usually called from the object destructor when using the OO interface. - -Not exported by default. - -This function is disabled if the global variable $KEEP_ALL is true. - -Can call croak() if there is a security anomaly during the stat() -comparison. - -=cut sub unlink1 { croak 'Usage: unlink1(filehandle, filename)' @@ -2198,6 +1527,761 @@ sub unlink1 { return unlink($path); } + +{ + # protect from using the variable itself + my $LEVEL = STANDARD; + sub safe_level { + my $self = shift; + if (@_) { + my $level = shift; + if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) { + carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W; + } else { + # Don't allow this on perl 5.005 or earlier + if ($] < 5.006 && $level != STANDARD) { + # Cant do MEDIUM or HIGH checks + croak "Currently requires perl 5.006 or newer to do the safe checks"; + } + # Check that we are allowed to change level + # Silently ignore if we can not. + $LEVEL = $level if _can_do_level($level); + } + } + return $LEVEL; + } +} + + +{ + my $TopSystemUID = 10; + $TopSystemUID = 197108 if $^O eq 'interix'; # "Administrator" + sub top_system_uid { + my $self = shift; + if (@_) { + my $newuid = shift; + croak "top_system_uid: UIDs should be numeric" + unless $newuid =~ /^\d+$/s; + $TopSystemUID = $newuid; + } + return $TopSystemUID; + } +} + + +package File::Temp::Dir; + +use File::Path qw/ rmtree /; +use strict; +use overload '""' => "STRINGIFY", + '0+' => \&File::Temp::NUMIFY, + fallback => 1; + +# private class specifically to support tempdir objects +# created by File::Temp->newdir + +# ostensibly the same method interface as File::Temp but without +# inheriting all the IO::Seekable methods and other cruft + +# Read-only - returns the name of the temp directory + +sub dirname { + my $self = shift; + return $self->{DIRNAME}; +} + +sub STRINGIFY { + my $self = shift; + return $self->dirname; +} + +sub unlink_on_destroy { + my $self = shift; + if (@_) { + $self->{CLEANUP} = shift; + } + return $self->{CLEANUP}; +} + +sub DESTROY { + my $self = shift; + local($., $@, $!, $^E, $?); + if ($self->unlink_on_destroy && + $$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) { + if (-d $self->{REALNAME}) { + # Some versions of rmtree will abort if you attempt to remove + # the directory you are sitting in. We protect that and turn it + # into a warning. We do this because this occurs during object + # destruction and so can not be caught by the user. + eval { rmtree($self->{REALNAME}, $File::Temp::DEBUG, 0); }; + warn $@ if ($@ && $^W); + } + } +} + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +File::Temp - return name and handle of a temporary file safely + +=head1 VERSION + +version 0.2304 + +=head1 SYNOPSIS + + use File::Temp qw/ tempfile tempdir /; + + $fh = tempfile(); + ($fh, $filename) = tempfile(); + + ($fh, $filename) = tempfile( $template, DIR => $dir); + ($fh, $filename) = tempfile( $template, SUFFIX => '.dat'); + ($fh, $filename) = tempfile( $template, TMPDIR => 1 ); + + binmode( $fh, ":utf8" ); + + $dir = tempdir( CLEANUP => 1 ); + ($fh, $filename) = tempfile( DIR => $dir ); + +Object interface: + + require File::Temp; + use File::Temp (); + use File::Temp qw/ :seekable /; + + $fh = File::Temp->new(); + $fname = $fh->filename; + + $fh = File::Temp->new(TEMPLATE => $template); + $fname = $fh->filename; + + $tmp = File::Temp->new( UNLINK => 0, SUFFIX => '.dat' ); + print $tmp "Some data\n"; + print "Filename is $tmp\n"; + $tmp->seek( 0, SEEK_END ); + +The following interfaces are provided for compatibility with +existing APIs. They should not be used in new code. + +MkTemp family: + + use File::Temp qw/ :mktemp /; + + ($fh, $file) = mkstemp( "tmpfileXXXXX" ); + ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix); + + $tmpdir = mkdtemp( $template ); + + $unopened_file = mktemp( $template ); + +POSIX functions: + + use File::Temp qw/ :POSIX /; + + $file = tmpnam(); + $fh = tmpfile(); + + ($fh, $file) = tmpnam(); + +Compatibility functions: + + $unopened_file = File::Temp::tempnam( $dir, $pfx ); + +=head1 DESCRIPTION + +C<File::Temp> can be used to create and open temporary files in a safe +way. There is both a function interface and an object-oriented +interface. The File::Temp constructor or the tempfile() function can +be used to return the name and the open filehandle of a temporary +file. The tempdir() function can be used to create a temporary +directory. + +The security aspect of temporary file creation is emphasized such that +a filehandle and filename are returned together. This helps guarantee +that a race condition can not occur where the temporary file is +created by another process between checking for the existence of the +file and its opening. Additional security levels are provided to +check, for example, that the sticky bit is set on world writable +directories. See L<"safe_level"> for more information. + +For compatibility with popular C library functions, Perl implementations of +the mkstemp() family of functions are provided. These are, mkstemp(), +mkstemps(), mkdtemp() and mktemp(). + +Additionally, implementations of the standard L<POSIX|POSIX> +tmpnam() and tmpfile() functions are provided if required. + +Implementations of mktemp(), tmpnam(), and tempnam() are provided, +but should be used with caution since they return only a filename +that was valid when function was called, so cannot guarantee +that the file will not exist by the time the caller opens the filename. + +Filehandles returned by these functions support the seekable methods. + +=begin __INTERNALS + +=head1 PORTABILITY + +This section is at the top in order to provide easier access to +porters. It is not expected to be rendered by a standard pod +formatting tool. Please skip straight to the SYNOPSIS section if you +are not trying to port this module to a new platform. + +This module is designed to be portable across operating systems and it +currently supports Unix, VMS, DOS, OS/2, Windows and Mac OS +(Classic). When porting to a new OS there are generally three main +issues that have to be solved: +=over 4 + +=item * + +Can the OS unlink an open file? If it can not then the +C<_can_unlink_opened_file> method should be modified. + +=item * + +Are the return values from C<stat> reliable? By default all the +return values from C<stat> are compared when unlinking a temporary +file using the filename and the handle. Operating systems other than +unix do not always have valid entries in all fields. If utility function +C<File::Temp::unlink0> fails then the C<stat> comparison should be +modified accordingly. + +=item * + +Security. Systems that can not support a test for the sticky bit +on a directory can not use the MEDIUM and HIGH security tests. +The C<_can_do_level> method should be modified accordingly. + +=back + +=end __INTERNALS + +=head1 OBJECT-ORIENTED INTERFACE + +This is the primary interface for interacting with +C<File::Temp>. Using the OO interface a temporary file can be created +when the object is constructed and the file can be removed when the +object is no longer required. + +Note that there is no method to obtain the filehandle from the +C<File::Temp> object. The object itself acts as a filehandle. The object +isa C<IO::Handle> and isa C<IO::Seekable> so all those methods are +available. + +Also, the object is configured such that it stringifies to the name of the +temporary file and so can be compared to a filename directly. It numifies +to the C<refaddr> the same as other handles and so can be compared to other +handles with C<==>. + + $fh eq $filename # as a string + $fh != \*STDOUT # as a number + +=over 4 + +=item B<new> + +Create a temporary file object. + + my $tmp = File::Temp->new(); + +by default the object is constructed as if C<tempfile> +was called without options, but with the additional behaviour +that the temporary file is removed by the object destructor +if UNLINK is set to true (the default). + +Supported arguments are the same as for C<tempfile>: UNLINK +(defaulting to true), DIR, EXLOCK and SUFFIX. Additionally, the filename +template is specified using the TEMPLATE option. The OPEN option +is not supported (the file is always opened). + + $tmp = File::Temp->new( TEMPLATE => 'tempXXXXX', + DIR => 'mydir', + SUFFIX => '.dat'); + +Arguments are case insensitive. + +Can call croak() if an error occurs. + +=item B<newdir> + +Create a temporary directory using an object oriented interface. + + $dir = File::Temp->newdir(); + +By default the directory is deleted when the object goes out of scope. + +Supports the same options as the C<tempdir> function. Note that directories +created with this method default to CLEANUP => 1. + + $dir = File::Temp->newdir( $template, %options ); + +A template may be specified either with a leading template or +with a TEMPLATE argument. + +=item B<filename> + +Return the name of the temporary file associated with this object +(if the object was created using the "new" constructor). + + $filename = $tmp->filename; + +This method is called automatically when the object is used as +a string. + +=item B<dirname> + +Return the name of the temporary directory associated with this +object (if the object was created using the "newdir" constructor). + + $dirname = $tmpdir->dirname; + +This method is called automatically when the object is used in string context. + +=item B<unlink_on_destroy> + +Control whether the file is unlinked when the object goes out of scope. +The file is removed if this value is true and $KEEP_ALL is not. + + $fh->unlink_on_destroy( 1 ); + +Default is for the file to be removed. + +=item B<DESTROY> + +When the object goes out of scope, the destructor is called. This +destructor will attempt to unlink the file (using L<unlink1|"unlink1">) +if the constructor was called with UNLINK set to 1 (the default state +if UNLINK is not specified). + +No error is given if the unlink fails. + +If the object has been passed to a child process during a fork, the +file will be deleted when the object goes out of scope in the parent. + +For a temporary directory object the directory will be removed unless +the CLEANUP argument was used in the constructor (and set to false) or +C<unlink_on_destroy> was modified after creation. Note that if a temp +directory is your current directory, it cannot be removed - a warning +will be given in this case. C<chdir()> out of the directory before +letting the object go out of scope. + +If the global variable $KEEP_ALL is true, the file or directory +will not be removed. + +=back + +=head1 FUNCTIONS + +This section describes the recommended interface for generating +temporary files and directories. + +=over 4 + +=item B<tempfile> + +This is the basic function to generate temporary files. +The behaviour of the file can be changed using various options: + + $fh = tempfile(); + ($fh, $filename) = tempfile(); + +Create a temporary file in the directory specified for temporary +files, as specified by the tmpdir() function in L<File::Spec>. + + ($fh, $filename) = tempfile($template); + +Create a temporary file in the current directory using the supplied +template. Trailing `X' characters are replaced with random letters to +generate the filename. At least four `X' characters must be present +at the end of the template. + + ($fh, $filename) = tempfile($template, SUFFIX => $suffix) + +Same as previously, except that a suffix is added to the template +after the `X' translation. Useful for ensuring that a temporary +filename has a particular extension when needed by other applications. +But see the WARNING at the end. + + ($fh, $filename) = tempfile($template, DIR => $dir); + +Translates the template as before except that a directory name +is specified. + + ($fh, $filename) = tempfile($template, TMPDIR => 1); + +Equivalent to specifying a DIR of "File::Spec->tmpdir", writing the file +into the same temporary directory as would be used if no template was +specified at all. + + ($fh, $filename) = tempfile($template, UNLINK => 1); + +Return the filename and filehandle as before except that the file is +automatically removed when the program exits (dependent on +$KEEP_ALL). Default is for the file to be removed if a file handle is +requested and to be kept if the filename is requested. In a scalar +context (where no filename is returned) the file is always deleted +either (depending on the operating system) on exit or when it is +closed (unless $KEEP_ALL is true when the temp file is created). + +Use the object-oriented interface if fine-grained control of when +a file is removed is required. + +If the template is not specified, a template is always +automatically generated. This temporary file is placed in tmpdir() +(L<File::Spec>) unless a directory is specified explicitly with the +DIR option. + + $fh = tempfile( DIR => $dir ); + +If called in scalar context, only the filehandle is returned and the +file will automatically be deleted when closed on operating systems +that support this (see the description of tmpfile() elsewhere in this +document). This is the preferred mode of operation, as if you only +have a filehandle, you can never create a race condition by fumbling +with the filename. On systems that can not unlink an open file or can +not mark a file as temporary when it is opened (for example, Windows +NT uses the C<O_TEMPORARY> flag) the file is marked for deletion when +the program ends (equivalent to setting UNLINK to 1). The C<UNLINK> +flag is ignored if present. + + (undef, $filename) = tempfile($template, OPEN => 0); + +This will return the filename based on the template but +will not open this file. Cannot be used in conjunction with +UNLINK set to true. Default is to always open the file +to protect from possible race conditions. A warning is issued +if warnings are turned on. Consider using the tmpnam() +and mktemp() functions described elsewhere in this document +if opening the file is not required. + +If the operating system supports it (for example BSD derived systems), the +filehandle will be opened with O_EXLOCK (open with exclusive file lock). +This can sometimes cause problems if the intention is to pass the filename +to another system that expects to take an exclusive lock itself (such as +DBD::SQLite) whilst ensuring that the tempfile is not reused. In this +situation the "EXLOCK" option can be passed to tempfile. By default EXLOCK +will be true (this retains compatibility with earlier releases). + + ($fh, $filename) = tempfile($template, EXLOCK => 0); + +Options can be combined as required. + +Will croak() if there is an error. + +=item B<tempdir> + +This is the recommended interface for creation of temporary +directories. By default the directory will not be removed on exit +(that is, it won't be temporary; this behaviour can not be changed +because of issues with backwards compatibility). To enable removal +either use the CLEANUP option which will trigger removal on program +exit, or consider using the "newdir" method in the object interface which +will allow the directory to be cleaned up when the object goes out of +scope. + +The behaviour of the function depends on the arguments: + + $tempdir = tempdir(); + +Create a directory in tmpdir() (see L<File::Spec|File::Spec>). + + $tempdir = tempdir( $template ); + +Create a directory from the supplied template. This template is +similar to that described for tempfile(). `X' characters at the end +of the template are replaced with random letters to construct the +directory name. At least four `X' characters must be in the template. + + $tempdir = tempdir ( DIR => $dir ); + +Specifies the directory to use for the temporary directory. +The temporary directory name is derived from an internal template. + + $tempdir = tempdir ( $template, DIR => $dir ); + +Prepend the supplied directory name to the template. The template +should not include parent directory specifications itself. Any parent +directory specifications are removed from the template before +prepending the supplied directory. + + $tempdir = tempdir ( $template, TMPDIR => 1 ); + +Using the supplied template, create the temporary directory in +a standard location for temporary files. Equivalent to doing + + $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir); + +but shorter. Parent directory specifications are stripped from the +template itself. The C<TMPDIR> option is ignored if C<DIR> is set +explicitly. Additionally, C<TMPDIR> is implied if neither a template +nor a directory are supplied. + + $tempdir = tempdir( $template, CLEANUP => 1); + +Create a temporary directory using the supplied template, but +attempt to remove it (and all files inside it) when the program +exits. Note that an attempt will be made to remove all files from +the directory even if they were not created by this module (otherwise +why ask to clean it up?). The directory removal is made with +the rmtree() function from the L<File::Path|File::Path> module. +Of course, if the template is not specified, the temporary directory +will be created in tmpdir() and will also be removed at program exit. + +Will croak() if there is an error. + +=back + +=head1 MKTEMP FUNCTIONS + +The following functions are Perl implementations of the +mktemp() family of temp file generation system calls. + +=over 4 + +=item B<mkstemp> + +Given a template, returns a filehandle to the temporary file and the name +of the file. + + ($fh, $name) = mkstemp( $template ); + +In scalar context, just the filehandle is returned. + +The template may be any filename with some number of X's appended +to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced +with unique alphanumeric combinations. + +Will croak() if there is an error. + +=item B<mkstemps> + +Similar to mkstemp(), except that an extra argument can be supplied +with a suffix to be appended to the template. + + ($fh, $name) = mkstemps( $template, $suffix ); + +For example a template of C<testXXXXXX> and suffix of C<.dat> +would generate a file similar to F<testhGji_w.dat>. + +Returns just the filehandle alone when called in scalar context. + +Will croak() if there is an error. + +=item B<mkdtemp> + +Create a directory from a template. The template must end in +X's that are replaced by the routine. + + $tmpdir_name = mkdtemp($template); + +Returns the name of the temporary directory created. + +Directory must be removed by the caller. + +Will croak() if there is an error. + +=item B<mktemp> + +Returns a valid temporary filename but does not guarantee +that the file will not be opened by someone else. + + $unopened_file = mktemp($template); + +Template is the same as that required by mkstemp(). + +Will croak() if there is an error. + +=back + +=head1 POSIX FUNCTIONS + +This section describes the re-implementation of the tmpnam() +and tmpfile() functions described in L<POSIX> +using the mkstemp() from this module. + +Unlike the L<POSIX|POSIX> implementations, the directory used +for the temporary file is not specified in a system include +file (C<P_tmpdir>) but simply depends on the choice of tmpdir() +returned by L<File::Spec|File::Spec>. On some implementations this +location can be set using the C<TMPDIR> environment variable, which +may not be secure. +If this is a problem, simply use mkstemp() and specify a template. + +=over 4 + +=item B<tmpnam> + +When called in scalar context, returns the full name (including path) +of a temporary file (uses mktemp()). The only check is that the file does +not already exist, but there is no guarantee that that condition will +continue to apply. + + $file = tmpnam(); + +When called in list context, a filehandle to the open file and +a filename are returned. This is achieved by calling mkstemp() +after constructing a suitable template. + + ($fh, $file) = tmpnam(); + +If possible, this form should be used to prevent possible +race conditions. + +See L<File::Spec/tmpdir> for information on the choice of temporary +directory for a particular operating system. + +Will croak() if there is an error. + +=item B<tmpfile> + +Returns the filehandle of a temporary file. + + $fh = tmpfile(); + +The file is removed when the filehandle is closed or when the program +exits. No access to the filename is provided. + +If the temporary file can not be created undef is returned. +Currently this command will probably not work when the temporary +directory is on an NFS file system. + +Will croak() if there is an error. + +=back + +=head1 ADDITIONAL FUNCTIONS + +These functions are provided for backwards compatibility +with common tempfile generation C library functions. + +They are not exported and must be addressed using the full package +name. + +=over 4 + +=item B<tempnam> + +Return the name of a temporary file in the specified directory +using a prefix. The file is guaranteed not to exist at the time +the function was called, but such guarantees are good for one +clock tick only. Always use the proper form of C<sysopen> +with C<O_CREAT | O_EXCL> if you must open such a filename. + + $filename = File::Temp::tempnam( $dir, $prefix ); + +Equivalent to running mktemp() with $dir/$prefixXXXXXXXX +(using unix file convention as an example) + +Because this function uses mktemp(), it can suffer from race conditions. + +Will croak() if there is an error. + +=back + +=head1 UTILITY FUNCTIONS + +Useful functions for dealing with the filehandle and filename. + +=over 4 + +=item B<unlink0> + +Given an open filehandle and the associated filename, make a safe +unlink. This is achieved by first checking that the filename and +filehandle initially point to the same file and that the number of +links to the file is 1 (all fields returned by stat() are compared). +Then the filename is unlinked and the filehandle checked once again to +verify that the number of links on that file is now 0. This is the +closest you can come to making sure that the filename unlinked was the +same as the file whose descriptor you hold. + + unlink0($fh, $path) + or die "Error unlinking file $path safely"; + +Returns false on error but croaks() if there is a security +anomaly. The filehandle is not closed since on some occasions this is +not required. + +On some platforms, for example Windows NT, it is not possible to +unlink an open file (the file must be closed first). On those +platforms, the actual unlinking is deferred until the program ends and +good status is returned. A check is still performed to make sure that +the filehandle and filename are pointing to the same thing (but not at +the time the end block is executed since the deferred removal may not +have access to the filehandle). + +Additionally, on Windows NT not all the fields returned by stat() can +be compared. For example, the C<dev> and C<rdev> fields seem to be +different. Also, it seems that the size of the file returned by stat() +does not always agree, with C<stat(FH)> being more accurate than +C<stat(filename)>, presumably because of caching issues even when +using autoflush (this is usually overcome by waiting a while after +writing to the tempfile before attempting to C<unlink0> it). + +Finally, on NFS file systems the link count of the file handle does +not always go to zero immediately after unlinking. Currently, this +command is expected to fail on NFS disks. + +This function is disabled if the global variable $KEEP_ALL is true +and an unlink on open file is supported. If the unlink is to be deferred +to the END block, the file is still registered for removal. + +This function should not be called if you are using the object oriented +interface since the it will interfere with the object destructor deleting +the file. + +=item B<cmpstat> + +Compare C<stat> of filehandle with C<stat> of provided filename. This +can be used to check that the filename and filehandle initially point +to the same file and that the number of links to the file is 1 (all +fields returned by stat() are compared). + + cmpstat($fh, $path) + or die "Error comparing handle with file"; + +Returns false if the stat information differs or if the link count is +greater than 1. Calls croak if there is a security anomaly. + +On certain platforms, for example Windows, not all the fields returned by stat() +can be compared. For example, the C<dev> and C<rdev> fields seem to be +different in Windows. Also, it seems that the size of the file +returned by stat() does not always agree, with C<stat(FH)> being more +accurate than C<stat(filename)>, presumably because of caching issues +even when using autoflush (this is usually overcome by waiting a while +after writing to the tempfile before attempting to C<unlink0> it). + +Not exported by default. + +=item B<unlink1> + +Similar to C<unlink0> except after file comparison using cmpstat, the +filehandle is closed prior to attempting to unlink the file. This +allows the file to be removed without using an END block, but does +mean that the post-unlink comparison of the filehandle state provided +by C<unlink0> is not available. + + unlink1($fh, $path) + or die "Error closing and unlinking file"; + +Usually called from the object destructor when using the OO interface. + +Not exported by default. + +This function is disabled if the global variable $KEEP_ALL is true. + +Can call croak() if there is a security anomaly during the stat() +comparison. + =item B<cleanup> Calling this function will cause any temp files or temp directories @@ -2294,32 +2378,6 @@ simply examine the return value of C<safe_level>. die "Could not change to high security" if $newlevel != File::Temp::HIGH; -=cut - -{ - # protect from using the variable itself - my $LEVEL = STANDARD; - sub safe_level { - my $self = shift; - if (@_) { - my $level = shift; - if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) { - carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W; - } else { - # Don't allow this on perl 5.005 or earlier - if ($] < 5.006 && $level != STANDARD) { - # Cant do MEDIUM or HIGH checks - croak "Currently requires perl 5.006 or newer to do the safe checks"; - } - # Check that we are allowed to change level - # Silently ignore if we can not. - $LEVEL = $level if _can_do_level($level); - } - } - return $LEVEL; - } -} - =item TopSystemUID This is the highest UID on the current system that refers to a root @@ -2339,23 +2397,6 @@ UID. This value can be adjusted to reduce security checking if required. The value is only relevant when C<safe_level> is set to MEDIUM or higher. -=cut - -{ - my $TopSystemUID = 10; - $TopSystemUID = 197108 if $^O eq 'interix'; # "Administrator" - sub top_system_uid { - my $self = shift; - if (@_) { - my $newuid = shift; - croak "top_system_uid: UIDs should be numeric" - unless $newuid =~ /^\d+$/s; - $TopSystemUID = $newuid; - } - return $TopSystemUID; - } -} - =item B<$KEEP_ALL> Controls whether temporary files and directories should be retained @@ -2456,6 +2497,10 @@ security checking, to ensure the presence of the function regardless of operating system and to help with portability. The module was shipped as a standard part of perl from v5.6.1. +Thanks to Tom Christiansen for suggesting that this module +should be written and providing ideas for code improvements and +security enhancements. + =head1 SEE ALSO L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path> @@ -2466,74 +2511,84 @@ different implementations of temporary file handling. See L<File::Tempdir> for an alternative object-oriented wrapper for the C<tempdir> function. +=for Pod::Coverage STRINGIFY NUMIFY top_system_uid + +# vim: ts=2 sts=2 sw=2 et: + +=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + +=head1 SUPPORT + +=head2 Bugs / Feature Requests + +Please report any bugs or feature requests through the issue tracker +at L<http://rt.cpan.org/Public/Dist/Display.html?Name=File-Temp>. +You will be notified automatically of any progress on your issue. + +=head2 Source Code + +This is open source software. The code repository is available for +public review and contribution under the terms of the license. + +L<https://github.com/Perl-Toolchain-Gang/File-Temp> + + git clone https://github.com/Perl-Toolchain-Gang/File-Temp.git + =head1 AUTHOR -Tim Jenness E<lt>tjenness@cpan.orgE<gt> +Tim Jenness <tjenness@cpan.org> -Copyright (C) 2007-2010 Tim Jenness. -Copyright (C) 1999-2007 Tim Jenness and the UK Particle Physics and -Astronomy Research Council. All Rights Reserved. This program is free -software; you can redistribute it and/or modify it under the same -terms as Perl itself. +=head1 CONTRIBUTORS -Original Perl implementation loosely based on the OpenBSD C code for -mkstemp(). Thanks to Tom Christiansen for suggesting that this module -should be written and providing ideas for code improvements and -security enhancements. +=over 4 -=cut +=item * -package File::Temp::Dir; +Ben Tilly <btilly@gmail.com> -use File::Path qw/ rmtree /; -use strict; -use overload '""' => "STRINGIFY", - '0+' => \&File::Temp::NUMIFY, - fallback => 1; +=item * -# private class specifically to support tempdir objects -# created by File::Temp->newdir +David Golden <dagolden@cpan.org> -# ostensibly the same method interface as File::Temp but without -# inheriting all the IO::Seekable methods and other cruft +=item * -# Read-only - returns the name of the temp directory +David Steinbrunner <dsteinbrunner@pobox.com> -sub dirname { - my $self = shift; - return $self->{DIRNAME}; -} +=item * -sub STRINGIFY { - my $self = shift; - return $self->dirname; -} +Ed Avis <eda@linux01.wcl.local> -sub unlink_on_destroy { - my $self = shift; - if (@_) { - $self->{CLEANUP} = shift; - } - return $self->{CLEANUP}; -} +=item * -sub DESTROY { - my $self = shift; - local($., $@, $!, $^E, $?); - if ($self->unlink_on_destroy && - $$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) { - if (-d $self->{REALNAME}) { - # Some versions of rmtree will abort if you attempt to remove - # the directory you are sitting in. We protect that and turn it - # into a warning. We do this because this occurs during object - # destruction and so can not be caught by the user. - eval { rmtree($self->{REALNAME}, $File::Temp::DEBUG, 0); }; - warn $@ if ($@ && $^W); - } - } -} +James E. Keenan <jkeen@verizon.net> +=item * -1; +Karen Etheridge <ether@cpan.org> -# vim: ts=2 sts=2 sw=2 et: +=item * + +Kevin Ryde <user42@zip.com.au> + +=item * + +Olivier Mengue <dolmen@cpan.org> + +=item * + +Peter John Acklam <pjacklam@online.no> + +=item * + +Peter Rabbitson <ribasushi@cpan.org> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2013 by Tim Jenness and the UK Particle Physics and Astronomy Research Council. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/Master/tlpkg/tlperl/lib/File/Which.pm b/Master/tlpkg/tlperl/lib/File/Which.pm new file mode 100644 index 00000000000..7acf5574846 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Which.pm @@ -0,0 +1,281 @@ +package File::Which; + +use 5.005003; +use strict; +use Exporter (); +use File::Spec (); + +use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK}; +BEGIN { + $VERSION = '1.16'; + @ISA = 'Exporter'; + @EXPORT = 'which'; + @EXPORT_OK = 'where'; +} + +use constant IS_VMS => ($^O eq 'VMS'); +use constant IS_MAC => ($^O eq 'MacOS'); +use constant IS_DOS => ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2'); +use constant IS_CYG => ($^O eq 'cygwin'); + +# For Win32 systems, stores the extensions used for +# executable files +# For others, the empty string is used +# because 'perl' . '' eq 'perl' => easier +my @PATHEXT = (''); +if ( IS_DOS ) { + # WinNT. PATHEXT might be set on Cygwin, but not used. + if ( $ENV{PATHEXT} ) { + push @PATHEXT, split ';', $ENV{PATHEXT}; + } else { + # Win9X or other: doesn't have PATHEXT, so needs hardcoded. + push @PATHEXT, qw{.com .exe .bat}; + } +} elsif ( IS_VMS ) { + push @PATHEXT, qw{.exe .com}; +} elsif ( IS_CYG ) { + # See this for more info + # http://cygwin.com/cygwin-ug-net/using-specialnames.html#pathnames-exe + push @PATHEXT, qw{.exe .com}; +} + +sub which { + my ($exec) = @_; + + return undef unless $exec; + + my $all = wantarray; + my @results = (); + + # check for aliases first + if ( IS_VMS ) { + my $symbol = `SHOW SYMBOL $exec`; + chomp($symbol); + unless ( $? ) { + return $symbol unless $all; + push @results, $symbol; + } + } + if ( IS_MAC ) { + my @aliases = split /\,/, $ENV{Aliases}; + foreach my $alias ( @aliases ) { + # This has not been tested!! + # PPT which says MPW-Perl cannot resolve `Alias $alias`, + # let's just hope it's fixed + if ( lc($alias) eq lc($exec) ) { + chomp(my $file = `Alias $alias`); + last unless $file; # if it failed, just go on the normal way + return $file unless $all; + push @results, $file; + # we can stop this loop as if it finds more aliases matching, + # it'll just be the same result anyway + last; + } + } + } + + return $exec + if !IS_VMS and !IS_MAC and !IS_DOS and $exec =~ /\// and -f $exec and -x $exec; + + my @path = File::Spec->path; + if ( IS_DOS or IS_VMS or IS_MAC ) { + unshift @path, File::Spec->curdir; + } + + foreach my $base ( map { File::Spec->catfile($_, $exec) } @path ) { + for my $ext ( @PATHEXT ) { + my $file = $base.$ext; + + # We don't want dirs (as they are -x) + next if -d $file; + + if ( + # Executable, normal case + -x _ + or ( + # MacOS doesn't mark as executable so we check -e + IS_MAC + || + ( + ( IS_DOS or IS_CYG ) + and + grep { + $file =~ /$_\z/i + } @PATHEXT[1..$#PATHEXT] + ) + # DOSish systems don't pass -x on + # non-exe/bat/com files. so we check -e. + # However, we don't want to pass -e on files + # that aren't in PATHEXT, like README. + and -e _ + ) + ) { + return $file unless $all; + push @results, $file; + } + } + } + + if ( $all ) { + return @results; + } else { + return undef; + } +} + +sub where { + # force wantarray + my @res = which($_[0]); + return @res; +} + +1; + +__END__ + +=pod + +=head1 NAME + +File::Which - Portable implementation of the `which' utility + +=head1 SYNOPSIS + + use File::Which; # exports which() + use File::Which qw(which where); # exports which() and where() + + my $exe_path = which('perldoc'); + + my @paths = where('perl'); + - Or - + my @paths = which('perl'); # an array forces search for all of them + +=head1 DESCRIPTION + +C<File::Which> was created to be able to get the paths to executable programs +on systems under which the `which' program wasn't implemented in the shell. + +C<File::Which> searches the directories of the user's C<PATH> (as returned by +C<File::Spec-E<gt>path()>), looking for executable files having the name +specified as a parameter to C<which()>. Under Win32 systems, which do not have a +notion of directly executable files, but uses special extensions such as C<.exe> +and C<.bat> to identify them, C<File::Which> takes extra steps to assure that +you will find the correct file (so for example, you might be searching for +C<perl>, it'll try F<perl.exe>, F<perl.bat>, etc.) + +=head1 Steps Used on Win32, DOS, OS2 and VMS + +=head2 Windows NT + +Windows NT has a special environment variable called C<PATHEXT>, which is used +by the shell to look for executable files. Usually, it will contain a list in +the form C<.EXE;.BAT;.COM;.JS;.VBS> etc. If C<File::Which> finds such an +environment variable, it parses the list and uses it as the different +extensions. + +=head2 Windows 9x and other ancient Win/DOS/OS2 + +This set of operating systems don't have the C<PATHEXT> variable, and usually +you will find executable files there with the extensions C<.exe>, C<.bat> and +(less likely) C<.com>. C<File::Which> uses this hardcoded list if it's running +under Win32 but does not find a C<PATHEXT> variable. + +=head2 VMS + +Same case as Windows 9x: uses C<.exe> and C<.com> (in that order). + +=head1 Functions + +=head2 which($short_exe_name) + +Exported by default. + +C<$short_exe_name> is the name used in the shell to call the program (for +example, C<perl>). + +If it finds an executable with the name you specified, C<which()> will return +the absolute path leading to this executable (for example, F</usr/bin/perl> or +F<C:\Perl\Bin\perl.exe>). + +If it does I<not> find the executable, it returns C<undef>. + +If C<which()> is called in list context, it will return I<all> the +matches. + +=head2 where($short_exe_name) + +Not exported by default. + +Same as C<which($short_exe_name)> in array context. Same as the +C<`where'> utility, will return an array containing all the path names +matching C<$short_exe_name>. + +=head1 CAVEATS + +Not tested on VMS or MacOS, although there is platform specific code +for those. Anyone who haves a second would be very kind to send me a +report of how it went. + +=head1 SUPPORT + +Bugs should be reported via the GitHub issue tracker + +L<https://github.com/plicease/File-Which/issues> + +For other issues, contact the maintainer. + +=head1 SEE ALSO + +=over 4 + +=item L<pwhich> + +Command line interface to this module. + +=item L<IPC::Cmd> + +Comes with a C<can_run> function with slightly different semantics that +the traditional UNIX where. It will find executables in the current +directory, even though the current directory is not searched for by +default on Unix. + +=item L<Devel::CheckBin> + +This module purports to "check that a command is available", but does not +provide any documentation on how you might use it. + +=back + +=head1 AUTHOR + +Current maintainer: Graham Ollis E<lt>plicease@cpan.orgE<gt> + +Previous maintainer: Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +Original author: Per Einar Ellefsen E<lt>pereinar@cpan.orgE<gt> + +Originated in F<modperl-2.0/lib/Apache/Build.pm>. Changed for use in DocSet +(for the mod_perl site) and Win32-awareness by me, with slight modifications +by Stas Bekman, then extracted to create C<File::Which>. + +Version 0.04 had some significant platform-related changes, taken from +the Perl Power Tools C<`which'> implementation by Abigail with +enhancements from Peter Prymmer. See +L<http://www.perl.com/language/ppt/src/which/index.html> for more +information. + +=head1 COPYRIGHT + +Copyright 2002 Per Einar Ellefsen. + +Some parts copyright 2009 Adam Kennedy. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<File::Spec>, L<which(1)>, Perl Power Tools: +L<http://www.perl.com/language/ppt/index.html>. + +=cut |