From: Steve Peters Date: Thu, 27 Apr 2006 18:06:12 +0000 (+0000) Subject: Upgrade to ExtUtils-Install-1.39 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3a465856879d8f5c62068f777bdbd4b60c7e7eb4;p=p5sagit%2Fp5-mst-13.2.git Upgrade to ExtUtils-Install-1.39 p4raw-id: //depot/perl@27983 --- diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index 80ec52c..65b728f 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -1,27 +1,17 @@ package ExtUtils::Install; - use 5.00503; -use vars qw(@ISA @EXPORT $VERSION); -$VERSION = '1.33_02'; +use strict; + +use vars qw(@ISA @EXPORT $VERSION $MUST_REBOOT %Config); +$VERSION = '1.39'; +$VERSION = eval $VERSION; use Exporter; use Carp (); use Config qw(%Config); + @ISA = ('Exporter'); @EXPORT = ('install','uninstall','pm_to_blib', 'install_default'); -$Is_VMS = $^O eq 'VMS'; -$Is_MacPerl = $^O eq 'MacOS'; - -my $Inc_uninstall_warn_handler; - -# install relative to here - -my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT}; - -use File::Spec; -my $Curdir = File::Spec->curdir; -my $Updir = File::Spec->updir; - =head1 NAME @@ -37,6 +27,31 @@ ExtUtils::Install - install files from here to there pm_to_blib({ 'lib/Foo/Bar.pm' => 'blib/lib/Foo/Bar.pm' }); +=cut + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MacPerl = $^O eq 'MacOS'; +my $Is_Win32 = $^O eq 'MSWin32'; +my $Is_cygwin = $^O eq 'cygwin'; +my $CanMoveAtBoot = ($Is_Win32 || $Is_cygwin); + +# *note* CanMoveAtBoot is only incidentally the same condition as below +# this needs not hold true in the future. +my $Has_Win32API_File = ($Is_Win32 || $Is_cygwin) + ? (eval {require Win32API::File; 1} || 0) + : 0; + + +my $Inc_uninstall_warn_handler; + +# install relative to here + +my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT}; + +use File::Spec; +my $Curdir = File::Spec->curdir; +my $Updir = File::Spec->updir; + =head1 DESCRIPTION @@ -47,6 +62,190 @@ Both install() and uninstall() are specific to the way ExtUtils::MakeMaker handles the installation and deinstallation of perl modules. They are not designed as general purpose tools. +On some operating systems such as Win32 installation may not be possible +until after a reboot has occured. This can have varying consequences: +removing an old DLL does not impact programs using the new one, but if +a new DLL cannot be installed properly until reboot then anything +depending on it must wait. The package variable + + $ExtUtils::Install::MUST_REBOOT + +is used to store this status. + +If this variable is true then such an operation has occured and +anything depending on this module cannot proceed until a reboot +has occured. + +If this value is defined but false then such an operation has +ocurred, but should not impact later operations. + +=begin _private + +=item _chmod($$;$) + +Wrapper to chmod() for debugging and error trapping. + +=end _private + +=cut + + +sub _chmod($$;$) { + my ( $mode, $item, $verbose )=@_; + $verbose ||= 0; + if (chmod $mode, $item) { + print "chmod($mode, $item)\n" if $verbose > 1; + } else { + my $err="$!"; + warn "Failed chmod($mode, $item): $err\n" + if -e $item; + } +} + +=begin _private + +=item _move_file_at_boot( $file, $target, $moan ) + +OS-Specific, Win32/Cygwin + +Schedules a file to be moved/renamed/deleted at next boot. +$file should be a filespec of an existing file +$target should be a ref to an array if the file is to be deleted +otherwise it should be a filespec for a rename. If the file is existing +it will be replaced. + +Sets $MUST_REBOOT to 0 to indicate a deletion operation has occured +and sets it to 1 to indicate that a move operation has been requested. + +returns 1 on success, on failure if $moan is false errors are fatal. +If $moan is true then returns 0 on error and warns instead of dies. + +=end _private + +=cut + + + +sub _move_file_at_boot { #XXX OS-SPECIFIC + my ( $file, $target, $moan )= @_; + Carp::confess("Panic: Can't _move_file_at_boot on this platform!") + unless $CanMoveAtBoot; + + my $descr= ref $target + ? "'$file' for deletion" + : "'$file' for installation as '$target'"; + + if ( ! $Has_Win32API_File ) { + my $msg=join "\n",'!' x 72, + ( $moan ? "WARNING:" : "ERROR:" ) + . " Cannot schedule $descr at reboot.", + "Try installing Win32API::File to allow operations on locked files", + "to be scheduled during reboot. Or try to perform the operation by", + "hand yourself. (You may need to close other perl processes first)", + '!' x 72,""; + if ( $moan ) { warn $msg } else { die $msg } + return 0; + } + my $opts= Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT(); + $opts= $opts | Win32API::File::MOVEFILE_REPLACE_EXISTING() + unless ref $target; + + _chmod( 0666, $file ); + _chmod( 0666, $target ) unless ref $target; + + if (Win32API::File::MoveFileEx( $file, $target, $opts )) { + $MUST_REBOOT ||= ref $target ? 0 : 1; + return 1; + } else { + my $msg=join "\n",'!' x 72, + ( $moan ? "WARNING:" : "ERROR:" ) + . "MoveFileEx $descr at reboot failed: $^E", + "You may try to perform the operation by hand yourself. ", + "(You may need to close other perl processes first).", + '!' x 72, ""; + if ( $moan ) { warn $msg } else { die $msg } + } + return 0; +} + + +=begin _private + +=item _unlink_or_rename( $file, $tryhard, $installing ) + +OS-Specific, Win32/Cygwin + +Tries to get a file out of the way by unlinking it or renaming it. On +some OS'es (Win32 based) DLL files can end up locked such that they can +be renamed but not deleted. Likewise sometimes a file can be locked such +that it cant even be renamed or changed except at reboot. To handle +these cases this routine finds a tempfile name that it can either rename +the file out of the way or use as a proxy for the install so that the +rename can happen later (at reboot). + + $file : the file to remove. + $tryhard : should advanced tricks be used for deletion + $installing : we are not merely deleting but we want to overwrite + +When $tryhard is not true if the unlink fails its fatal. When $tryhard +is true then the file is attempted to be renamed. The renamed file is +then scheduled for deletion. If the rename fails then $installing +governs what happens. If it is false the failure is fatal. If it is true +then an attempt is made to schedule installation at boot using a +temporary file to hold the new file. If this fails then a fatal error is +thrown, if it succeeds it returns the temporary file name (which will be +a derivative of the original in the same directory) so that the caller can +use it to install under. In all other cases of success returns $file. +On failure throws a fatal error. + +=end _private + +=cut + + + +sub _unlink_or_rename { #XXX OS-SPECIFIC + my ( $file, $tryhard, $installing )= @_; + + _chmod( 0666, $file ); + unlink $file + and return $file; + my $error="$!"; + + Carp::croak('!' x 72, "\n", + "ERROR: Cannot unlink '$file': $!\n", + '!' x 72, "\n") + unless $CanMoveAtBoot && $tryhard; + + my $tmp= "AAA"; + ++$tmp while -e "$file.$tmp"; + $tmp= "$file.$tmp"; + + warn "WARNING: Unable to unlink '$file': $error\n", + "Going to try to rename it to '$tmp'.\n"; + + if ( rename $file, $tmp ) { + warn "Rename succesful. Scheduling '$tmp'\nfor deletion at reboot.\n"; + # when $installing we can set $moan to true. + # IOW, if we cant delete the renamed file at reboot its + # not the end of the world. The other cases are more serious + # and need to be fatal. + _move_file_at_boot( $tmp, [], $installing ); + return $file; + } elsif ( $installing ) { + warn "WARNING: Rename failed: $!. Scheduling '$tmp'\nfor". + " installation as '$file' at reboot.\n"; + _move_file_at_boot( $tmp, $file ); + return $tmp; + } else { + Carp::croak('!' x 72, "\n", + "ERROR: Rename failed:$!\n", + "Cannot procede.\n", + '!' x 72, "\n"); + } + +} + =head2 Functions =over 4 @@ -54,7 +253,7 @@ perl modules. They are not designed as general purpose tools. =item B install(\%from_to); - install(\%from_to, $verbose, $dont_execute, $uninstall_shadows); + install(\%from_to, $verbose, $dont_execute, $uninstall_shadows, $skip); Copies each directory tree of %from_to to its corresponding value preserving timestamps and permissions. @@ -68,7 +267,8 @@ 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" +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. @@ -76,10 +276,82 @@ 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. + +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 -sub install { - my($from_to,$verbose,$nonono,$inc_uninstall) = @_; +# +# Handles the reading the skip file. +# +sub _get_install_skip { + my ( $skip, $verbose )= @_; + if ($ENV{EU_INSTALL_IGNORE_SKIP}) { + print "EU_INSTALL_IGNORE_SKIP is set, ignore skipfile settings\n" + if $verbose>2; + return []; + } + if ( ! defined $skip ) { + print "Looking for install skip list\n" + if $verbose>2; + for my $file ( 'INSTALL.SKIP', $ENV{EU_INSTALL_SITE_SKIPFILE} ) { + next unless $file; + print "\tChecking for $file\n" + if $verbose>2; + if (-e $file) { + $skip= $file; + last; + } + } + } + if ($skip && !ref $skip) { + print "Reading skip patterns from '$skip'.\n" + if $verbose; + if (open my $fh,$skip ) { + my @patterns; + while (<$fh>) { + chomp; + next if /^\s*(?:#|$)/; + print "\tSkip pattern: $_\n" if $verbose>3; + push @patterns, $_; + } + $skip= \@patterns; + } else { + warn "Can't read skip file:'$skip':$!\n"; + $skip=[]; + } + } elsif ( UNIVERSAL::isa($skip,'ARRAY') ) { + print "Using array for skip list\n" + if $verbose>2; + } elsif ($verbose) { + print "No skip list found.\n" + if $verbose>1; + $skip= []; + } + warn "Got @{[0+@$skip]} skip patterns.\n" + if $verbose>3; + return $skip +} + + +sub install { #XXX OS-SPECIFIC + my($from_to,$verbose,$nonono,$inc_uninstall,$skip) = @_; $verbose ||= 0; $nonono ||= 0; @@ -91,14 +363,13 @@ sub install { use File::Path qw(mkpath); use File::Compare qw(compare); - my $win32_special=!$nonono && - $^O eq 'MSWin32' && - eval { require Win32API::File; 1 }; + $skip= _get_install_skip($skip,$verbose); + my(%from_to) = %$from_to; my(%pack, $dir, $warn_permissions); my($packlist) = ExtUtils::Packlist->new(); # -w doesn't work reliably on FAT dirs - $warn_permissions++ if $^O eq 'MSWin32'; + $warn_permissions++ if $Is_Win32; #XXX OS-SPECIFIC local(*DIR); for (qw/read write/) { $pack{$_}=$from_to{$_}; @@ -148,17 +419,27 @@ sub install { } chdir $source or next; + find(sub { my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9]; - return unless -f _; + return if !-f _; my $origfile = $_; + return if $origfile eq ".exists"; my $targetdir = File::Spec->catdir($targetroot, $File::Find::dir); my $targetfile = File::Spec->catfile($targetdir, $origfile); my $sourcedir = File::Spec->catdir($source, $File::Find::dir); my $sourcefile = File::Spec->catfile($sourcedir, $origfile); + for my $pat (@$skip) { + if ( $sourcefile=~/$pat/ ) { + print "Skipping $targetfile (filtered)\n" + if $verbose>1; + return; + } + } + my $save_cwd = cwd; chdir $cwd; # in case the target is relative # 5.5.3's File::Find missing no_chdir option. @@ -168,51 +449,39 @@ sub install { # We have a good chance, we can skip this one $diff = compare($sourcefile, $targetfile); } else { - print "$sourcefile differs\n" if $verbose>1; $diff++; } - + print "$sourcefile differs\n" if $diff && $verbose>1; + my $realtarget= $targetfile; if ($diff) { - if ($win32_special && -f $targetfile && !unlink $targetfile) { - print "Can't remove existing '$targetfile': $!\n"; - my $tmp = "AAA"; - ++$tmp while -e "$targetfile.$tmp"; - $tmp= "$targetfile.$tmp"; - if ( rename $targetfile, $tmp ) { - print "However it has been renamed as '$tmp' which ". - "will be removed at next reboot.\n"; - Win32API::File::MoveFileEx( $tmp, [], - Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT() ) - or die "MoveFileEx/Delete '$tmp' failed: $^E\n"; - } else { - print "Installation cannot be completed until you reboot.\n", - "Until then using '$tmp' as the install filename.\n"; - Win32API::File::MoveFileEx( $tmp, $targetfile, - Win32API::File::MOVEFILE_REPLACE_EXISTING() | - Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT() ) - or die "MoveFileEx/Replace '$tmp' failed: $^E\n"; - $targetfile = $tmp; - } - } elsif (-f $targetfile) { - forceunlink($targetfile) unless $nonono; + if (-f $targetfile) { + print "_unlink_or_rename($targetfile)\n" if $verbose>1; + $targetfile= _unlink_or_rename( $targetfile, 'tryhard', 'install' ) + unless $nonono; } else { mkpath($targetdir,0,0755) unless $nonono; print "mkpath($targetdir,0,0755)\n" if $verbose>1; } copy($sourcefile, $targetfile) unless $nonono; print "Installing $targetfile\n"; + #XXX OS-SPECIFIC utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1; print "utime($atime,$mtime,$targetfile)\n" if $verbose>1; - $mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); - chmod $mode, $targetfile; - print "chmod($mode, $targetfile)\n" if $verbose>1; + + $mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); + $mode = $mode | 0222 + if $realtarget ne $targetfile; + _chmod( $mode, $targetfile, $verbose ); + + } else { print "Skipping $targetfile (unchanged)\n" if $verbose; } - if (defined $inc_uninstall) { - inc_uninstall($sourcefile,$File::Find::dir,$verbose, - $inc_uninstall ? 0 : 1); + if ( defined $inc_uninstall ) { + inc_uninstall($sourcefile,$File::Find::dir,$verbose, + $inc_uninstall ? 0 : 1, + $realtarget ne $targetfile ? $realtarget : ""); } # Record the full pathname. @@ -222,17 +491,64 @@ sub install { chdir $save_cwd; # File::Find seems to always be Unixy except on MacPerl :( - }, $Is_MacPerl ? $Curdir : '.' ); + }, $Is_MacPerl ? $Curdir : '.' ); #XXX OS-SPECIFIC chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!"); } + if ($pack{'write'}) { $dir = install_rooted_dir(dirname($pack{'write'})); mkpath($dir,0,0755) unless $nonono; print "Writing $pack{'write'}\n"; $packlist->write(install_rooted_file($pack{'write'})) unless $nonono; } + + _do_cleanup($verbose); +} + +=begin _private + +=item _do_cleanup + +Standardize finish event for after another instruction has occured. +Handles converting $MUST_REBOOT to a die for instance. + +=end _private + +=cut + +sub _do_cleanup { + my ($verbose) = @_; + if ($MUST_REBOOT) { + die + '!' x 72, "\n", + "Operation not completed: ", + "Please reboot to complete the Installation.\n", + '!' x 72, "\n", + ; + } elsif (defined $MUST_REBOOT & $verbose) { + warn '-' x 72, "\n", + "Installation will be completed at the next reboot.\n", + "However it is not necessary to reboot immediately.\n"; + } } +=begin _undocumented + +=item install_rooted_file( $file ) + +Returns $file, or catfile($INSTALL_ROOT,$file) if $INSTALL_ROOT +is defined. + +=item install_rooted_dir( $dir ) + +Returns $dir, or catdir($INSTALL_ROOT,$dir) if $INSTALL_ROOT +is defined. + +=end _undocumented + +=cut + + sub install_rooted_file { if (defined $INSTALL_ROOT) { File::Spec->catfile($INSTALL_ROOT, $_[0]); @@ -250,12 +566,35 @@ sub install_rooted_dir { } } +=begin _undocumented + +=item 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 +Win32 in that it will try to use Win32API::File to schedule a delete at +reboot. A wrapper for _unlink_or_rename(). + +=end _undocumented + +=cut + sub forceunlink { - chmod 0666, $_[0]; - unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!") + my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC + _unlink_or_rename( $file, $tryhard ); } +=begin _undocumented + +=item directory_not_empty( $dir ) + +Returns 1 if there is an .exists file somewhere in a directory tree. +Returns 0 if there is not. + +=end _undocumented + +=cut sub directory_not_empty ($) { my($dir) = @_; @@ -345,28 +684,43 @@ sub uninstall { foreach (sort(keys(%$packlist))) { chomp; print "unlink $_\n" if $verbose; - forceunlink($_) unless $nonono; + forceunlink($_,'tryhard') unless $nonono; } print "unlink $fil\n" if $verbose; - forceunlink($fil) unless $nonono; + forceunlink($fil, 'tryhard') unless $nonono; + _do_cleanup($verbose); } +=begin _undocumented + +=item inc_uninstall($filepath,$libdir,$verbose,$nonono,$ignore) + +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. + +=end _undocumented + +=cut + sub inc_uninstall { - my($filepath,$libdir,$verbose,$nonono) = @_; + my($filepath,$libdir,$verbose,$nonono,$ignore) = @_; my($dir); + $ignore||=""; my $file = (File::Spec->splitpath($filepath))[2]; my %seen_dir = (); - my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'} + 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)}) { - next if $dir eq $Curdir; - next if $seen_dir{$dir}++; - my($targetfile) = File::Spec->catfile($dir,$libdir,$file); + my $canonpath = File::Spec->canonpath($dir); + next if $canonpath eq $Curdir; + next if $seen_dir{$canonpath}++; + my $targetfile = File::Spec->catfile($canonpath,$libdir,$file); next unless -f $targetfile; # The reason why we compare file's contents is, that we cannot @@ -377,14 +731,14 @@ sub inc_uninstall { # We have a good chance, we can skip this one $diff = compare($filepath,$targetfile); } else { - print "#$file and $targetfile differ\n" if $verbose>1; $diff++; } + print "#$file and $targetfile differ\n" if $diff && $verbose > 1; - next unless $diff; + next if !$diff or $targetfile eq $ignore; if ($nonono) { if ($verbose) { - $Inc_uninstall_warn_handler ||= new ExtUtils::Install::Warn; + $Inc_uninstall_warn_handler ||= ExtUtils::Install::Warn->new(); $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier. $Inc_uninstall_warn_handler->add( File::Spec->catfile($libdir, $file), @@ -394,11 +748,21 @@ sub inc_uninstall { # if not verbose, we just say nothing } else { print "Unlinking $targetfile (shadowing?)\n"; - forceunlink($targetfile); + forceunlink($targetfile,'tryhard'); } } } +=begin _undocumented + +=item run_filter($cmd,$src,$dest) + +Filter $src using $cmd into $dest. + +=end _undocumented + +=cut + sub run_filter { my ($cmd, $src, $dest) = @_; local(*CMD, *SRC); @@ -453,7 +817,7 @@ sub pm_to_blib { # the comparison check when there's no filter to be ran. # -- RAM, 03/01/2001 - my $need_filtering = defined $pm_filter && length $pm_filter && + my $need_filtering = defined $pm_filter && length $pm_filter && $from =~ /\.pm$/; if (!$need_filtering && 0 == compare($from,$to)) { @@ -461,6 +825,7 @@ sub pm_to_blib { next; } if (-f $to){ + # we wont try hard here. its too likely to mess things up. forceunlink($to); } else { mkpath(dirname($to),0,0755); @@ -474,7 +839,7 @@ sub pm_to_blib { } my($mode,$atime,$mtime) = (stat $from)[2,8,9]; utime($atime,$mtime+$Is_VMS,$to); - chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to); + _chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to); next unless $from =~ /\.pm$/; _autosplit($to,$autodir); } @@ -493,7 +858,7 @@ locking (ie. Windows). So we wrap it and close the filehandle. =cut -sub _autosplit { +sub _autosplit { #XXX OS-SPECIFIC my $retval = autosplit(@_); close *AutoSplit::IN if defined *AutoSplit::IN{IO}; @@ -523,12 +888,44 @@ sub DESTROY { } } $plural = $i>1 ? "all those files" : "this file"; - print "## Running 'make install UNINST=1' will unlink $plural for you.\n"; + my $inst = (_invokant() eq 'ExtUtils::MakeMaker') + ? ( $Config::Config{make} || 'make' ).' install UNINST=1' + : './Build install uninst=1'; + print "## Running '$inst' will unlink $plural for you.\n"; } } -=back +=begin _private + +=item _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 +or by ExtUtils::MakeMaker. + +=end _private + +=cut + +sub _invokant { + my @stack; + my $frame = 0; + while (my $file = (caller($frame++))[1]) { + push @stack, (File::Spec->splitpath($file))[2]; + } + + my $builder; + my $top = pop @stack; + if ($top =~ /^Build/i || exists($INC{'Module/Build.pm'})) { + $builder = 'Module::Build'; + } else { + $builder = 'ExtUtils::MakeMaker'; + } + return $builder; +} + +=back =head1 ENVIRONMENT @@ -538,25 +935,29 @@ sub DESTROY { Will be prepended to each install path. +=item B + +Will prevent the automatic use of INSTALL.SKIP as the install skip file. + +=item B + +If there is no INSTALL.SKIP file in the make directory then this value +can be used to provide a default. + =back =head1 AUTHOR Original author lost in the mists of time. Probably the same as Makemaker. -Currently maintained by Michael G Schwern C - -Send patches and ideas to C. +Production release currently maintained by demerphq C Send bug reports via http://rt.cpan.org/. Please send your generated Makefile along with your report. -For more up-to-date information, see L. - - =head1 LICENSE -This program is free software; you can redistribute it and/or +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L diff --git a/lib/ExtUtils/Installed.pm b/lib/ExtUtils/Installed.pm index d1faaa2..d5cffb6 100644 --- a/lib/ExtUtils/Installed.pm +++ b/lib/ExtUtils/Installed.pm @@ -16,7 +16,8 @@ my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/); require VMS::Filespec if $Is_VMS; use vars qw($VERSION); -$VERSION = '0.08_01'; +$VERSION = '1.38'; +$VERSION = eval $VERSION; sub _is_prefix { my ($self, $path, $prefix) = @_; @@ -41,7 +42,7 @@ sub _is_prefix { return(0); } -sub _is_doc { +sub _is_doc { my ($self, $path) = @_; my $man1dir = $Config{man1direxp}; my $man3dir = $Config{man3direxp}; @@ -50,7 +51,7 @@ sub _is_doc { ($man3dir && $self->_is_prefix($path, $man3dir)) ? 1 : 0) } - + sub _is_type { my ($self, $path, $type) = @_; return 1 if $type eq "all"; @@ -127,7 +128,7 @@ sub new { } # Read the .packlist - $self->{$module}{packlist} = + $self->{$module}{packlist} = ExtUtils::Packlist->new($File::Find::name); }; @@ -186,7 +187,7 @@ sub files { my (@files); foreach my $file (keys(%{$self->{$module}{packlist}})) { push(@files, $file) - if ($self->_is_type($file, $type) && + if ($self->_is_type($file, $type) && $self->_is_under($file, @under)); } return(@files); diff --git a/lib/ExtUtils/Packlist.pm b/lib/ExtUtils/Packlist.pm index 91df1a3..6fdf184 100644 --- a/lib/ExtUtils/Packlist.pm +++ b/lib/ExtUtils/Packlist.pm @@ -4,11 +4,22 @@ use 5.00503; use strict; use Carp qw(); use vars qw($VERSION); -$VERSION = '0.04_01'; +$VERSION = '1.38'; +$VERSION = eval $VERSION; # Used for generating filehandle globs. IO::File might not be available! my $fhname = "FH1"; +=begin _undocumented + +=item mkfh() + +Make a filehandle. Same kind of idea as Symbol::gensym(). + +=end _undocumented + +=cut + sub mkfh() { no strict; diff --git a/lib/ExtUtils/t/Install.t b/lib/ExtUtils/t/Install.t index 6058811..dacc3fb 100644 --- a/lib/ExtUtils/t/Install.t +++ b/lib/ExtUtils/t/Install.t @@ -17,7 +17,7 @@ use TieOut; use File::Path; use File::Spec; -use Test::More tests => 32; +use Test::More tests => 33; use MakeMaker::Test::Setup::BFD; @@ -72,13 +72,14 @@ install( { 'blib/lib' => 'install-test/lib/perl', } ); 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) } ; close PACKLIST; -# On case-insensitive filesystems (ie. VMS), the keys of the packlist might +# 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 ); diff --git a/lib/ExtUtils/t/Installed.t b/lib/ExtUtils/t/Installed.t index ba35deb..c18e8b0 100644 --- a/lib/ExtUtils/t/Installed.t +++ b/lib/ExtUtils/t/Installed.t @@ -53,7 +53,7 @@ foreach my $path (qw( man1dir man3dir )) { # VMS 5.6.1 doesn't seem to have $Config{prefixexp} my $prefix = $Config{prefix} || $Config{prefixexp}; -# You can concatenate /foo but not foo:, which defaults in the current +# You can concatenate /foo but not foo:, which defaults in the current # directory $prefix = VMS::Filespec::unixify($prefix) if $Is_VMS; @@ -65,7 +65,7 @@ ok( $ei->_is_type( File::Spec->catfile($prefix, 'bar'), 'prog'), SKIP: { skip('no man directories on this system', 1) unless $mandirs; - is( $ei->_is_type('bar', 'doc'), 0, + is( $ei->_is_type('bar', 'doc'), 0, '... should not find doc file outside path' ); } @@ -116,31 +116,31 @@ close FAKEMOD; my $realei = ExtUtils::Installed->new(); isa_ok( $realei, 'ExtUtils::Installed' ); isa_ok( $realei->{Perl}{packlist}, 'ExtUtils::Packlist' ); - is( $realei->{Perl}{version}, $Config{version}, + is( $realei->{Perl}{version}, $Config{version}, 'new() should set Perl version from %Config' ); ok( exists $realei->{FakeMod}, 'new() should find modules with .packlists'); isa_ok( $realei->{FakeMod}{packlist}, 'ExtUtils::Packlist' ); - is( $realei->{FakeMod}{version}, '1.1.1', + is( $realei->{FakeMod}{version}, '1.1.1', '... should find version in modules' ); } # modules $ei->{$_} = 1 for qw( abc def ghi ); -is( join(' ', $ei->modules()), 'abc def ghi', +is( join(' ', $ei->modules()), 'abc def ghi', 'modules() should return sorted keys' ); # This didn't work for a long time due to a sort in scalar context oddity. is( $ei->modules, 3, 'modules() in scalar context' ); # files -$ei->{goodmod} = { - packlist => { - ($Config{man1direxp} ? - (File::Spec->catdir($Config{man1direxp}, 'foo') => 1) : +$ei->{goodmod} = { + packlist => { + ($Config{man1direxp} ? + (File::Spec->catdir($Config{man1direxp}, 'foo') => 1) : ()), - ($Config{man3direxp} ? - (File::Spec->catdir($Config{man3direxp}, 'bar') => 1) : + ($Config{man3direxp} ? + (File::Spec->catdir($Config{man3direxp}, 'bar') => 1) : ()), File::Spec->catdir($prefix, 'foobar') => 1, foobaz => 1, @@ -154,8 +154,8 @@ like( $@, qr/type must be/,'files() should croak given bad type' ); my @files; SKIP: { - skip('no man directory man1dir on this system', 2) - unless $Config{man1direxp}; + skip('no man directory man1dir on this system', 2) + unless $Config{man1direxp}; @files = $ei->files('goodmod', 'doc', $Config{man1direxp}); is( scalar @files, 1, '... should find doc file under given dir' ); is( (grep { /foo$/ } @files), 1, '... checking file name' ); @@ -190,22 +190,22 @@ is( scalar @dirs, 2 + $mandirs, '... should find all files files() would, again' is( join(' ', @files), join(' ', @dirs), '... should sort output' ); # directory_tree -my $expectdirs = - ($mandirs == 2) && +my $expectdirs = + ($mandirs == 2) && (dirname($Config{man1direxp}) eq dirname($Config{man3direxp})) ? 3 : 2; - + SKIP: { skip('no man directories on this system', 1) unless $mandirs; @dirs = $ei->directory_tree('goodmod', 'doc', $Config{man1direxp} ? dirname($Config{man1direxp}) : dirname($Config{man3direxp})); - is( scalar @dirs, $expectdirs, + is( scalar @dirs, $expectdirs, 'directory_tree() should report intermediate dirs to those requested' ); } my $fakepak = Fakepak->new(102); -$ei->{yesmod} = { +$ei->{yesmod} = { version => 101, packlist => $fakepak, }; @@ -213,20 +213,20 @@ $ei->{yesmod} = { # these should all croak foreach my $sub (qw( validate packlist version )) { eval { $ei->$sub('nomod') }; - like( $@, qr/nomod is not installed/, + like( $@, qr/nomod is not installed/, "$sub() should croak when asked about uninstalled module" ); } # validate -is( $ei->validate('yesmod'), 'validated', +is( $ei->validate('yesmod'), 'validated', 'validate() should return results of packlist validate() call' ); # packlist -is( ${ $ei->packlist('yesmod') }, 102, +is( ${ $ei->packlist('yesmod') }, 102, 'packlist() should report installed mod packlist' ); # version -is( $ei->version('yesmod'), 101, +is( $ei->version('yesmod'), 101, 'version() should report installed mod version' ); diff --git a/lib/ExtUtils/t/Packlist.t b/lib/ExtUtils/t/Packlist.t index 58eaf8f..cb73e00 100644 --- a/lib/ExtUtils/t/Packlist.t +++ b/lib/ExtUtils/t/Packlist.t @@ -39,7 +39,7 @@ is( ExtUtils::Packlist::FETCH($pl, 'foo'), 'bar', 'check FETCH()' ); # test FIRSTKEY and NEXTKEY SKIP: { $pl->{data}{bar} = 'baz'; - skip('not enough keys to test FIRSTKEY', 2) + skip('not enough keys to test FIRSTKEY', 2) unless keys %{ $pl->{data} } > 2; # get the first and second key @@ -50,9 +50,9 @@ SKIP: { for (keys %{ $pl->{data} } ) { last if $i++; } - + # finally, see if it really can get the first key again - is( ExtUtils::Packlist::FIRSTKEY($pl), $first, + is( ExtUtils::Packlist::FIRSTKEY($pl), $first, 'FIRSTKEY() should be consistent' ); is( ExtUtils::Packlist::NEXTKEY($pl), $second, @@ -155,9 +155,9 @@ SKIP: { is( ExtUtils::Packlist::validate($pl), 1, 'validate() should find missing files' ); ExtUtils::Packlist::validate($pl, 1); - ok( !exists $pl->{data}{fake}, + ok( !exists $pl->{data}{fake}, 'validate() should remove missing files when prompted' ); - + # one more new() test, to see if it calls read() successfully $pl = ExtUtils::Packlist->new('eplist'); }