From 4b19af017623bfa3bb72bb164598a517f586e0d3 Mon Sep 17 00:00:00 2001 From: Charles Bailey Date: Fri, 4 Aug 2000 01:18:46 +0000 Subject: YA resync with mainstem, including VMS patches from others p4raw-id: //depot/vmsperl@6514 --- lib/File/Find.pm | 34 +++-- lib/File/Spec.pm | 2 +- lib/File/Spec/Mac.pm | 38 +++--- lib/File/Spec/Unix.pm | 37 ++++-- lib/File/Spec/VMS.pm | 6 +- lib/File/Spec/Win32.pm | 57 +-------- lib/File/Temp.pm | 335 ++++++++++++++++++++++++++++++++----------------- 7 files changed, 289 insertions(+), 220 deletions(-) (limited to 'lib/File') diff --git a/lib/File/Find.pm b/lib/File/Find.pm index ac73f1b5eb..a9f190c722 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -373,7 +373,7 @@ sub _find_opt { $name = $abs_dir . $_; - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } @@ -429,7 +429,7 @@ sub _find_dir($$$) { $_= ($no_chdir ? $dir_name : $dir_rel ); # prune may happen here $prune= 0; - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" next if $prune; } @@ -472,7 +472,7 @@ sub _find_dir($$$) { $name = $dir_pref . $FN; $_ = ($no_chdir ? $name : $FN); - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } } @@ -496,13 +496,13 @@ sub _find_dir($$$) { else { $name = $dir_pref . $FN; $_= ($no_chdir ? $name : $FN); - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } } else { $name = $dir_pref . $FN; $_= ($no_chdir ? $name : $FN); - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } } } @@ -528,7 +528,7 @@ sub _find_dir($$$) { if ( substr($_,-2) eq '/.' ) { s|/\.$||; } - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } else { push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth; last; @@ -584,13 +584,25 @@ sub _find_dir_symlnk($$$) { while (defined $SE) { unless ($bydepth) { + # change to parent directory + unless ($no_chdir) { + my $udir = $pdir_loc; + if ($untaint) { + $udir = $1 if $pdir_loc =~ m|$untaint_pat|; + } + unless (chdir $udir) { + warn "Can't cd to $udir: $!\n"; + next; + } + } $dir= $p_dir; $name= $dir_name; $_= ($no_chdir ? $dir_name : $dir_rel ); $fullname= $dir_loc; # prune may happen here $prune= 0; - &$wanted_callback; + lstat($_); # make sure file tests with '_' work + { &$wanted_callback }; # protect against wild "next" next if $prune; } @@ -640,7 +652,7 @@ sub _find_dir_symlnk($$$) { $fullname = $new_loc; $name = $dir_pref . $FN; $_ = ($no_chdir ? $name : $FN); - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } } @@ -673,7 +685,8 @@ sub _find_dir_symlnk($$$) { s|/\.$||; } - &$wanted_callback; + lstat($_); # make sure file tests with '_' work + { &$wanted_callback }; # protect against wild "next" } else { push @Stack,[$dir_loc, $pdir_loc, $p_dir, $dir_rel,-1] if $bydepth; last; @@ -721,7 +734,8 @@ if ($^O eq 'VMS') { } $File::Find::dont_use_nlink = 1 - if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32'; + if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32' || + $^O eq 'cygwin'; # Set dont_use_nlink in your hint file if your system's stat doesn't # report the number of links in a directory as an indication diff --git a/lib/File/Spec.pm b/lib/File/Spec.pm index ed26d76a56..40503c467f 100644 --- a/lib/File/Spec.pm +++ b/lib/File/Spec.pm @@ -3,7 +3,7 @@ package File::Spec; use strict; use vars qw(@ISA $VERSION); -$VERSION = '0.81'; +$VERSION = 0.82 ; my %module = (MacOS => 'Mac', MSWin32 => 'Win32', diff --git a/lib/File/Spec/Mac.pm b/lib/File/Spec/Mac.pm index 5315d9220f..9ef55ec84a 100644 --- a/lib/File/Spec/Mac.pm +++ b/lib/File/Spec/Mac.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '1.1'; +$VERSION = '1.2'; @ISA = qw(File::Spec::Unix); @@ -192,12 +192,16 @@ folder named "HD" in the current working directory on a drive named "HD"), relative wins. Use ":" in the appropriate place in the path if you want to distinguish unambiguously. +As a special case, the file name '' is always considered to be absolute. + =cut sub file_name_is_absolute { my ($self,$file) = @_; if ($file =~ /:/) { return ($file !~ m/^:/s); + } elsif ( $file eq '' ) { + return 1 ; } else { return (! -e ":$file"); } @@ -307,6 +311,12 @@ sub catpath { =item abs2rel +See L for general documentation. + +Unlike Cabs2rel()>, this function will make +checks against the local filesystem if necessary. See +L for details. + =cut sub abs2rel { @@ -344,31 +354,15 @@ sub abs2rel { =item rel2abs -Converts a relative path to an absolute path. - - $abs_path = File::Spec->rel2abs( $destination ) ; - $abs_path = File::Spec->rel2abs( $destination, $base ) ; - -If $base is not present or '', then L is used. If $base is relative, -then it is converted to absolute form using L. This means that it -is taken to be relative to L. - -On systems with the concept of a volume, this assumes that both paths -are on the $base volume, and ignores the $destination volume. - -On systems that have a grammar that indicates filenames, this ignores the -$base filename as well. Otherwise all path components are assumed to be -directories. - -If $path is absolute, it is cleaned up and returned using L. - -Based on code written by Shigio Yamaguchi. +See L for general documentation. -No checks against the filesystem are made. +Unlike Crel2abs()>, this function will make +checks against the local filesystem if necessary. See +L for details. =cut -sub rel2abs($;$;) { +sub rel2abs { my ($self,$path,$base ) = @_; if ( ! $self->file_name_is_absolute( $path ) ) { diff --git a/lib/File/Spec/Unix.pm b/lib/File/Spec/Unix.pm index 6ca26d74ce..a81c533235 100644 --- a/lib/File/Spec/Unix.pm +++ b/lib/File/Spec/Unix.pm @@ -3,7 +3,7 @@ package File::Spec::Unix; use strict; use vars qw($VERSION); -$VERSION = '1.1'; +$VERSION = '1.2'; use Cwd; @@ -165,7 +165,12 @@ sub case_tolerant { =item file_name_is_absolute -Takes as argument a path and returns true, if it is an absolute path. +Takes as argument a path and returns true if it is an absolute path. + +This does not consult the local filesystem on Unix, Win32, or OS/2. It +does sometimes on MacOS (see L). +It does consult the working environment for VMS (see +L). =cut @@ -311,8 +316,8 @@ sub catpath { Takes a destination path and an optional base path returns a relative path from the base path to the destination path: - $rel_path = File::Spec->abs2rel( $destination ) ; - $rel_path = File::Spec->abs2rel( $destination, $base ) ; + $rel_path = File::Spec->abs2rel( $path ) ; + $rel_path = File::Spec->abs2rel( $path, $base ) ; If $base is not present or '', then L is used. If $base is relative, then it is converted to absolute form using L. This means that it @@ -328,9 +333,13 @@ directories. If $path is relative, it is converted to absolute form using L. This means that it is taken to be relative to L. -Based on code written by Shigio Yamaguchi. +No checks against the filesystem are made on most systems. On MacOS, +the filesystem may be consulted (see +L). On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. -No checks against the filesystem are made. +Based on code written by Shigio Yamaguchi. =cut @@ -388,15 +397,15 @@ sub abs2rel { Converts a relative path to an absolute path. - $abs_path = File::Spec->rel2abs( $destination ) ; - $abs_path = File::Spec->rel2abs( $destination, $base ) ; + $abs_path = File::Spec->rel2abs( $path ) ; + $abs_path = File::Spec->rel2abs( $path, $base ) ; If $base is not present or '', then L is used. If $base is relative, then it is converted to absolute form using L. This means that it is taken to be relative to L. On systems with the concept of a volume, this assumes that both paths -are on the $base volume, and ignores the $destination volume. +are on the $base volume, and ignores the $path volume. On systems that have a grammar that indicates filenames, this ignores the $base filename as well. Otherwise all path components are assumed to be @@ -404,13 +413,17 @@ directories. If $path is absolute, it is cleaned up and returned using L. -Based on code written by Shigio Yamaguchi. +No checks against the filesystem are made on most systems. On MacOS, +the filesystem may be consulted (see +L). On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. -No checks against the filesystem are made. +Based on code written by Shigio Yamaguchi. =cut -sub rel2abs($;$;) { +sub rel2abs { my ($self,$path,$base ) = @_; # Clean up $path diff --git a/lib/File/Spec/VMS.pm b/lib/File/Spec/VMS.pm index cc06ca636d..60b0ec8e50 100644 --- a/lib/File/Spec/VMS.pm +++ b/lib/File/Spec/VMS.pm @@ -265,7 +265,7 @@ sub rootdir { Returns a string representation of the first writable directory from the following list or '' if none are writable: - sys$scratch + sys$scratch: $ENV{TMPDIR} =cut @@ -273,7 +273,7 @@ from the following list or '' if none are writable: my $tmpdir; sub tmpdir { return $tmpdir if defined $tmpdir; - foreach ('sys$scratch', $ENV{TMPDIR}) { + foreach ('sys$scratch:', $ENV{TMPDIR}) { next unless defined && -d && -w _; $tmpdir = $_; last; @@ -451,7 +451,7 @@ Use VMS syntax when converting filespecs. =cut -sub rel2abs($;$;) { +sub rel2abs { my $self = shift ; return vmspath(File::Spec::Unix::rel2abs( $self, @_ )) if ( join( '', @_ ) =~ m{/} ) ; diff --git a/lib/File/Spec/Win32.pm b/lib/File/Spec/Win32.pm index b8fe37bbdb..f5d6cda2bc 100644 --- a/lib/File/Spec/Win32.pm +++ b/lib/File/Spec/Win32.pm @@ -5,7 +5,7 @@ use Cwd; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '1.1'; +$VERSION = '1.2'; @ISA = qw(File::Spec::Unix); @@ -242,34 +242,6 @@ sub catpath { } -=item abs2rel - -Takes a destination path and an optional base path returns a relative path -from the base path to the destination path: - - $rel_path = File::Spec->abs2rel( $destination ) ; - $rel_path = File::Spec->abs2rel( $destination, $base ) ; - -If $base is not present or '', then L is used. If $base is relative, -then it is converted to absolute form using L. This means that it -is taken to be relative to L. - -On systems with the concept of a volume, this assumes that both paths -are on the $destination volume, and ignores the $base volume. - -On systems that have a grammar that indicates filenames, this ignores the -$base filename as well. Otherwise all path components are assumed to be -directories. - -If $path is relative, it is converted to absolute form using L. -This means that it is taken to be relative to L. - -Based on code written by Shigio Yamaguchi. - -No checks against the filesystem are made. - -=cut - sub abs2rel { my($self,$path,$base) = @_; @@ -339,33 +311,8 @@ sub abs2rel { ) ; } -=item rel2abs - -Converts a relative path to an absolute path. - - $abs_path = File::Spec->rel2abs( $destination ) ; - $abs_path = File::Spec->rel2abs( $destination, $base ) ; - -If $base is not present or '', then L is used. If $base is relative, -then it is converted to absolute form using L. This means that it -is taken to be relative to L. - -Assumes that both paths are on the $base volume, and ignores the -$destination volume. - -On systems that have a grammar that indicates filenames, this ignores the -$base filename as well. Otherwise all path components are assumed to be -directories. - -If $path is absolute, it is cleaned up and returned using L. - -Based on code written by Shigio Yamaguchi. - -No checks against the filesystem are made. - -=cut -sub rel2abs($;$;) { +sub rel2abs { my ($self,$path,$base ) = @_; if ( ! $self->file_name_is_absolute( $path ) ) { diff --git a/lib/File/Temp.pm b/lib/File/Temp.pm index 736ef3fdb3..aac8b7a93c 100644 --- a/lib/File/Temp.pm +++ b/lib/File/Temp.pm @@ -92,6 +92,10 @@ use File::Path qw/ rmtree /; use Fcntl 1.03; use Errno qw( EEXIST ENOENT ENOTDIR EINVAL ); +# Need the Symbol package if we are running older perl +require Symbol if $] < 5.006; + + # use 'our' on v5.6.0 use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG); @@ -99,8 +103,6 @@ $DEBUG = 0; # We are exporting functions -#require Exporter; -#@ISA = qw/Exporter/; use base qw/Exporter/; # Export list - to allow fine tuning of export table @@ -111,7 +113,7 @@ use base qw/Exporter/; tmpnam tmpfile mktemp - mkstemp + mkstemp mkstemps mkdtemp unlink0 @@ -129,13 +131,13 @@ Exporter::export_tags('POSIX','mktemp'); # Version number -$VERSION = '0.07'; +$VERSION = '0.09'; # 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 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 - 0 1 2 3 4 5 6 7 8 9 _ + 0 1 2 3 4 5 6 7 8 9 _ /); # Maximum number of tries to make a temp file before failing @@ -155,12 +157,25 @@ use constant STANDARD => 0; use constant MEDIUM => 1; use constant HIGH => 2; +# OPENFLAGS. If we defined the flag to use with Sysopen here this gives +# us an optimisation when many temporary files are requested + +my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR; + +for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + no strict 'refs'; + $OPENFLAGS |= $bit if eval { $bit = &$func(); 1 }; +} + + + # INTERNAL ROUTINES - not to be used outside of package # Generic routine for getting a temporary filename # modelled on OpenBSD _gettemp() in mktemp.c -# The template must contain X's that are to be replaced +# The template must contain X's that are to be replaced # with the random values # Arguments: @@ -216,7 +231,7 @@ sub _gettemp { # Read the options and merge with defaults %options = (%options, @_) if @_; - + # Can not open the file and make a directory in a single call if ($options{"open"} && $options{"mkdir"}) { carp "File::Temp::_gettemp: doopen and domkdir can not both be true\n"; @@ -268,11 +283,16 @@ sub _gettemp { $parent = File::Spec->curdir; } else { - # Put it back together without the last one - $parent = File::Spec->catdir(@dirs[0..$#dirs-1]); + if ($^O eq 'VMS') { # need volume to avoid relative dir spec + $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]); + } else { - # ...and attach the volume (no filename) - $parent = File::Spec->catpath($volume, $parent, ''); + # Put it back together without the last one + $parent = File::Spec->catdir(@dirs[0..$#dirs-1]); + + # ...and attach the volume (no filename) + $parent = File::Spec->catpath($volume, $parent, ''); + } } @@ -296,7 +316,7 @@ sub _gettemp { # that does not exist or is not writable unless (-d $parent && -w _) { - carp "File::Temp::_gettemp: Parent directory ($parent) is not a directory" + carp "File::Temp::_gettemp: Parent directory ($parent) is not a directory" . " or is not writable\n"; return (); } @@ -320,19 +340,18 @@ sub _gettemp { # Calculate the flags that we wish to use for the sysopen # Some of these are not always available - my $openflags; - if ($options{"open"}) { +# my $openflags; +# if ($options{"open"}) { # Default set - $openflags = O_CREAT | O_EXCL | O_RDWR; +# $openflags = O_CREAT | O_EXCL | O_RDWR; - for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/) { - my ($bit, $func) = (0, "Fcntl::O_" . $oflag); - no strict 'refs'; - $openflags |= $bit if eval { $bit = &$func(); 1 }; - } +# for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/) { +# my ($bit, $func) = (0, "Fcntl::O_" . $oflag); +# no strict 'refs'; +# $openflags |= $bit if eval { $bit = &$func(); 1 }; +# } - } - +# } # Now try MAX_TRIES time to open the file for (my $i = 0; $i < MAX_TRIES; $i++) { @@ -343,7 +362,6 @@ sub _gettemp { # If we are running before perl5.6.0 we can not auto-vivify if ($] < 5.006) { - require Symbol; $fh = &Symbol::gensym; } @@ -359,7 +377,7 @@ sub _gettemp { umask(066); # Attempt to open the file - if ( sysopen($fh, $path, $openflags, 0600) ) { + if ( sysopen($fh, $path, $OPENFLAGS, 0600) ) { # Reset umask umask($umask); @@ -419,10 +437,10 @@ sub _gettemp { return (undef, $path) unless -e $path; - # Try again until MAX_TRIES + # Try again until MAX_TRIES } - + # Did not successfully open the tempfile/dir # so try again with a different set of random letters # No point in trying to increment unless we have only @@ -449,7 +467,7 @@ sub _gettemp { # Check for out of control looping if ($counter > $MAX_GUESS) { - carp "Tried to get a new temp name different to the previous value$MAX_GUESS times.\nSomething wrong with template?? ($template)"; + carp "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)"; return (); } @@ -469,6 +487,10 @@ sub _gettemp { # No arguments. Return value is the random character +# No longer called since _replace_XX runs a few percent faster if +# I inline the code. This is important if we are creating thousands of +# temporary files. + sub _randchar { $CHARS[ int( rand( $#CHARS ) ) ]; @@ -497,18 +519,18 @@ sub _replace_XX { # Don't want to always use substr when not required though. if ($ignore) { - substr($path, 0, - $ignore) =~ s/X(?=X*\z)/_randchar()/ge; + substr($path, 0, - $ignore) =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge; } else { - $path =~ s/X(?=X*\z)/_randchar()/ge; + $path =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge; } return $path; } # internal routine to check to see if the directory is safe -# First checks to see if the directory is not owned by the +# First checks to see if the directory is not owned by the # current user or root. Then checks to see if anyone else -# can write to the directory and if so, checks to see if +# can write to the directory and if so, checks to see if # it has the sticky bit set # Will not work on systems that do not support sticky bit @@ -530,6 +552,7 @@ sub _is_safe { # Stat path my @info = stat($path); return 0 unless scalar(@info); + return 1 if $^O eq 'VMS'; # owner delete control at file level # Check to see whether owner is neither superuser (or a system uid) nor me # Use the real uid from the $< variable @@ -567,6 +590,7 @@ sub _is_verysafe { require POSIX; my $path = shift; + return 1 if $^O eq 'VMS'; # owner delete control at file level # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined # and If it is not there do the extensive test @@ -626,19 +650,48 @@ sub _is_verysafe { # platform for files that are currently open. # Returns true if we can, false otherwise. -# Currently WinNT can not unlink an opened file +# Currently WinNT, OS/2 and VMS can not unlink an opened file +# On VMS this is because the O_EXCL flag is used to open the +# temporary file. Currently I do not know enough about the issues +# on VMS to decide whether O_EXCL is a requirement. sub _can_unlink_opened_file { - - $^O ne 'MSWin32' ? 1 : 0; + if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS') { + return 0; + } else { + return 1; + } } +# internal routine to decide which security levels are allowed +# see safe_level() for more information on this + +# Controls whether the supplied security level is allowed + +# $cando = _can_do_level( $level ) + +sub _can_do_level { + + # Get security level + my $level = shift; + + # Always have to be able to do STANDARD + return 1 if $level == STANDARD; + + # Currently, the systems that can do HIGH or MEDIUM are identical + if ( $^O eq 'MSWin32' || $^O eq 'os2') { + return 0; + } else { + return 1; + } + +} # This routine sets up a deferred unlinking of a specified # filename and filehandle. It is used in the following cases: -# - Called by unlink0 if an opend file can not be unlinked +# - Called by unlink0 if an opened file can not be unlinked # - Called by tempfile() if files are to be removed on shutdown # - Called by tempdir() if directories are to be removed on shutdown @@ -650,71 +703,84 @@ sub _can_unlink_opened_file { # - isdir (flag to indicate that we are being given a directory) # [and hence no filehandle] -# Status is not referred since all the magic is done with END blocks +# Status is not referred to since all the magic is done with and END block -sub _deferred_unlink { +{ + # Will set up two lexical variables to contain all the files to be + # removed. One array for files, another for directories + # They will only exist in this block + # This means we only have to set up a single END block to remove all files + # @files_to_unlink contains an array ref with the filehandle and filename + my (@files_to_unlink, @dirs_to_unlink); + + # Set up an end block to use these arrays + END { + # Files + foreach my $file (@files_to_unlink) { + # 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 + # probably a better way to do this + close($file->[0]); # file handle is [0] + + if (-f $file->[1]) { # file name is [1] + unlink $file->[1] or warn "Error removing ".$file->[1]; + } + } + # Dirs + foreach my $dir (@dirs_to_unlink) { + if (-d $dir) { + rmtree($dir, $DEBUG, 1); + } + } - croak 'Usage: _deferred_unlink($fh, $fname, $isdir)' - unless scalar(@_) == 3; - my ($fh, $fname, $isdir) = @_; + } - warn "Setting up deferred removal of $fname\n" - if $DEBUG; + # This is the sub called to register a file for deferred unlinking + # This could simply store the input parameters and defer everything + # until the END block. For now we do a bit of checking at this + # point in order to make sure that (1) we have a file/dir to delete + # and (2) we have been called with the correct arguments. + sub _deferred_unlink { - # If we have a directory, check that it is a directory - if ($isdir) { + croak 'Usage: _deferred_unlink($fh, $fname, $isdir)' + unless scalar(@_) == 3; - if (-d $fname) { + my ($fh, $fname, $isdir) = @_; - # Directory exists so set up END block - # (quoted to preserve lexical variables) - eval q{ - END { - if (-d $fname) { - rmtree($fname, $DEBUG, 1); - } - } - 1; - } || die; + warn "Setting up deferred removal of $fname\n" + if $DEBUG; - } else { - carp "Request to remove directory $fname could not be completed since it does not exists!\n"; - } + # If we have a directory, check that it is a directory + if ($isdir) { + if (-d $fname) { - } else { + # Directory exists so store it + push (@dirs_to_unlink, $fname); - if (-f $fname) { - - # dile exists so set up END block - # (quoted to preserve lexical variables) - eval q{ - END { - # 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 - # probably a better way to do this - close($fh); - - if (-f $fname) { - unlink $fname - || warn "Error removing $fname"; - } - } - 1; - } || die; + } else { + carp "Request to remove directory $fname could not be completed since it does not exists!\n"; + } } else { - carp "Request to remove file $fname could not be completed since it is not there!\n"; - } + if (-f $fname) { + + # file exists so store handle and name for later removal + push(@files_to_unlink, [$fh, $fname]); + + } else { + carp "Request to remove file $fname could not be completed since it is not there!\n"; + } + + } - } -} +} =head1 FUNCTIONS @@ -807,7 +873,7 @@ sub tempfile { } - # Construct the template + # Construct the template # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc # functions or simply constructing a template and using _gettemp() @@ -829,11 +895,11 @@ sub tempfile { $template = File::Spec->catfile($options{"DIR"}, TEMPXXX); } else { - + $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX); } - + } # Now add a suffix @@ -846,13 +912,13 @@ sub tempfile { "open" => $options{'OPEN'}, "mkdir"=> 0 , "suffixlen" => length($options{'SUFFIX'}), - ) ); + ) ); # Set up an exit handler that can do whatever is right for the # system. Do not check return status since this is all done with # END blocks _deferred_unlink($fh, $path, 0) if $options{"UNLINK"}; - + # Return if (wantarray()) { @@ -867,7 +933,7 @@ sub tempfile { # Unlink the file. It is up to unlink0 to decide what to do with # this (whether to unlink now or to defer until later) unlink0($fh, $path) or croak "Error unlinking file $path using unlink0"; - + # Return just the filehandle. return $fh; } @@ -985,26 +1051,31 @@ sub tempdir { $template = File::Spec->catdir($options{"DIR"}, TEMPXXX); } else { - + $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX); } - + } # Create the directory my $tempdir; + my $suffixlen = 0; + if ($^O eq 'VMS') { # dir names can end in delimiters + $template =~ m/([\.\]:>]+)$/; + $suffixlen = length($1); + } croak "Error in tempdir() using $template" unless ((undef, $tempdir) = _gettemp($template, - "open" => 0, + "open" => 0, "mkdir"=> 1 , - "suffixlen" => 0, - ) ); - + "suffixlen" => $suffixlen, + ) ); + # Install exit handler; must be dynamic to get lexical - if ( $options{'CLEANUP'} && -d $tempdir) { + if ( $options{'CLEANUP'} && -d $tempdir) { _deferred_unlink(undef, $tempdir, 1); - } + } # Return the dir name return $tempdir; @@ -1046,8 +1117,8 @@ sub mkstemp { my ($fh, $path); croak "Error in mkstemp using $template" - unless (($fh, $path) = _gettemp($template, - "open" => 1, + unless (($fh, $path) = _gettemp($template, + "open" => 1, "mkdir"=> 0 , "suffixlen" => 0, ) ); @@ -1085,7 +1156,7 @@ sub mkstemps { my $suffix = shift; $template .= $suffix; - + my ($fh, $path); croak "Error in mkstemps using $template" unless (($fh, $path) = _gettemp($template, @@ -1122,15 +1193,19 @@ sub mkdtemp { croak "Usage: mkdtemp(template)" if scalar(@_) != 1; - - my $template = shift; + my $template = shift; + my $suffixlen = 0; + if ($^O eq 'VMS') { # dir names can end in delimiters + $template =~ m/([\.\]:>]+)$/; + $suffixlen = length($1); + } my ($junk, $tmpdir); croak "Error creating temp directory from template $template\n" unless (($junk, $tmpdir) = _gettemp($template, - "open" => 0, + "open" => 0, "mkdir"=> 1 , - "suffixlen" => 0, + "suffixlen" => $suffixlen, ) ); return $tmpdir; @@ -1158,7 +1233,7 @@ sub mktemp { my ($tmpname, $junk); croak "Error getting name to temp file from template $template\n" unless (($junk, $tmpname) = _gettemp($template, - "open" => 0, + "open" => 0, "mkdir"=> 0 , "suffixlen" => 0, ) ); @@ -1217,7 +1292,7 @@ sub tmpnam { # Use a ten character template and append to tmpdir my $template = File::Spec->catfile($tmpdir, TEMPXXX); - + if (wantarray() ) { return mkstemp($template); } else { @@ -1320,11 +1395,11 @@ 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). +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 and C fields seem to be different @@ -1334,6 +1409,10 @@ C, 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 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. + =cut sub unlink0 { @@ -1352,7 +1431,7 @@ sub unlink0 { if ($fh[3] > 1 && $^W) { carp "unlink0: fstat found too many links; SB=@fh"; - } + } # Stat the path my @path = stat $path; @@ -1360,12 +1439,12 @@ sub unlink0 { unless (@path) { carp "unlink0: $path is gone already" if $^W; return; - } + } # this is no longer a file, but may be a directory, or worse unless (-f _) { confess "panic: $path is no longer a file: SB=@fh"; - } + } # Do comparison of each member of the array # On WinNT dev and rdev seem to be different @@ -1375,17 +1454,22 @@ sub unlink0 { my @okstat = (0..$#fh); # Use all by default if ($^O eq 'MSWin32') { @okstat = (1,2,3,4,5,7,8,9,10); + } elsif ($^O eq 'os2') { + @okstat = (0, 2..$#fh); } # Now compare each entry explicitly by number for (@okstat) { print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG; - unless ($fh[$_] == $path[$_]) { + # Use eq rather than == since rdev, blksize, and blocks (6, 11, + # and 12) will be '' on platforms that do not support them. This + # is fine since we are only comparing integers. + unless ($fh[$_] eq $path[$_]) { warn "Did not match $_ element of stat\n" if $DEBUG; return 0; } } - + # attempt remove the file (does not work on some platforms) if (_can_unlink_opened_file()) { # XXX: do *not* call this on a directory; possible race @@ -1468,7 +1552,21 @@ run with MEDIUM or HIGH security. This is simply because the safety tests use functions from L that are not available in older versions of perl. The problem is that the version number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though -they are different versions..... +they are different versions. + +On systems that do not support the HIGH or MEDIUM safety levels +(for example Win NT or OS/2) any attempt to change the level will +be ignored. The decision to ignore rather than raise an exception +allows portable programs to be written with high security in mind +for the systems that can support this without those programs failing +on systems where the extra tests are irrelevant. + +If you really need to see whether the change has been accepted +simply examine the return value of C. + + $newlevel = File::Temp->safe_level( File::Temp::HIGH ); + die "Could not change to high security" + if $newlevel != File::Temp::HIGH; =cut @@ -1482,11 +1580,14 @@ they are different versions..... if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) { carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n"; } else { + # Dont 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"; } - $LEVEL = $level; + # Check that we are allowed to change level + # Silently ignore if we can not. + $LEVEL = $level if _can_do_level($level); } } return $LEVEL; -- cgit v1.2.1 From 22d4bb9ccb8701e68f9243547d7e3a3c55f70908 Mon Sep 17 00:00:00 2001 From: Charles Bailey Date: Fri, 20 Oct 2000 04:44:37 +0000 Subject: SYN SYN p4raw-id: //depot/vmsperl@7375 --- lib/File/Copy.pm | 2 +- lib/File/Find.pm | 64 ++++++++++++++------- lib/File/Temp.pm | 165 +++++++++++++++++++++++++++++++++++++++++-------------- 3 files changed, 168 insertions(+), 63 deletions(-) (limited to 'lib/File') diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index e6cf786034..8d1d7834c9 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -221,7 +221,7 @@ File::Copy - Copy files or filehandles use POSIX; use File::Copy cp; - $n=FileHandle->new("/dev/null","r"); + $n = FileHandle->new("/a/file","r"); cp($n,"x");' =head1 DESCRIPTION diff --git a/lib/File/Find.pm b/lib/File/Find.pm index a9f190c722..6e6e462767 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -42,6 +42,22 @@ Reports the name of a directory only AFTER all its entries have been reported. Entry point finddepth() is a shortcut for specifying C<{ bydepth => 1 }> in the first argument of find(). +=item C + +The value should be a code reference. This code reference is used to +preprocess a directory; it is called after readdir() but before the loop that +calls the wanted() function. It is called with a list of strings and is +expected to return a list of strings. The code can be used to sort the +strings alphabetically, numerically, or to filter out directory entries based +on their name alone. + +=item C + +The value should be a code reference. It is invoked just before leaving the +current directory. It is called in void context with no arguments. The name +of the current directory is in $File::Find::dir. This hook is handy for +summarizing a directory, such as calculating its disk usage. + =item C Causes symbolic links to be followed. Since directory trees with symbolic @@ -55,7 +71,7 @@ If either I or I is in effect: =item * -It is guarantueed that an I has been called before the user's +It is guaranteed that an I has been called before the user's I function is called. This enables fast file checks involving S< _>. =item * @@ -67,11 +83,10 @@ pathname of the file with all symbolic links resolved =item C -This is similar to I except that it may report some files -more than once. It does detect cycles however. -Since only symbolic links have to be hashed, this is -much cheaper both in space and time. -If processing a file more than once (by the user's I function) +This is similar to I except that it may report some files more +than once. It does detect cycles, however. Since only symbolic links +have to be hashed, this is much cheaper both in space and time. If +processing a file more than once (by the user's I function) is worse than just taking time, the option I should be used. =item C @@ -97,14 +112,14 @@ C<$_> will be the same as C<$File::Find::name>. If find is used in taint-mode (-T command line switch or if EUID != UID or if EGID != GID) then internally directory names have to be untainted before they can be cd'ed to. Therefore they are checked against a regular -expression I. Note, that all names passed to the +expression I. Note that all names passed to the user's I function are still tainted. =item C See above. This should be set using the C quoting operator. The default is set to C. -Note that the paranthesis which are vital. +Note that the parantheses are vital. =item C @@ -116,15 +131,15 @@ are skipped. The default is to 'die' in such a case. The wanted() function does whatever verifications you want. C<$File::Find::dir> contains the current directory name, and C<$_> the current filename within that directory. C<$File::Find::name> contains -the complete pathname to the file. You are chdir()'d to C<$File::Find::dir> when -the function is called, unless C was specified. -When or are in effect there is also a -C<$File::Find::fullname>. -The function may set C<$File::Find::prune> to prune the tree -unless C was specified. -Unless C or C is specified, for compatibility -reasons (find.pl, find2perl) there are in addition the following globals -available: C<$File::Find::topdir>, C<$File::Find::topdev>, C<$File::Find::topino>, +the complete pathname to the file. You are chdir()'d to +C<$File::Find::dir> when the function is called, unless C +was specified. When or are in effect, there is +also a C<$File::Find::fullname>. The function may set +C<$File::Find::prune> to prune the tree unless C was +specified. Unless C or C is specified, for +compatibility reasons (find.pl, find2perl) there are in addition the +following globals available: C<$File::Find::topdir>, +C<$File::Find::topdev>, C<$File::Find::topino>, C<$File::Find::topmode> and C<$File::Find::topnlink>. This library is useful for the C tool, which when fed, @@ -161,7 +176,7 @@ module. =head1 CAVEAT -Be aware that the option to follow symblic links can be dangerous. +Be aware that the option to follow symbolic links can be dangerous. Depending on the structure of the directory tree (including symbolic links to directories) you might traverse a given (physical) directory more than once (only if C is in effect). @@ -183,7 +198,8 @@ require File::Basename; my %SLnkSeen; my ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow, - $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat); + $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat, + $pre_process, $post_process); sub contract_name { my ($cdir,$fn) = @_; @@ -282,6 +298,8 @@ sub _find_opt { my $cwd_untainted = $cwd; $wanted_callback = $wanted->{wanted}; $bydepth = $wanted->{bydepth}; + $pre_process = $wanted->{preprocess}; + $post_process = $wanted->{postprocess}; $no_chdir = $wanted->{no_chdir}; $full_check = $wanted->{follow}; $follow = $full_check || $wanted->{follow_fast}; @@ -464,6 +482,8 @@ sub _find_dir($$$) { } @filenames = readdir DIR; closedir(DIR); + @filenames = &$pre_process(@filenames) if $pre_process; + push @Stack,[$CdLvl,$dir_name,"",-2] if $post_process; if ($nlink == 2 && !$avoid_nlink) { # This dir has no subdirectories. @@ -518,7 +538,11 @@ sub _find_dir($$$) { } $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel"); $dir_pref = "$dir_name/"; - if ( $nlink < 0 ) { # must be finddepth, report dirname now + if ( $nlink == -2 ) { + $name = $dir = $p_dir; + $_ = "."; + &$post_process; # End-of-directory processing + } elsif ( $nlink < 0 ) { # must be finddepth, report dirname now $name = $dir_name; if ( substr($name,-2) eq '/.' ) { $name =~ s|/\.$||; diff --git a/lib/File/Temp.pm b/lib/File/Temp.pm index aac8b7a93c..a35104400d 100644 --- a/lib/File/Temp.pm +++ b/lib/File/Temp.pm @@ -4,6 +4,40 @@ package File::Temp; File::Temp - return name and handle of a temporary file safely +=begin __INTERNALS + +=head1 PORTABILITY + +This module is designed to be portable across operating systems +and it currently supports Unix, VMS, DOS, OS/2 and Windows. 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't then the +C<_can_unlink_opened_file> method should be modified. + +=item * + +Are the return values from C reliable? By default all the +return values from C 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 C fails +then the C 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 /; @@ -61,12 +95,12 @@ 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. +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(), @@ -91,8 +125,9 @@ use File::Spec 0.8; use File::Path qw/ rmtree /; use Fcntl 1.03; use Errno qw( EEXIST ENOENT ENOTDIR EINVAL ); +require VMS::Stdio if $^O eq 'VMS'; -# Need the Symbol package if we are running older perl +# Need the Symbol package if we are running older perl require Symbol if $] < 5.006; @@ -131,7 +166,7 @@ Exporter::export_tags('POSIX','mktemp'); # Version number -$VERSION = '0.09'; +$VERSION = '0.10'; # This is a list of characters that can be used in random filenames @@ -162,12 +197,25 @@ use constant HIGH => 2; my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR; -for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/) { +for my $oflag (qw/ FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT /) { my ($bit, $func) = (0, "Fcntl::O_" . $oflag); no strict 'refs'; $OPENFLAGS |= $bit if eval { $bit = &$func(); 1 }; } +# On some systems the O_TEMPORARY flag can be used to tell the OS +# to automatically remove the file when it is closed. This is fine +# in most cases but not if tempfile is called with UNLINK=>0 and +# the filename is requested -- in the case where the filename is to +# be passed to another routine. This happens on windows. We overcome +# this by using a second open flags variable + +my $OPENTEMPFLAGS = $OPENFLAGS; +for my $oflag (qw/ TEMPORARY /) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + no strict 'refs'; + $OPENTEMPFLAGS |= $bit if eval { $bit = &$func(); 1 }; +} # INTERNAL ROUTINES - not to be used outside of package @@ -190,7 +238,13 @@ for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/) { # default is 0 # "suffixlen" => number of characters at end of PATH to be ignored. # default is 0. +# "unlink_on_close" => indicates that, if possible, the OS should remove +# the file as soon as it is closed. Usually indicates +# use of the O_TEMPORARY flag to sysopen. +# Usually irrelevant on unix + # "open" and "mkdir" can not both be true +# "unlink_on_close" is not used when "mkdir" is true. # The default options are equivalent to mktemp(). @@ -214,6 +268,7 @@ sub _gettemp { "open" => 0, "mkdir" => 0, "suffixlen" => 0, + "unlink_on_close" => 0, ); # Read the template @@ -285,6 +340,7 @@ sub _gettemp { if ($^O eq 'VMS') { # need volume to avoid relative dir spec $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]); + $parent = 'sys$disk:[]' if $parent eq ''; } else { # Put it back together without the last one @@ -338,21 +394,6 @@ sub _gettemp { } - # Calculate the flags that we wish to use for the sysopen - # Some of these are not always available -# my $openflags; -# if ($options{"open"}) { - # Default set -# $openflags = O_CREAT | O_EXCL | O_RDWR; - -# for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/) { -# my ($bit, $func) = (0, "Fcntl::O_" . $oflag); -# no strict 'refs'; -# $openflags |= $bit if eval { $bit = &$func(); 1 }; -# } - -# } - # Now try MAX_TRIES time to open the file for (my $i = 0; $i < MAX_TRIES; $i++) { @@ -377,7 +418,18 @@ sub _gettemp { umask(066); # Attempt to open the file - if ( sysopen($fh, $path, $OPENFLAGS, 0600) ) { + my $open_success = undef; + if ( $^O eq 'VMS' and $options{"unlink_on_close"} ) { + # make it auto delete on close by setting FAB$V_DLT bit + $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt'); + $open_success = $fh; + } else { + my $flags = ( $options{"unlink_on_close"} ? + $OPENTEMPFLAGS : + $OPENFLAGS ); + $open_success = sysopen($fh, $path, $flags, 0600); + } + if ( $open_success ) { # Reset umask umask($umask); @@ -557,8 +609,12 @@ sub _is_safe { # Check to see whether owner is neither superuser (or a system uid) nor me # Use the real uid from the $< variable # UID is in [4] - if ( $info[4] > File::Temp->top_system_uid() && $info[4] != $<) { - carp "Directory owned neither by root nor the current user"; + if ($info[4] > File::Temp->top_system_uid() && $info[4] != $<) { + + Carp::cluck(sprintf "uid=$info[4] topuid=%s \$<=$< path='$path'", + File::Temp->top_system_uid()); + + carp "Directory owned neither by root nor the current user."; return 0; } @@ -657,7 +713,7 @@ sub _is_verysafe { sub _can_unlink_opened_file { - if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS') { + if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos') { return 0; } else { return 1; @@ -681,7 +737,7 @@ sub _can_do_level { return 1 if $level == STANDARD; # Currently, the systems that can do HIGH or MEDIUM are identical - if ( $^O eq 'MSWin32' || $^O eq 'os2') { + if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos') { return 0; } else { return 1; @@ -703,7 +759,7 @@ sub _can_do_level { # - isdir (flag to indicate that we are being given a directory) # [and hence no filehandle] -# Status is not referred to since all the magic is done with and END block +# Status is not referred to since all the magic is done with an END block { # Will set up two lexical variables to contain all the files to be @@ -758,10 +814,12 @@ sub _can_do_level { if (-d $fname) { # Directory exists so store it + # first on VMS turn []foo into [.foo] for rmtree + $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS'; push (@dirs_to_unlink, $fname); } else { - carp "Request to remove directory $fname could not be completed since it does not exists!\n"; + carp "Request to remove directory $fname could not be completed since it does not exist!\n"; } } else { @@ -818,6 +876,13 @@ But see the WARNING at the end. Translates the template as before except that a directory name is specified. + ($fh, $filename) = tempfile($template, UNLINK => 1); + +Return the filename and filehandle as before except that the file is +automatically removed when the program exits. Default is for the file +to be removed if a file handle is requested and to be kept if the +filename is requested. + If the template is not specified, a template is always automatically generated. This temporary file is placed in tmpdir() (L) unless a directory is specified explicitly with the @@ -844,6 +909,8 @@ if warnings are turned on. Consider using the tmpnam() and mktemp() functions described elsewhere in this document if opening the file is not required. +Options can be combined as required. + =cut sub tempfile { @@ -854,9 +921,9 @@ sub tempfile { # Default options my %options = ( "DIR" => undef, # Directory prefix - "SUFFIX" => '', # Template suffix - "UNLINK" => 0, # Unlink file on exit - "OPEN" => 1, # Do not open file + "SUFFIX" => '', # Template suffix + "UNLINK" => 0, # Do not unlink file on exit + "OPEN" => 1, # Open file ); # Check to see whether we have an odd or even number of arguments @@ -873,6 +940,12 @@ sub tempfile { } + if ($options{"DIR"} and $^O eq 'VMS') { + + # on VMS turn []foo into [.foo] for concatenation + $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"}); + } + # Construct the template # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc @@ -909,8 +982,9 @@ sub tempfile { my ($fh, $path); croak "Error in tempfile() using $template" unless (($fh, $path) = _gettemp($template, - "open" => $options{'OPEN'}, + "open" => $options{'OPEN'}, "mkdir"=> 0 , + "unlink_on_close" => $options{'UNLINK'}, "suffixlen" => length($options{'SUFFIX'}), ) ); @@ -1023,8 +1097,9 @@ sub tempdir { if ($options{'TMPDIR'} || $options{'DIR'}) { # Strip parent directory from the filename - # + # # There is no filename at the end + $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS'; my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1); # Last directory is then our template @@ -1033,7 +1108,7 @@ sub tempdir { # Prepend the supplied directory or temp dir if ($options{"DIR"}) { - $template = File::Spec->catfile($options{"DIR"}, $template); + $template = File::Spec->catdir($options{"DIR"}, $template); } elsif ($options{TMPDIR}) { @@ -1314,7 +1389,7 @@ exits. No access to the filename is provided. sub tmpfile { - # Simply call tmpnam() in an array context + # Simply call tmpnam() in a list context my ($fh, $file) = tmpnam(); # Make sure file is removed when filehandle is closed @@ -1402,8 +1477,8 @@ 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 and C fields seem to be different -and also. Also, it seems that the size of the file returned by stat() +be compared. For example, the C and C fields seem to be +different. Also, it seems that the size of the file returned by stat() does not always agree, with C being more accurate than C, presumably because of caching issues even when using autoflush (this is usually overcome by waiting a while after @@ -1456,6 +1531,10 @@ sub unlink0 { @okstat = (1,2,3,4,5,7,8,9,10); } elsif ($^O eq 'os2') { @okstat = (0, 2..$#fh); + } elsif ($^O eq 'VMS') { # device and file ID are sufficient + @okstat = (0, 1); + } elsif ($^O eq 'dos') { + @okstat = (0,2..7,11..$#fh); } # Now compare each entry explicitly by number @@ -1483,7 +1562,9 @@ sub unlink0 { print "Link count = $fh[3] \n" if $DEBUG; # Make sure that the link count is zero - return ( $fh[3] == 0 ? 1 : 0); + # - Cygwin provides deferred unlinking, however, + # on Win9x the link count remains 1 + return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0); } else { _deferred_unlink($fh, $path, 0); @@ -1653,7 +1734,7 @@ descriptor before passing it to another process. =head1 HISTORY Originally began life in May 1999 as an XS interface to the system -mkstemp() function. In March 2000, the mkstemp() code was +mkstemp() function. In March 2000, the OpenBSD mkstemp() code was translated to Perl for total control of the code's security checking, to ensure the presence of the function regardless of operating system and to help with portability. -- cgit v1.2.1 From e3830a4ec012ee625f1b3bc63b5b18c656f377da Mon Sep 17 00:00:00 2001 From: Charles Bailey Date: Wed, 25 Oct 2000 03:13:53 +0000 Subject: Cleanup from prior patch (Charles Lane?): - improve handling of MFDs in Basename and Path - default to no xsubpp line # munging when building debug images p4raw-id: //depot/vmsperl@7430 --- lib/File/Basename.pm | 8 ++++++-- lib/File/Path.pm | 17 ++++++++++------- 2 files changed, 16 insertions(+), 9 deletions(-) (limited to 'lib/File') diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index 4581e7e93c..243234403a 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -189,9 +189,13 @@ sub fileparse { } elsif ($fstype !~ /^VMS/i) { # default to Unix ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#s); - if ($^O eq 'VMS' and $fullname =~ m:/[^/]+/000000/?:) { + if ($^O eq 'VMS' and $fullname =~ m:^(/[^/]+/000000(/|$))(.*):) { # dev:[000000] is top of VMS tree, similar to Unix '/' - ($basename,$dirpath) = ('',$fullname); + # so strip it off and treat the rest as "normal" + my $devspec = $1; + my $remainder = $3; + ($dirpath,$basename) = ($remainder =~ m#^(.*/)?(.*)#s); + $dirpath = $devspec.$dirpath; } $dirpath = './' unless $dirpath; } diff --git a/lib/File/Path.pm b/lib/File/Path.pm index 46f360a461..ffc856bb59 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -119,16 +119,19 @@ sub mkpath { my(@created,$path); foreach $path (@$paths) { $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT - next if -d $path; # Logic wants Unix paths, so go with the flow. - $path = VMS::Filespec::unixify($path) if $Is_VMS; - my $parent = File::Basename::dirname($path); - # Allow for creation of new logical filesystems under VMS - if (not $Is_VMS or $parent !~ m:/[^/]+/000000/?:) { - unless (-d $parent or $path eq $parent) { - push(@created,mkpath($parent, $verbose, $mode)); + if ($Is_VMS) { + next if $path eq '/'; + $path = VMS::Filespec::unixify($path); + if ($path =~ m:^(/[^/]+)/?\z:) { + $path = $1.'/000000'; } } + next if -d $path; + my $parent = File::Basename::dirname($path); + unless (-d $parent or $path eq $parent) { + push(@created,mkpath($parent, $verbose, $mode)); + } print "mkdir $path\n" if $verbose; unless (mkdir($path,$mode)) { my $e = $!; -- cgit v1.2.1