Change 33572 by [EMAIL PROTECTED] on 2008/03/26 12:45:28
Integrate:
[ 33332]
Subject: [PATCH] consting for .c files in tests
From: "Robin Barker" <[EMAIL PROTECTED]>
Date: Mon, 18 Feb 2008 13:43:56 -0000
Message-ID: <[EMAIL PROTECTED]>
[ 33386]
Subject: Fwd: CPAN Upload: Y/YV/YVES/ExtUtils-Install-1.45.tar.gz
From: demerphq <[EMAIL PROTECTED]>
Date: Wed, 27 Feb 2008 14:06:29 +0100
Message-ID: <[EMAIL PROTECTED]>
Upgrade to ExtUtils-Install-1.45 to fix [cpan #32813]
[ 33404]
Synchronize blead with changes from ExtUtils::Install 1.46
Apply patches from Michael Schwern (rt #33688, rt #31429, rt #31248)
and from Slaven Rezic (rt #33290). Also implemented the suggestion from
Schwern about not dieing when failing to remove a shadow file that is
later on in INC than the installed version. (rt #2928)
[ 33410]
Update ExtUtils::Install to release 1.47
[ 33460]
Upgrade to ExtUtils-Install-1.50
[ 33566]
Subject: RE: [PATCH revised] Fix ExtUtils::Install under Cygwin
From: "Steve Hay" <[EMAIL PROTECTED]>
Message-ID: <[EMAIL PROTECTED]>
Date: Mon, 17 Mar 2008 14:36:54 -0000
"OK, so how about the attached. This fixes up -w for all compilers so
that it is symmetrical with chmod(), and adds a note to perltodo on
fixing POSIX::access() and chdir()."
The whole long thread started here:
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-03/msg00056.html
[ 33567]
Patches for VMS by Craig Berry from
http://rt.cpan.org/Public/Bug/Display.html?id=34095
(1.50 has 3 failures on VMS)
Affected files ...
... //depot/maint-5.10/perl/MANIFEST#15 integrate
... //depot/maint-5.10/perl/lib/ExtUtils/Install.pm#2 integrate
... //depot/maint-5.10/perl/lib/ExtUtils/t/Embed.t#3 integrate
... //depot/maint-5.10/perl/lib/ExtUtils/t/Install.t#2 integrate
... //depot/maint-5.10/perl/lib/ExtUtils/t/Installapi2.t#1 branch
... //depot/maint-5.10/perl/lib/ExtUtils/t/can_write_dir.t#1 branch
... //depot/maint-5.10/perl/pod/perlport.pod#3 integrate
... //depot/maint-5.10/perl/pod/perltodo.pod#4 integrate
... //depot/maint-5.10/perl/win32/win32.c#3 integrate
Differences ...
==== //depot/maint-5.10/perl/MANIFEST#15 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#14~33529~ 2008-03-14 04:50:59.000000000 -0700
+++ perl/MANIFEST 2008-03-26 05:45:28.000000000 -0700
@@ -1797,6 +1797,7 @@
lib/ExtUtils/t/basic.t See if MakeMaker can build a module
lib/ExtUtils/t/build_man.t Set if MakeMaker builds manpages
lib/ExtUtils/t/bytes.t Test ExtUtils::MakeMaker::bytes
+lib/ExtUtils/t/can_write_dir.t Does the _can_write_dir function of
ExtUtils::Install work properly?
lib/ExtUtils/t/cd.t Test to see cd works
lib/ExtUtils/t/config.t Test ExtUtils::MakeMaker::Config
lib/ExtUtils/t/Constant.t See if ExtUtils::Constant works
@@ -1810,6 +1811,7 @@
lib/ExtUtils/t/INSTALL_BASE.t Test INSTALL_BASE in MakeMaker
lib/ExtUtils/t/Installed.t See if ExtUtils::Installed works
lib/ExtUtils/t/Install.t See if ExtUtils::Install works
+lib/ExtUtils/t/Installapi2.t See if new api for ExtUtils::Install::install()
works
lib/ExtUtils/t/INST_PREFIX.t See if MakeMaker can apply PREFIXs
lib/ExtUtils/t/INST.t Check MakeMaker INST_* macros
lib/ExtUtils/t/Liblist.t See if ExtUtils::Liblist works
==== //depot/maint-5.10/perl/lib/ExtUtils/Install.pm#2 (text) ====
Index: perl/lib/ExtUtils/Install.pm
--- perl/lib/ExtUtils/Install.pm#1~32694~ 2007-12-22 01:23:09.000000000
-0800
+++ perl/lib/ExtUtils/Install.pm 2008-03-26 05:45:28.000000000 -0700
@@ -1,10 +1,7 @@
package ExtUtils::Install;
-use 5.00503;
use strict;
use vars qw(@ISA @EXPORT $VERSION $MUST_REBOOT %Config);
-$VERSION = '1.44';
-$VERSION = eval $VERSION;
use AutoSplit;
use Carp ();
@@ -23,6 +20,8 @@
@ISA = ('Exporter');
@EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
+=pod
+
=head1 NAME
ExtUtils::Install - install files from here to there
@@ -36,6 +35,17 @@
uninstall($packlist);
pm_to_blib({ 'lib/Foo/Bar.pm' => 'blib/lib/Foo/Bar.pm' });
+
+=head1 VERSION
+
+1.51
+
+=cut
+
+$VERSION = '1.50_01';
+$VERSION = eval $VERSION;
+
+=pod
=head1 DESCRIPTION
@@ -238,8 +248,9 @@
my ( $file, $tryhard, $installing )= @_;
_chmod( 0666, $file );
- unlink $file
- and return $file;
+ my $unlink_count = 0;
+ while (unlink $file) { $unlink_count++; }
+ return $file if $unlink_count > 0;
my $error="$!";
_choke("Cannot unlink '$file': $!")
@@ -272,58 +283,10 @@
}
+=pod
=head2 Functions
-=over 4
-
-=item B<install>
-
- install(\%from_to);
- install(\%from_to, $verbose, $dont_execute, $uninstall_shadows, $skip);
-
-Copies each directory tree of %from_to to its corresponding value
-preserving timestamps and permissions.
-
-There are two keys with a special meaning in the hash: "read" and
-"write". These contain packlist files. After the copying is done,
-install() will write the list of target files to $from_to{write}. If
-$from_to{read} is given the contents of this file will be merged into
-the written file. The read and the written file may be identical, but
-on AFS it is quite likely that people are installing to a different
-directory than the one where the files later appear.
-
-If $verbose is true, will print out each file removed. Default is
-false. This is "make install VERBINST=1". $verbose values going
-up to 5 show increasingly more diagnostics output.
-
-If $dont_execute is true it will only print what it was going to do
-without actually doing it. Default is false.
-
-If $uninstall_shadows is true any differing versions throughout @INC
-will be uninstalled. This is "make install UNINST=1"
-
-As of 1.37_02 install() supports the use of a list of patterns to filter
-out files that shouldn't be installed. If $skip is omitted or undefined
-then install will try to read the list from INSTALL.SKIP in the CWD.
-This file is a list of regular expressions and is just like the
-MANIFEST.SKIP file used by L<ExtUtils::Manifest>.
-
-A default site INSTALL.SKIP may be provided by setting then environment
-variable EU_INSTALL_SITE_SKIPFILE, this will only be used when there
-isn't a distribution specific INSTALL.SKIP. If the environment variable
-EU_INSTALL_IGNORE_SKIP is true then no install file filtering will be
-performed.
-
-If $skip is undefined then the skip file will be autodetected and used if it
-is found. If $skip is a reference to an array then it is assumed
-the array contains the list of patterns, if $skip is a true non reference it is
-assumed to be the filename holding the list of patterns, any other value of
-$skip is taken to mean that no install filtering should occur.
-
-
-=cut
-
=begin _private
=item _get_install_skip
@@ -383,19 +346,21 @@
return $skip
}
+=pod
+
=item _have_write_access
Abstract a -w check that tries to use POSIX::access() if possible.
=cut
-
{
my $has_posix;
sub _have_write_access {
my $dir=shift;
- if (!defined $has_posix) {
- $has_posix=eval "local $^W; require POSIX; 1" || 0;
+ unless (defined $has_posix) {
+ $has_posix= (!$Is_cygwin && !$Is_Win32
+ && eval 'local $^W; require POSIX; 1') || 0;
}
if ($has_posix) {
return POSIX::access($dir, POSIX::W_OK());
@@ -405,6 +370,7 @@
}
}
+=pod
=item _can_write_dir(C<$dir>)
@@ -431,12 +397,22 @@
return
unless defined $dir and length $dir;
- my ($vol, $dirs, $file) =
File::Spec->splitpath(File::Spec->rel2abs($dir),1);
+ my ($vol, $dirs, $file) = File::Spec->splitpath($dir,1);
my @dirs = File::Spec->splitdir($dirs);
+ unshift @dirs, File::Spec->curdir
+ unless File::Spec->file_name_is_absolute($dir);
+
my $path='';
my @make;
while (@dirs) {
- $dir = File::Spec->catdir($vol,@dirs);
+ if ($Is_VMS) {
+ $dir = File::Spec->catdir($vol,@dirs);
+ }
+ else {
+ $dir = File::Spec->catdir(@dirs);
+ $dir = File::Spec->catpath($vol,$dir,'')
+ if defined $vol and length $vol;
+ }
next if ( $dir eq $path );
if ( ! -e $dir ) {
unshift @make,$dir;
@@ -453,29 +429,31 @@
return 0;
}
-=item _mkpath($dir,$show,$mode,$verbose,$fake)
+=pod
+
+=item _mkpath($dir,$show,$mode,$verbose,$dry_run)
Wrapper around File::Path::mkpath() to handle errors.
If $verbose is true and >1 then additional diagnostics will be produced, also
this will force $show to true.
-If $fake is true then the directory will not be created but a check will be
+If $dry_run is true then the directory will not be created but a check will be
made to see whether it would be possible to write to the directory, or that
it would be possible to create the directory.
-If $fake is not true dies if the directory can not be created or is not
+If $dry_run is not true dies if the directory can not be created or is not
writable.
=cut
sub _mkpath {
- my ($dir,$show,$mode,$verbose,$fake)[EMAIL PROTECTED];
+ my ($dir,$show,$mode,$verbose,$dry_run)[EMAIL PROTECTED];
if ( $verbose && $verbose > 1 && ! -d $dir) {
$show= 1;
printf "mkpath(%s,%d,%#o)\n", $dir, $show, $mode;
}
- if (!$fake) {
+ if (!$dry_run) {
if ( ! eval { File::Path::mkpath($dir,$show,$mode); 1 } ) {
_choke("Can't create '$dir'","$@");
}
@@ -488,23 +466,26 @@
$root ? "Do not have write permissions on '$root'"
: "Unknown Error"
);
- if ($fake) {
+ if ($dry_run) {
_warnonce @msg;
} else {
_choke @msg;
}
- } elsif ($show and $fake) {
+ } elsif ($show and $dry_run) {
print "$_\n" for @make;
}
+
}
-=item _copy($from,$to,$verbose,$fake)
+=pod
+
+=item _copy($from,$to,$verbose,$dry_run)
Wrapper around File::Copy::copy to handle errors.
If $verbose is true and >1 then additional dignostics will be emitted.
-If $fake is true then the copy will not actually occur.
+If $dry_run is true then the copy will not actually occur.
Dies if the copy fails.
@@ -512,16 +493,18 @@
sub _copy {
- my ( $from, $to, $verbose, $nonono)[EMAIL PROTECTED];
+ my ( $from, $to, $verbose, $dry_run)[EMAIL PROTECTED];
if ($verbose && $verbose>1) {
printf "copy(%s,%s)\n", $from, $to;
}
- if (!$nonono) {
+ if (!$dry_run) {
File::Copy::copy($from,$to)
or Carp::croak( _estr "ERROR: Cannot copy '$from' to '$to': $!" );
}
}
+=pod
+
=item _chdir($from)
Wrapper around chdir to catch errors.
@@ -543,16 +526,149 @@
return $ret;
}
+=pod
+
=end _private
+=over 4
+
+=item B<install>
+
+ # deprecated forms
+ install(\%from_to);
+ install(\%from_to, $verbose, $dry_run, $uninstall_shadows,
+ $skip, $always_copy, \%result);
+
+ # recommended form as of 1.47
+ install([
+ from_to => \%from_to,
+ verbose => 1,
+ dry_run => 0,
+ uninstall_shadows => 1,
+ skip => undef,
+ always_copy => 1,
+ result => \%install_results,
+ ]);
+
+
+Copies each directory tree of %from_to to its corresponding value
+preserving timestamps and permissions.
+
+There are two keys with a special meaning in the hash: "read" and
+"write". These contain packlist files. After the copying is done,
+install() will write the list of target files to $from_to{write}. If
+$from_to{read} is given the contents of this file will be merged into
+the written file. The read and the written file may be identical, but
+on AFS it is quite likely that people are installing to a different
+directory than the one where the files later appear.
+
+If $verbose is true, will print out each file removed. Default is
+false. This is "make install VERBINST=1". $verbose values going
+up to 5 show increasingly more diagnostics output.
+
+If $dry_run is true it will only print what it was going to do
+without actually doing it. Default is false.
+
+If $uninstall_shadows is true any differing versions throughout @INC
+will be uninstalled. This is "make install UNINST=1"
+
+As of 1.37_02 install() supports the use of a list of patterns to filter out
+files that shouldn't be installed. If $skip is omitted or undefined then
+install will try to read the list from INSTALL.SKIP in the CWD. This file is
+a list of regular expressions and is just like the MANIFEST.SKIP file used
+by L<ExtUtils::Manifest>.
+
+A default site INSTALL.SKIP may be provided by setting then environment
+variable EU_INSTALL_SITE_SKIPFILE, this will only be used when there isn't a
+distribution specific INSTALL.SKIP. If the environment variable
+EU_INSTALL_IGNORE_SKIP is true then no install file filtering will be
+performed.
+
+If $skip is undefined then the skip file will be autodetected and used if it
+is found. If $skip is a reference to an array then it is assumed the array
+contains the list of patterns, if $skip is a true non reference it is
+assumed to be the filename holding the list of patterns, any other value of
+$skip is taken to mean that no install filtering should occur.
+
+B<Changes As of Version 1.47>
+
+As of version 1.47 the following additions were made to the install interface.
+Note that the new argument style and use of the %result hash is recommended.
+
+The $always_copy parameter which when true causes files to be updated
+regardles as to whether they have changed, if it is defined but false then
+copies are made only if the files have changed, if it is undefined then the
+value of the environment variable EU_INSTALL_ALWAYS_COPY is used as default.
+
+The %result hash will be populated with the various keys/subhashes reflecting
+the install. Currently these keys and their structure are:
+
+ install => { $target => $source },
+ install_fail => { $target => $source },
+ install_unchanged => { $target => $source },
+
+ install_filtered => { $source => $pattern },
+
+ uninstall => { $uninstalled => $source },
+ uninstall_fail => { $uninstalled => $source },
+
+where C<$source> is the filespec of the file being installed. C<$target> is
where
+it is being installed to, and C<$uninstalled> is any shadow file that is in
C<@INC>
+or C<$ENV{PERL5LIB}> or other standard locations, and C<$pattern> is the
pattern that
+caused a source file to be skipped. In future more keys will be added, such as
to
+show created directories, however this requires changes in other modules and
must
+therefore wait.
+
+These keys will be populated before any exceptions are thrown should there be
an
+error.
+
+Note that all updates of the %result are additive, the hash will not be
+cleared before use, thus allowing status results of many installs to be easily
+aggregated.
+
+B<NEW ARGUMENT STYLE>
+
+If there is only one argument and it is a reference to an array then
+the array is assumed to contain a list of key-value pairs specifying
+the options. In this case the option "from_to" is mandatory. This style
+means that you dont have to supply a cryptic list of arguments and can
+use a self documenting argument list that is easier to understand.
+
+This is now the recommended interface to install().
+
+B<RETURN>
+
+If all actions were successful install will return a hashref of the results
+as described above for the $result parameter. If any action is a failure
+then install will die, therefore it is recommended to pass in the $result
+parameter instead of using the return value. If the result parameter is
+provided then the returned hashref will be the passed in hashref.
+
=cut
sub install { #XXX OS-SPECIFIC
- my($from_to,$verbose,$nonono,$inc_uninstall,$skip) = @_;
+
my($from_to,$verbose,$dry_run,$uninstall_shadows,$skip,$always_copy,$result) =
@_;
+ if (@_==1 and eval { [EMAIL PROTECTED] }) {
+ my %opts = @$from_to;
+ $from_to = $opts{from_to}
+ or Carp::confess("from_to is a mandatory
parameter");
+ $verbose = $opts{verbose};
+ $dry_run = $opts{dry_run};
+ $uninstall_shadows = $opts{uninstall_shadows};
+ $skip = $opts{skip};
+ $always_copy = $opts{always_copy};
+ $result = $opts{result};
+ }
+
+ $result ||= {};
$verbose ||= 0;
- $nonono ||= 0;
+ $dry_run ||= 0;
$skip= _get_install_skip($skip,$verbose);
+ $always_copy = $ENV{EU_INSTALL_ALWAYS_COPY}
+ || $ENV{EU_ALWAYS_COPY}
+ || 0
+ unless defined $always_copy;
my(%from_to) = %$from_to;
my(%pack, $dir, %warned);
@@ -614,6 +730,7 @@
if ( $sourcefile=~/$pat/ ) {
print "Skipping $targetfile (filtered)\n"
if $verbose>1;
+ $result->{install_filtered}{$sourcefile} = $pat;
return;
}
}
@@ -621,11 +738,12 @@
# and because the target is relative
my $save_cwd = _chdir($cwd);
my $diff = 0;
- if ( -f $targetfile && -s _ == $size) {
- # We have a good chance, we can skip this one
- $diff = compare($sourcefile, $targetfile);
- } else {
+ # XXX: I wonder how useful this logic is actually -- demerphq
+ if ( $always_copy or !-f $targetfile or -s $targetfile != $size) {
$diff++;
+ } else {
+ # we might not need to copy this file
+ $diff = compare($sourcefile, $targetfile);
}
$check_dirs{$targetdir}++
unless -w $targetfile;
@@ -642,9 +760,8 @@
}, $current_directory );
_chdir($cwd);
}
-
foreach my $targetdir (sort keys %check_dirs) {
- _mkpath( $targetdir, 0, 0755, $verbose, $nonono );
+ _mkpath( $targetdir, 0, 0755, $verbose, $dry_run );
}
foreach my $found (@found_files) {
my ($diff, $ffd, $origfile, $mode, $size, $atime, $mtime,
@@ -652,32 +769,44 @@
my $realtarget= $targetfile;
if ($diff) {
- if (-f $targetfile) {
- print "_unlink_or_rename($targetfile)\n" if $verbose>1;
- $targetfile= _unlink_or_rename( $targetfile, 'tryhard',
'install' )
- unless $nonono;
- } elsif ( ! -d $targetdir ) {
- _mkpath( $targetdir, 0, 0755, $verbose, $nonono );
- }
- print "Installing $targetfile\n";
- _copy( $sourcefile, $targetfile, $verbose, $nonono, );
- #XXX OS-SPECIFIC
- print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
- utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
-
-
- $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
- $mode = $mode | 0222
- if $realtarget ne $targetfile;
- _chmod( $mode, $targetfile, $verbose );
+ eval {
+ if (-f $targetfile) {
+ print "_unlink_or_rename($targetfile)\n" if $verbose>1;
+ $targetfile= _unlink_or_rename( $targetfile, 'tryhard',
'install' )
+ unless $dry_run;
+ } elsif ( ! -d $targetdir ) {
+ _mkpath( $targetdir, 0, 0755, $verbose, $dry_run );
+ }
+ print "Installing $targetfile\n";
+
+ _copy( $sourcefile, $targetfile, $verbose, $dry_run, );
+
+
+ #XXX OS-SPECIFIC
+ print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
+ utime($atime,$mtime + $Is_VMS,$targetfile) unless $dry_run>1;
+
+
+ $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
+ $mode = $mode | 0222
+ if $realtarget ne $targetfile;
+ _chmod( $mode, $targetfile, $verbose );
+ $result->{install}{$targetfile} = $sourcefile;
+ 1
+ } or do {
+ $result->{install_fail}{$targetfile} = $sourcefile;
+ die $@;
+ };
} else {
+ $result->{install_unchanged}{$targetfile} = $sourcefile;
print "Skipping $targetfile (unchanged)\n" if $verbose;
}
- if ( $inc_uninstall ) {
+ if ( $uninstall_shadows ) {
inc_uninstall($sourcefile,$ffd, $verbose,
- $nonono,
- $realtarget ne $targetfile ? $realtarget : "");
+ $dry_run,
+ $realtarget ne $targetfile ? $realtarget : "",
+ $result);
}
# Record the full pathname.
@@ -686,12 +815,13 @@
if ($pack{'write'}) {
$dir = install_rooted_dir(dirname($pack{'write'}));
- _mkpath( $dir, 0, 0755, $verbose, $nonono );
+ _mkpath( $dir, 0, 0755, $verbose, $dry_run );
print "Writing $pack{'write'}\n";
- $packlist->write(install_rooted_file($pack{'write'})) unless $nonono;
+ $packlist->write(install_rooted_file($pack{'write'})) unless $dry_run;
}
_do_cleanup($verbose);
+ return $result;
}
=begin _private
@@ -767,7 +897,7 @@
sub forceunlink {
my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC
- _unlink_or_rename( $file, $tryhard );
+ _unlink_or_rename( $file, $tryhard, not("installing") );
}
=begin _undocumented
@@ -794,6 +924,7 @@
return $files;
}
+=pod
=item B<install_default> I<DISCOURAGED>
@@ -857,9 +988,9 @@
=cut
sub uninstall {
- my($fil,$verbose,$nonono) = @_;
+ my($fil,$verbose,$dry_run) = @_;
$verbose ||= 0;
- $nonono ||= 0;
+ $dry_run ||= 0;
die _estr "ERROR: no packlist file found: '$fil'"
unless -f $fil;
@@ -869,40 +1000,53 @@
foreach (sort(keys(%$packlist))) {
chomp;
print "unlink $_\n" if $verbose;
- forceunlink($_,'tryhard') unless $nonono;
+ forceunlink($_,'tryhard') unless $dry_run;
}
print "unlink $fil\n" if $verbose;
- forceunlink($fil, 'tryhard') unless $nonono;
+ forceunlink($fil, 'tryhard') unless $dry_run;
_do_cleanup($verbose);
}
=begin _undocumented
-=item inc_uninstall($filepath,$libdir,$verbose,$nonono,$ignore)
+=item inc_uninstall($filepath,$libdir,$verbose,$dry_run,$ignore,$results)
Remove shadowed files. If $ignore is true then it is assumed to hold
a filename to ignore. This is used to prevent spurious warnings from
occuring when doing an install at reboot.
+We now only die when failing to remove a file that has precedence over
+our own, when our install has precedence we only warn.
+
+$results is assumed to contain a hashref which will have the keys
+'uninstall' and 'uninstall_fail' populated with keys for the files
+removed and values of the source files they would shadow.
+
=end _undocumented
=cut
sub inc_uninstall {
- my($filepath,$libdir,$verbose,$nonono,$ignore) = @_;
+ my($filepath,$libdir,$verbose,$dry_run,$ignore,$results) = @_;
my($dir);
$ignore||="";
my $file = (File::Spec->splitpath($filepath))[2];
my %seen_dir = ();
-
+
my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'}
? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
-
- foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
- privlibexp
- sitearchexp
- sitelibexp)}) {
- my $canonpath = File::Spec->canonpath($dir);
+
+ my @dirs=( @PERL_ENV_LIB,
+ @INC,
+ @Config{qw(archlibexp
+ privlibexp
+ sitearchexp
+ sitelibexp)});
+
+ #warn join "\n","---",@dirs,"---";
+ my $seen_ours;
+ foreach $dir ( @dirs ) {
+ my $canonpath = $Is_VMS ? $dir : File::Spec->canonpath($dir);
next if $canonpath eq $Curdir;
next if $seen_dir{$canonpath}++;
my $targetfile = File::Spec->catfile($canonpath,$libdir,$file);
@@ -920,8 +1064,12 @@
}
print "#$file and $targetfile differ\n" if $diff && $verbose > 1;
- next if !$diff or $targetfile eq $ignore;
- if ($nonono) {
+ if (!$diff or $targetfile eq $ignore) {
+ $seen_ours = 1;
+ next;
+ }
+ if ($dry_run) {
+ $results->{uninstall}{$targetfile} = $filepath;
if ($verbose) {
$Inc_uninstall_warn_handler ||= ExtUtils::Install::Warn->new();
$libdir =~ s|^\./||s ; # That's just cosmetics, no need to
port. It looks prettier.
@@ -933,7 +1081,21 @@
# if not verbose, we just say nothing
} else {
print "Unlinking $targetfile (shadowing?)\n" if $verbose;
- forceunlink($targetfile,'tryhard');
+ eval {
+ die "Fake die for testing"
+ if $ExtUtils::Install::Testing and
+
ucase(File::Spec->canonpath($ExtUtils::Install::Testing)) eq ucase($targetfile);
+ forceunlink($targetfile,'tryhard');
+ $results->{uninstall}{$targetfile} = $filepath;
+ 1;
+ } or do {
+ $results->{fail_uninstall}{$targetfile} = $filepath;
+ if ($seen_ours) {
+ warn "Failed to remove probably harmless shadow file
'$targetfile'\n";
+ } else {
+ die "[EMAIL PROTECTED]";
+ }
+ };
}
}
}
@@ -962,6 +1124,7 @@
close CMD or die "Filter command '$cmd' failed for $src";
}
+=pod
=item B<pm_to_blib>
@@ -1068,7 +1231,8 @@
}
$plural = $i>1 ? "all those files" : "this file";
my $inst = (_invokant() eq 'ExtUtils::MakeMaker')
- ? ( $Config::Config{make} || 'make' ).' install UNINST=1'
+ ? ( $Config::Config{make} || 'make' ).' install'
+ . ( $Is_VMS ? '/MACRO="UNINST"=1' : ' UNINST=1' )
: './Build install uninst=1';
print "## Running '$inst' will unlink $plural for you.\n";
}
@@ -1103,6 +1267,7 @@
return $builder;
}
+=pod
=back
@@ -1123,13 +1288,23 @@
If there is no INSTALL.SKIP file in the make directory then this value
can be used to provide a default.
+=item B<EU_INSTALL_ALWAYS_COPY>
+
+If this environment variable is true then normal install processes will
+always overwrite older identical files during the install process.
+
+Note that the alias EU_ALWAYS_COPY will be supported if EU_INSTALL_ALWAYS_COPY
+is not defined until at least the 1.50 release. Please ensure you use the
+correct EU_INSTALL_ALWAYS_COPY.
+
=back
=head1 AUTHOR
Original author lost in the mists of time. Probably the same as Makemaker.
-Production release currently maintained by demerphq C<yves at cpan.org>
+Production release currently maintained by demerphq C<yves at cpan.org>,
+extensive changes by Michael G. Schwern.
Send bug reports via http://rt.cpan.org/. Please send your
generated Makefile along with your report.
==== //depot/maint-5.10/perl/lib/ExtUtils/t/Embed.t#3 (text) ====
Index: perl/lib/ExtUtils/t/Embed.t
--- perl/lib/ExtUtils/t/Embed.t#2~33483~ 2008-03-11 14:22:23.000000000
-0700
+++ perl/lib/ExtUtils/t/Embed.t 2008-03-26 05:45:28.000000000 -0700
@@ -163,7 +163,7 @@
#define my_puts(a) if(puts(a) < 0) exit(666)
-static char *cmds[] = { "perl","-e", "$|=1; print qq[ok 5\\n]", NULL };
+static const char * cmds [] = { "perl", "-e", "$|=1; print qq[ok 5\\n]", NULL
};
#ifdef PERL_GLOBAL_STRUCT_PRIVATE
static struct perl_vars *my_plvarsp;
@@ -171,12 +171,11 @@
#endif
#ifdef NO_ENV_ARRAY_IN_MAIN
-extern char **environ;
-int main(int argc, char **argv)
+int main(int argc, char **argv) {
+ char **env;
#else
-int main(int argc, char **argv, char **env)
+int main(int argc, char **argv, char **env) {
#endif
-{
PerlInterpreter *my_perl;
#ifdef PERL_GLOBAL_STRUCT
dVAR;
@@ -188,11 +187,7 @@
(void)argc; /* PERL_SYS_INIT3 may #define away their use */
(void)argv;
-#ifdef NO_ENV_ARRAY_IN_MAIN
- PERL_SYS_INIT3(&argc,&argv,&environ);
-#else
- PERL_SYS_INIT3(&argc,&argv,&env);
-#endif
+ PERL_SYS_INIT3(&argc, &argv, &env);
my_perl = perl_alloc();
@@ -202,11 +197,7 @@
my_puts("ok 3");
-#ifdef NO_ENV_ARRAY_IN_MAIN
- perl_parse(my_perl, NULL, (sizeof(cmds)/sizeof(char *))-1, cmds, environ);
-#else
- perl_parse(my_perl, NULL, (sizeof(cmds)/sizeof(char *))-1, cmds, env);
-#endif
+ perl_parse(my_perl, NULL, (sizeof(cmds)/sizeof(char *))-1, (char **)cmds,
env);
my_puts("ok 4");
==== //depot/maint-5.10/perl/lib/ExtUtils/t/Install.t#2 (text) ====
Index: perl/lib/ExtUtils/t/Install.t
--- perl/lib/ExtUtils/t/Install.t#1~32694~ 2007-12-22 01:23:09.000000000
-0800
+++ perl/lib/ExtUtils/t/Install.t 2008-03-26 05:45:28.000000000 -0700
@@ -17,11 +17,14 @@
use File::Path;
use File::Spec;
-use Test::More tests => 38;
+use Test::More tests => 52;
use MakeMaker::Test::Setup::BFD;
BEGIN { use_ok('ExtUtils::Install') }
+# ensure the env doesnt pollute our tests
+local $ENV{EU_INSTALL_ALWAYS_COPY};
+local $ENV{EU_ALWAYS_COPY};
# Check exports.
foreach my $func (qw(install uninstall pm_to_blib install_default)) {
@@ -122,6 +125,56 @@
' UNINST=0 left different' );
}
+# Test UNINST=1 only warning when failing to remove an irrelevent shadow file
+{
+ my $tfile='install-test/lib/perl/Big/Dummy.pm';
+ local $ExtUtils::Install::Testing = $tfile;
+ local @INC = ('install-test/other_lib/perl','install-test/lib/perl');
+ local $ENV{PERL5LIB} = '';
+ ok( -r $tfile, 'different install exists' );
+ my @warn;
+ local $SIG{__WARN__}=sub { push @warn, @_; return };
+ my $ok=eval {
+ install( { 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },
+ 0, 0, 1);
+ 1
+ };
+ ok($ok,' we didnt die');
+ ok([EMAIL PROTECTED]," we did warn");
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+ ok( -r $tfile, ' UNINST=1 failed to remove different' );
+
+}
+
+# Test UNINST=1 dieing when failing to remove an relevent shadow file
+{
+ my $tfile='install-test/lib/perl/Big/Dummy.pm';
+ local $ExtUtils::Install::Testing = $tfile;
+ local @INC = ('install-test/lib/perl','install-test/other_lib/perl');
+ local $ENV{PERL5LIB} = '';
+ ok( -r $tfile, 'different install exists' );
+ my @warn;
+ local $SIG{__WARN__}=sub { push @warn,@_; return };
+ my $ok=eval {
+ install( { 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },
+ 0, 0, 1);
+ 1
+ };
+ ok(!$ok,' we did die');
+ ok([EMAIL PROTECTED]," we didnt warn");
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+ ok( -r $tfile,' UNINST=1 failed to remove different' );
+}
# Test UNINST=1 removing other versions in other dirs.
{
@@ -138,3 +191,4 @@
ok( !-r 'install-test/lib/perl/Big/Dummy.pm',
' UNINST=1 removed different' );
}
+
==== //depot/maint-5.10/perl/lib/ExtUtils/t/Installapi2.t#1 (text) ====
Index: perl/lib/ExtUtils/t/Installapi2.t
--- /dev/null 2008-03-18 12:45:05.529577733 -0700
+++ perl/lib/ExtUtils/t/Installapi2.t 2008-03-26 05:45:28.000000000 -0700
@@ -0,0 +1,238 @@
+#!/usr/bin/perl -w
+
+# Test ExtUtils::Install.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ @INC = ('../../lib', '../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use strict;
+use TieOut;
+use File::Path;
+use File::Spec;
+
+use Test::More tests => 70;
+
+use MakeMaker::Test::Setup::BFD;
+
+BEGIN { use_ok('ExtUtils::Install') }
+
+# Check exports.
+foreach my $func (qw(install uninstall pm_to_blib install_default)) {
+ can_ok(__PACKAGE__, $func);
+}
+
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir );
+ ok( teardown_recurs(), 'teardown' );
+}
+# ensure the env doesnt pollute our tests
+local $ENV{EU_INSTALL_ALWAYS_COPY};
+local $ENV{EU_ALWAYS_COPY};
+
+chdir 'Big-Dummy';
+
+my $stdout = tie *STDOUT, 'TieOut';
+pm_to_blib( { 'lib/Big/Dummy.pm' => 'blib/lib/Big/Dummy.pm' },
+ 'blib/lib/auto'
+ );
+END { rmtree 'blib' }
+
+ok( -d 'blib/lib', 'pm_to_blib created blib dir' );
+ok( -r 'blib/lib/Big/Dummy.pm', ' copied .pm file' );
+ok( -r 'blib/lib/auto', ' created autosplit dir' );
+is( $stdout->read, "cp lib/Big/Dummy.pm blib/lib/Big/Dummy.pm\n" );
+
+pm_to_blib( { 'lib/Big/Dummy.pm' => 'blib/lib/Big/Dummy.pm' },
+ 'blib/lib/auto'
+ );
+ok( -d 'blib/lib', 'second run, blib dir still there' );
+ok( -r 'blib/lib/Big/Dummy.pm', ' .pm file still there' );
+ok( -r 'blib/lib/auto', ' autosplit still there' );
+is( $stdout->read, "Skip blib/lib/Big/Dummy.pm (unchanged)\n" );
+
+install( [
+ from_to=>{ 'blib/lib' => 'install-test/lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },
+ dry_run=>1]);
+ok( ! -d 'install-test/lib/perl', 'install made dir (dry run)');
+ok( ! -r 'install-test/lib/perl/Big/Dummy.pm',
+ ' .pm file installed (dry run)');
+ok( ! -r 'install-test/packlist', ' packlist exists (dry run)');
+
+install([ from_to=> { 'blib/lib' => 'install-test/lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ } ]);
+ok( -d 'install-test/lib/perl', 'install made dir' );
+ok( -r 'install-test/lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ok(!-r 'install-test/lib/perl/Big/Dummy.SKIP', ' ignored .SKIP file' );
+ok( -r 'install-test/packlist', ' packlist exists' );
+
+open(PACKLIST, 'install-test/packlist' );
+my %packlist = map { chomp; ($_ => 1) } <PACKLIST>;
+close PACKLIST;
+
+# On case-insensitive filesystems (ie. VMS), the keys of the packlist might
+# be lowercase. :(
+my $native_dummy = File::Spec->catfile(qw(install-test lib perl Big Dummy.pm));
+is( keys %packlist, 1 );
+is( lc((keys %packlist)[0]), lc $native_dummy, 'packlist written' );
+
+
+# Test UNINST=1 preserving same versions in other dirs.
+install([from_to=> { 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },uninstall_shadows=>1]);
+ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ok( -r 'install-test/packlist', ' packlist exists' );
+ok( -r 'install-test/lib/perl/Big/Dummy.pm', ' UNINST=1 preserved same' );
+
+
+chmod 0644, 'blib/lib/Big/Dummy.pm' or die $!;
+open(DUMMY, ">>blib/lib/Big/Dummy.pm") or die $!;
+print DUMMY "Extra stuff\n";
+close DUMMY;
+
+
+# Test UNINST=0 does not remove other versions in other dirs.
+{
+ ok( -r 'install-test/lib/perl/Big/Dummy.pm', 'different install exists' );
+
+ local @INC = ('install-test/lib/perl');
+ local $ENV{PERL5LIB} = '';
+ install([from_to=> { 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ }]);
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+ ok( -r 'install-test/lib/perl/Big/Dummy.pm',
+ ' UNINST=0 left different' );
+}
+
+# Test UNINST=1 only warning when failing to remove an irrelevent shadow file
+{
+ my $tfile='install-test/lib/perl/Big/Dummy.pm';
+ local $ExtUtils::Install::Testing = $tfile;
+ local @INC = ('install-test/other_lib/perl','install-test/lib/perl');
+ local $ENV{PERL5LIB} = '';
+ ok( -r $tfile, 'different install exists' );
+ my @warn;
+ local $SIG{__WARN__}=sub { push @warn, @_; return };
+ my $ok=eval {
+ install([from_to=> { 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },
+ uninstall_shadows=>1]);
+ 1
+ };
+ ok($ok,' we didnt die');
+ ok([EMAIL PROTECTED]," we did warn");
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+ ok( -r $tfile, ' UNINST=1 failed to remove different' );
+
+}
+
+# Test UNINST=1 dieing when failing to remove an relevent shadow file
+{
+ my $tfile='install-test/lib/perl/Big/Dummy.pm';
+ local $ExtUtils::Install::Testing = $tfile;
+ local @INC = ('install-test/lib/perl','install-test/other_lib/perl');
+ local $ENV{PERL5LIB} = '';
+ ok( -r $tfile, 'different install exists' );
+ my @warn;
+ local $SIG{__WARN__}=sub { push @warn,@_; return };
+ my $ok=eval {
+ install([from_to=> { 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },uninstall_shadows=>1]);
+ 1
+ };
+ ok(!$ok,' we did die');
+ ok([EMAIL PROTECTED]," we didnt warn");
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+ ok( -r $tfile,' UNINST=1 failed to remove different' );
+}
+
+# Test UNINST=1 removing other versions in other dirs.
+{
+ local @INC = ('install-test/lib/perl');
+ local $ENV{PERL5LIB} = '';
+ ok( -r 'install-test/lib/perl/Big/Dummy.pm','different install exists' );
+ install([from_to=>{ 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },uninstall_shadows=>1]);
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+ ok( !-r 'install-test/lib/perl/Big/Dummy.pm',
+ ' UNINST=1 removed different' );
+}
+
+# Test EU_ALWAYS_COPY triggers copy.
+{
+ local @INC = ('install-test/lib/perl');
+ local $ENV{PERL5LIB} = '';
+ local $ENV{EU_INSTALL_ALWAYS_COPY}=1;
+ my $tfile='install-test/other_lib/perl/Big/Dummy.pm';
+ my $sfile='blib/lib/Big/Dummy.pm';
+ ok(-r $tfile,"install file already exists");
+ ok(-r $sfile,"source file already exists");
+ utime time-600, time-600, $sfile or die "utime '$sfile' failed:$!";
+ ok( (stat $tfile)[9]!=(stat $sfile)[9],' Times are different');
+ install([from_to=>{ 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },result=>\my %result]);
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+SKIP: {
+ skip "Times not preserved during copy by default", 1 if $^O eq 'VMS';
+ ok( (stat $tfile)[9]==(stat $sfile)[9],' Times are same');
+}
+ ok( !$result{install_unchanged},' $result{install_unchanged} should be
empty');
+}
+# Test nothing is copied.
+{
+ local @INC = ('install-test/lib/perl');
+ local $ENV{PERL5LIB} = '';
+ local $ENV{EU_INSTALL_ALWAYS_COPY}=0;
+ my $tfile='install-test/other_lib/perl/Big/Dummy.pm';
+ my $sfile='blib/lib/Big/Dummy.pm';
+ ok(-r $tfile,"install file already exists");
+ ok(-r $sfile,"source file already exists");
+ utime time-1200, time-1200, $sfile or die "utime '$sfile' failed:$!";
+ ok( (stat $tfile)[9]!=(stat $sfile)[9],' Times are different');
+ install([from_to=>{ 'blib/lib' => 'install-test/other_lib/perl',
+ read => 'install-test/packlist',
+ write => 'install-test/packlist'
+ },result=>\my %result]);
+ ok( -d 'install-test/other_lib/perl', 'install made other dir' );
+ ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', ' .pm file installed' );
+ ok( -r 'install-test/packlist', ' packlist exists' );
+ ok( (stat $tfile)[9]!=(stat$sfile)[9],' Times are different');
+ ok( !$result{install},' nothing should have been installed');
+ ok( $result{install_unchanged},' install_unchanged should be populated');
+}
==== //depot/maint-5.10/perl/lib/ExtUtils/t/can_write_dir.t#1 (xtext) ====
Index: perl/lib/ExtUtils/t/can_write_dir.t
--- /dev/null 2008-03-18 12:45:05.529577733 -0700
+++ perl/lib/ExtUtils/t/can_write_dir.t 2008-03-26 05:45:28.000000000 -0700
@@ -0,0 +1,61 @@
+#!/usr/bin/perl -w
+
+# Test the private _can_write_dir() function.
+
+use strict;
+use ExtUtils::Install;
+use File::Spec;
+{ package FS; our @ISA = qw(File::Spec); }
+
+# Alias it for easier access
+*can_write_dir = \&ExtUtils::Install::_can_write_dir;
+
+use Test::More 'no_plan';
+
+
+my $dne = FS->catdir(qw(does not exist));
+ok ! -e $dne;
+is_deeply [can_write_dir($dne)],
+ [1,
+ FS->curdir,
+ FS->catdir('does'),
+ FS->catdir('does', 'not'),
+ FS->catdir('does', 'not', 'exist')
+ ];
+
+
+my $abs_dne = FS->rel2abs($dne);
+ok ! -e $abs_dne;
+is_deeply [can_write_dir($abs_dne)],
+ [1,
+ FS->rel2abs(FS->curdir),
+ FS->rel2abs(FS->catdir('does')),
+ FS->rel2abs(FS->catdir('does', 'not')),
+ FS->rel2abs(FS->catdir('does', 'not', 'exist')),
+ ];
+
+SKIP: {
+ my $exists = FS->catdir(qw(exists));
+ my $subdir = FS->catdir(qw(exists subdir));
+
+
+ ok mkdir $exists;
+ END { rmdir $exists }
+
+ ok chmod 0555, $exists, 'make read only';
+
+ skip "Current user or OS cannot create directories that they cannot read",
6
+ if -w $exists; # these tests require a directory we cant read
+
+ is_deeply [can_write_dir($exists)], [0, $exists];
+ is_deeply [can_write_dir($subdir)], [0, $exists, $subdir];
+
+ ok chmod 0777, $exists, 'make writable';
+ ok -w $exists;
+ is_deeply [can_write_dir($exists)], [1, $exists];
+ is_deeply [can_write_dir($subdir)],
+ [1,
+ $exists,
+ $subdir
+ ];
+}
\ No newline at end of file
==== //depot/maint-5.10/perl/pod/perlport.pod#3 (text) ====
Index: perl/pod/perlport.pod
--- perl/pod/perlport.pod#2~33123~ 2008-01-30 03:45:08.000000000 -0800
+++ perl/pod/perlport.pod 2008-03-26 05:45:28.000000000 -0700
@@ -1580,6 +1580,11 @@
and applications are executable, and there are no uid/gid
considerations. C<-o> is not supported. (S<Mac OS>)
+C<-w> only inspects the read-only file attribute (FILE_ATTRIBUTE_READONLY),
+which determines whether the directory can be deleted, not whether it can
+be written to. Directories always have read and write access unless denied
+by discretionary access control lists (DACLs). (S<Win32>)
+
C<-r>, C<-w>, C<-x>, and C<-o> tell whether the file is accessible,
which may not reflect UIC-based file protections. (VMS)
==== //depot/maint-5.10/perl/pod/perltodo.pod#4 (text) ====
Index: perl/pod/perltodo.pod
--- perl/pod/perltodo.pod#3~33123~ 2008-01-30 03:45:08.000000000 -0800
+++ perl/pod/perltodo.pod 2008-03-26 05:45:28.000000000 -0700
@@ -484,6 +484,31 @@
might be nice to do as Microsoft suggest here too, although, unlike the secure
functions issue, there is presumably little or no benefit in this case.
+=head2 Fix POSIX::access() and chdir() on Win32
+
+These functions currently take no account of DACLs and therefore do not behave
+correctly in situations where access is restricted by DACLs (as opposed to the
+read-only attribute).
+
+Furthermore, POSIX::access() behaves differently for directories having the
+read-only attribute set depending on what CRT library is being used. For
+example, the _access() function in the VC6 and VC7 CRTs (wrongly) claim that
+such directories are not writable, whereas in fact all directories are writable
+unless access is denied by DACLs. (In the case of directories, the read-only
+attribute actually only means that the directory cannot be deleted.) This CRT
+bug is fixed in the VC8 and VC9 CRTs (but, of course, the directory may still
+not actually be writable if access is indeed denied by DACLs).
+
+For the chdir() issue, see ActiveState bug #74552:
+http://bugs.activestate.com/show_bug.cgi?id=74552
+
+Therefore, DACLs should be checked both for consistency across CRTs and for
+the correct answer.
+
+(Note that perl's -w operator should not be modified to check DACLs. It has
+been written so that it reflects the state of the read-only attribute, even
+for directories (whatever CRT is being used), for symmetry with chmod().)
+
=head2 strcat(), strcpy(), strncat(), strncpy(), sprintf(), vsprintf()
Maybe create a utility that checks after each libperl.a creation that
==== //depot/maint-5.10/perl/win32/win32.c#3 (text) ====
Index: perl/win32/win32.c
--- perl/win32/win32.c#2~33121~ 2008-01-30 03:03:49.000000000 -0800
+++ perl/win32/win32.c 2008-03-26 05:45:28.000000000 -0700
@@ -1500,9 +1500,22 @@
errno = ENOTDIR;
return -1;
}
+ if (S_ISDIR(sbuf->st_mode)) {
+ /* Ensure the "write" bit is switched off in the mode for
+ * directories with the read-only attribute set. Borland (at least)
+ * switches it on for directories, which is technically correct
+ * (directories are indeed always writable unless denied by DACLs),
+ * but we want stat() and -w to reflect the state of the read-only
+ * attribute for symmetry with chmod(). */
+ DWORD r = GetFileAttributesA(path);
+ if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) {
+ sbuf->st_mode &= ~S_IWRITE;
+ }
+ }
#ifdef __BORLANDC__
- if (S_ISDIR(sbuf->st_mode))
- sbuf->st_mode |= S_IWRITE | S_IEXEC;
+ if (S_ISDIR(sbuf->st_mode)) {
+ sbuf->st_mode |= S_IEXEC;
+ }
else if (S_ISREG(sbuf->st_mode)) {
int perms;
if (l >= 4 && path[l-4] == '.') {
End of Patch.
