This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update ExtUtils-Install to CPAN version 2.20
authorChris 'BinGOs' Williams <chris@bingosnet.co.uk>
Fri, 18 Dec 2020 12:54:10 +0000 (12:54 +0000)
committerChris 'BinGOs' Williams <chris@bingosnet.co.uk>
Fri, 18 Dec 2020 12:54:10 +0000 (12:54 +0000)
  [DELTA]

2.20

- Exercise _is_prefix() method more in tests
- Optimisations for file comparisons
- Optimisations for directory creation
- Typo fix in POD
- Optimisations for tree traversal

Porting/Maintainers.pl
cpan/ExtUtils-Install/lib/ExtUtils/Install.pm
cpan/ExtUtils-Install/lib/ExtUtils/Installed.pm
cpan/ExtUtils-Install/lib/ExtUtils/Packlist.pm
cpan/ExtUtils-Install/t/Installed.t

index d8d2294..32b4c23 100755 (executable)
@@ -453,7 +453,7 @@ use File::Glob qw(:case);
     },
 
     'ExtUtils::Install' => {
-        'DISTRIBUTION' => 'BINGOS/ExtUtils-Install-2.18.tar.gz',
+        'DISTRIBUTION' => 'BINGOS/ExtUtils-Install-2.20.tar.gz',
         'FILES'        => q[cpan/ExtUtils-Install],
         'EXCLUDED'     => [
             qw( t/lib/Test/Builder.pm
index 2fb43bc..9608180 100644 (file)
@@ -32,11 +32,11 @@ ExtUtils::Install - install files from here to there
 
 =head1 VERSION
 
-2.18
+2.20
 
 =cut
 
-our $VERSION = '2.18';  # <-- do not forget to update the POD section just above this line!
+our $VERSION = '2.20';  # <-- do not forget to update the POD section just above this line!
 $VERSION = eval $VERSION;
 
 =pod
@@ -65,26 +65,22 @@ anything depending on this module cannot proceed until a reboot
 has occurred.
 
 If this value is defined but false then such an operation has
-ocurred, but should not impact later operations.
-
-=over
+occurred, but should not impact later operations.
 
 =begin _private
 
-=item _chmod($$;$)
+=head2 _chmod($$;$)
 
 Wrapper to chmod() for debugging and error trapping.
 
-=item _warnonce(@)
+=head2 _warnonce(@)
 
 Warns about something only once.
 
-=item _choke(@)
+=head2 _choke(@)
 
 Dies with a special message.
 
-=back
-
 =end _private
 
 =cut
@@ -137,8 +133,12 @@ sub _confess {
 }
 
 sub _compare {
-    require File::Compare;
-    File::Compare::compare(@_);
+    # avoid loading File::Compare in the common case
+    if (-f $_[1] && -s _ == -s $_[0]) {
+        require File::Compare;
+        return File::Compare::compare(@_);
+    }
+    return 1;
 }
 
 
@@ -157,9 +157,7 @@ sub _chmod($$;$) {
 
 =begin _private
 
-=over
-
-=item _move_file_at_boot( $file, $target, $moan  )
+=head2 _move_file_at_boot( $file, $target, $moan  )
 
 OS-Specific, Win32/Cygwin
 
@@ -231,8 +229,7 @@ If $moan is true then returns 0 on error and warns instead of dies.
 
 =begin _private
 
-
-=item _unlink_or_rename( $file, $tryhard, $installing )
+=head2 _unlink_or_rename( $file, $tryhard, $installing )
 
 OS-Specific, Win32/Cygwin
 
@@ -263,8 +260,6 @@ On failure throws a fatal error.
 
 =cut
 
-
-
 sub _unlink_or_rename { #XXX OS-SPECIFIC
     my ( $file, $tryhard, $installing )= @_;
 
@@ -310,25 +305,16 @@ sub _unlink_or_rename { #XXX OS-SPECIFIC
 
 }
 
-
-=pod
-
-=back
-
-=head2 Functions
+=head1 Functions
 
 =begin _private
 
-=over
-
-=item _get_install_skip
+=head2 _get_install_skip
 
 Handles loading the INSTALL.SKIP file. Returns an array of patterns to use.
 
 =cut
 
-
-
 sub _get_install_skip {
     my ( $skip, $verbose )= @_;
     if ($ENV{EU_INSTALL_IGNORE_SKIP}) {
@@ -378,9 +364,7 @@ sub _get_install_skip {
     return $skip
 }
 
-=pod
-
-=item _have_write_access
+=head2 _have_write_access
 
 Abstract a -w check that tries to use POSIX::access() if possible.
 
@@ -402,9 +386,7 @@ Abstract a -w check that tries to use POSIX::access() if possible.
     }
 }
 
-=pod
-
-=item _can_write_dir(C<$dir>)
+=head2 _can_write_dir(C<$dir>)
 
 Checks whether a given directory is writable, taking account
 the possibility that the directory might not exist and would have to
@@ -423,7 +405,6 @@ relative paths with C<..> in them. But for our purposes it should work ok
 
 =cut
 
-
 sub _can_write_dir {
     my $dir=shift;
     return
@@ -461,9 +442,7 @@ sub _can_write_dir {
     return 0;
 }
 
-=pod
-
-=item _mkpath($dir,$show,$mode,$verbose,$dry_run)
+=head2 _mkpath($dir,$show,$mode,$verbose,$dry_run)
 
 Wrapper around File::Path::mkpath() to handle errors.
 
@@ -486,10 +465,16 @@ sub _mkpath {
         printf "mkpath(%s,%d,%#o)\n", $dir, $show, $mode;
     }
     if (!$dry_run) {
-        if ( ! eval { File::Path::mkpath($dir,$show,$mode); 1 } ) {
-            _choke("Can't create '$dir'","$@");
+        my @created;
+        eval {
+            @created = File::Path::mkpath($dir,$show,$mode);
+            1;
+        } or _choke("Can't create '$dir'","$@");
+        # if we created any directories, we were able to write and don't need
+        # extra checks
+        if (@created) {
+            return;
         }
-
     }
     my ($can,$root,@make)=_can_write_dir($dir);
     if (!$can) {
@@ -509,9 +494,7 @@ sub _mkpath {
 
 }
 
-=pod
-
-=item _copy($from,$to,$verbose,$dry_run)
+=head2 _copy($from,$to,$verbose,$dry_run)
 
 Wrapper around File::Copy::copy to handle errors.
 
@@ -523,7 +506,6 @@ Dies if the copy fails.
 
 =cut
 
-
 sub _copy {
     my ( $from, $to, $verbose, $dry_run)=@_;
     if ($verbose && $verbose>1) {
@@ -537,7 +519,7 @@ sub _copy {
 
 =pod
 
-=item _chdir($from)
+=head2 _chdir($from)
 
 Wrapper around chdir to catch errors.
 
@@ -558,15 +540,9 @@ sub _chdir {
     return $ret;
 }
 
-=pod
-
-=back
-
 =end _private
 
-=over
-
-=item B<install>
+=head2 install
 
     # deprecated forms
     install(\%from_to);
@@ -774,15 +750,9 @@ sub install { #XXX OS-SPECIFIC
             }
             # we have to do this for back compat with old File::Finds
             # and because the target is relative
-            my $save_cwd = _chdir($cwd);
-            my $diff = 0;
-            # 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);
-            }
+            my $save_cwd = File::Spec->catfile($cwd, $sourcedir);
+            _chdir($cwd);
+            my $diff = $always_copy || _compare($sourcefile, $targetfile);
             $check_dirs{$targetdir}++
                 unless -w $targetfile;
 
@@ -864,7 +834,7 @@ sub install { #XXX OS-SPECIFIC
 
 =begin _private
 
-=item _do_cleanup
+=head2 _do_cleanup
 
 Standardize finish event for after another instruction has occurred.
 Handles converting $MUST_REBOOT to a die for instance.
@@ -887,12 +857,12 @@ sub _do_cleanup {
 
 =begin _undocumented
 
-=item install_rooted_file( $file )
+=head2 install_rooted_file( $file )
 
 Returns $file, or catfile($INSTALL_ROOT,$file) if $INSTALL_ROOT
 is defined.
 
-=item install_rooted_dir( $dir )
+=head2 install_rooted_dir( $dir )
 
 Returns $dir, or catdir($INSTALL_ROOT,$dir) if $INSTALL_ROOT
 is defined.
@@ -901,7 +871,6 @@ is defined.
 
 =cut
 
-
 sub install_rooted_file {
     if (defined $INSTALL_ROOT) {
         File::Spec->catfile($INSTALL_ROOT, $_[0]);
@@ -921,7 +890,7 @@ sub install_rooted_dir {
 
 =begin _undocumented
 
-=item forceunlink( $file, $tryhard )
+=head2 forceunlink( $file, $tryhard )
 
 Tries to delete a file. If $tryhard is true then we will use whatever
 devious tricks we can to delete the file. Currently this only applies to
@@ -932,7 +901,6 @@ reboot. A wrapper for _unlink_or_rename().
 
 =cut
 
-
 sub forceunlink {
     my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC
     _unlink_or_rename( $file, $tryhard, not("installing") );
@@ -940,7 +908,7 @@ sub forceunlink {
 
 =begin _undocumented
 
-=item directory_not_empty( $dir )
+=head2 directory_not_empty( $dir )
 
 Returns 1 if there is an .exists file somewhere in a directory tree.
 Returns 0 if there is not.
@@ -963,9 +931,9 @@ sub directory_not_empty ($) {
   return $files;
 }
 
-=pod
+=head2 install_default
 
-=item B<install_default> I<DISCOURAGED>
+I<DISCOURAGED>
 
     install_default();
     install_default($fullext);
@@ -1019,7 +987,7 @@ sub install_default {
 }
 
 
-=item B<uninstall>
+=head2 uninstall
 
     uninstall($packlist_file);
     uninstall($packlist_file, $verbose, $dont_execute);
@@ -1057,7 +1025,7 @@ sub uninstall {
 
 =begin _undocumented
 
-=item inc_uninstall($filepath,$libdir,$verbose,$dry_run,$ignore,$results)
+=head2 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
@@ -1103,13 +1071,8 @@ sub inc_uninstall {
         # The reason why we compare file's contents is, that we cannot
         # know, which is the file we just installed (AFS). So we leave
         # an identical file in place
-        my $diff = 0;
-        if ( -f $targetfile && -s _ == -s $filepath) {
-            # We have a good chance, we can skip this one
-            $diff = _compare($filepath,$targetfile);
-        } else {
-            $diff++;
-        }
+        my $diff = _compare($filepath,$targetfile);
+
         print "#$file and $targetfile differ\n" if $diff && $verbose > 1;
 
         if (!$diff or $targetfile eq $ignore) {
@@ -1150,7 +1113,7 @@ sub inc_uninstall {
 
 =begin _undocumented
 
-=item run_filter($cmd,$src,$dest)
+=head2 run_filter($cmd,$src,$dest)
 
 Filter $src using $cmd into $dest.
 
@@ -1172,9 +1135,7 @@ sub run_filter {
     close CMD or die "Filter command '$cmd' failed for $src";
 }
 
-=pod
-
-=item B<pm_to_blib>
+=head2 pm_to_blib
 
     pm_to_blib(\%from_to);
     pm_to_blib(\%from_to, $autosplit_dir);
@@ -1199,6 +1160,7 @@ environment variable will silence this output.
 sub pm_to_blib {
     my($fromto,$autodir,$pm_filter) = @_;
 
+    my %dirs;
     _mkpath($autodir,0,0755) if defined $autodir;
     while(my($from, $to) = each %$fromto) {
         if( -f $to && -s $from == -s $to && -M $to < -M $from ) {
@@ -1214,7 +1176,7 @@ sub pm_to_blib {
         my $need_filtering = defined $pm_filter && length $pm_filter &&
                              $from =~ /\.pm$/;
 
-        if (!$need_filtering && 0 == _compare($from,$to)) {
+        if (!$need_filtering && !_compare($from,$to)) {
             print "Skip $to (unchanged)\n" unless $INSTALL_QUIET;
             next;
         }
@@ -1222,7 +1184,10 @@ sub pm_to_blib {
             # we wont try hard here. its too likely to mess things up.
             forceunlink($to);
         } else {
-            _mkpath(dirname($to),0,0755);
+            my $dirname = dirname($to);
+            if (!$dirs{$dirname}++) {
+                _mkpath($dirname,0,0755);
+            }
         }
         if ($need_filtering) {
             run_filter($pm_filter, $from, $to);
@@ -1239,10 +1204,9 @@ sub pm_to_blib {
     }
 }
 
-
 =begin _private
 
-=item _autosplit
+=head2 _autosplit
 
 From 1.0307 back, AutoSplit will sometimes leave an open filehandle to
 the file being split.  This causes problems on systems with mandatory
@@ -1293,7 +1257,7 @@ sub DESTROY {
 
 =begin _private
 
-=item _invokant
+=head2 _invokant
 
 Does a heuristic on the stack to see who called us for more intelligent
 error messages. Currently assumes we will be called only by Module::Build
@@ -1320,10 +1284,6 @@ sub _invokant {
     return $builder;
 }
 
-=pod
-
-=back
-
 =head1 ENVIRONMENT
 
 =over 4
index f12ea23..0cfd96b 100644 (file)
@@ -15,7 +15,7 @@ my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);
 
 require VMS::Filespec if $Is_VMS;
 
-our $VERSION = '2.18';
+our $VERSION = '2.20';
 $VERSION = eval $VERSION;
 
 sub _is_prefix {
index f975b41..98d09e3 100644 (file)
@@ -4,7 +4,7 @@ use strict;
 use Carp qw();
 use Config;
 our $Relocations;
-our $VERSION = '2.18';
+our $VERSION = '2.20';
 $VERSION = eval $VERSION;
 
 # Used for generating filehandle globs.  IO::File might not be available!
index 5cf7b80..7d7bf24 100644 (file)
@@ -18,7 +18,7 @@ use File::Basename;
 use File::Spec;
 use File::Temp qw[tempdir];
 
-use Test::More tests => 74;
+use Test::More tests => 76;
 
 BEGIN { use_ok( 'ExtUtils::Installed' ) }
 
@@ -36,6 +36,10 @@ ok( $ei->_is_prefix('foo/bar', 'foo'),
         '_is_prefix() should match valid path prefix' );
 ok( !$ei->_is_prefix('\foo\bar', '\bar'),
         '... should not match wrong prefix' );
+ok( ! defined $ei->_is_prefix( undef, 'foo' ),
+    '_is_prefix() needs two defined arguments' );
+ok( ! defined $ei->_is_prefix( 'foo/bar', undef ),
+    '_is_prefix() needs two defined arguments' );
 
 # _is_type
 ok( $ei->_is_type(0, 'all'), '_is_type() should be true for type of "all"' );