From e198ad16b8e9d759aac5600f4a4964317fd90b90 Mon Sep 17 00:00:00 2001 From: Florian Ragwitz Date: Tue, 9 Nov 2010 21:18:21 +0100 Subject: Move ExtUtils-Command from cpan/ to dist/ Randy Kobes passed away recently, so let's have p5p maintain it for now. --- MANIFEST | 8 +- Porting/Maintainers.pl | 6 +- cpan/ExtUtils-Command/lib/ExtUtils/Command.pm | 369 -------------------------- cpan/ExtUtils-Command/t/cp.t | 27 -- cpan/ExtUtils-Command/t/eu_command.t | 284 -------------------- cpan/ExtUtils-Command/t/lib/TieOut.pm | 28 -- dist/ExtUtils-Command/lib/ExtUtils/Command.pm | 368 +++++++++++++++++++++++++ dist/ExtUtils-Command/t/cp.t | 27 ++ dist/ExtUtils-Command/t/eu_command.t | 284 ++++++++++++++++++++ dist/ExtUtils-Command/t/lib/TieOut.pm | 28 ++ make_ext.pl | 2 +- t/TEST | 2 +- 12 files changed, 716 insertions(+), 717 deletions(-) delete mode 100644 cpan/ExtUtils-Command/lib/ExtUtils/Command.pm delete mode 100644 cpan/ExtUtils-Command/t/cp.t delete mode 100644 cpan/ExtUtils-Command/t/eu_command.t delete mode 100644 cpan/ExtUtils-Command/t/lib/TieOut.pm create mode 100644 dist/ExtUtils-Command/lib/ExtUtils/Command.pm create mode 100644 dist/ExtUtils-Command/t/cp.t create mode 100644 dist/ExtUtils-Command/t/eu_command.t create mode 100644 dist/ExtUtils-Command/t/lib/TieOut.pm diff --git a/MANIFEST b/MANIFEST index a28abe5744..1ea8e21f8c 100644 --- a/MANIFEST +++ b/MANIFEST @@ -876,10 +876,6 @@ cpan/ExtUtils-CBuilder/t/00-have-compiler.t ExtUtils::CBuilder tests cpan/ExtUtils-CBuilder/t/01-basic.t tests for ExtUtils::CBuilder cpan/ExtUtils-CBuilder/t/02-link.t tests for ExtUtils::CBuilder cpan/ExtUtils-CBuilder/t/03-cplusplus.t tests for ExtUtils::CBuilder -cpan/ExtUtils-Command/lib/ExtUtils/Command.pm Utilities for Make on non-UNIX platforms -cpan/ExtUtils-Command/t/cp.t See if ExtUtils::Command works -cpan/ExtUtils-Command/t/eu_command.t See if ExtUtils::Command works -cpan/ExtUtils-Command/t/lib/TieOut.pm Testing library to capture prints cpan/ExtUtils-Constant/lib/ExtUtils/Constant/Base.pm generate XS code to import C header constants cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm generate XS code to import C header constants cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm generate XS code for proxy constants @@ -2697,6 +2693,10 @@ dist/Data-Dumper/t/overload.t See if Data::Dumper works for overloaded data dist/Data-Dumper/t/pair.t See if Data::Dumper pair separator works dist/Data-Dumper/t/perl-74170.t Regression test for stack reallocation dist/Data-Dumper/t/terse.t See if Data::Dumper terse option works +dist/ExtUtils-Command/lib/ExtUtils/Command.pm Utilities for Make on non-UNIX platforms +dist/ExtUtils-Command/t/cp.t See if ExtUtils::Command works +dist/ExtUtils-Command/t/eu_command.t See if ExtUtils::Command works +dist/ExtUtils-Command/t/lib/TieOut.pm Testing library to capture prints dist/ExtUtils-Install/Changes ExtUtils-Install change log dist/ExtUtils-Install/lib/ExtUtils/Installed.pm Information on installed extensions dist/ExtUtils-Install/lib/ExtUtils/Install.pm Handles 'make install' on extensions diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 654ed6878e..3a954e717e 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -534,15 +534,15 @@ use File::Glob qw(:case); 'ExtUtils::Command' => { - 'MAINTAINER' => 'rkobes', + 'MAINTAINER' => 'p5p', 'DISTRIBUTION' => 'RKOBES/ExtUtils-Command-1.16.tar.gz', - 'FILES' => q[cpan/ExtUtils-Command], + 'FILES' => q[dist/ExtUtils-Command], 'EXCLUDED' => [ qw{ t/shell_command.t t/shell_exit.t lib/Shell/Command.pm }, ], - 'UPSTREAM' => undef, + 'UPSTREAM' => 'blead', }, 'ExtUtils::Constant' => diff --git a/cpan/ExtUtils-Command/lib/ExtUtils/Command.pm b/cpan/ExtUtils-Command/lib/ExtUtils/Command.pm deleted file mode 100644 index b5632ff06d..0000000000 --- a/cpan/ExtUtils-Command/lib/ExtUtils/Command.pm +++ /dev/null @@ -1,369 +0,0 @@ -package ExtUtils::Command; - -use 5.00503; -use strict; -use Carp; -use File::Copy; -use File::Compare; -use File::Basename; -use File::Path qw(rmtree); -require Exporter; -use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); -@ISA = qw(Exporter); -@EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod - dos2unix); -$VERSION = '1.16'; - -my $Is_VMS = $^O eq 'VMS'; -my $Is_VMS_mode = $Is_VMS; -my $Is_VMS_noefs = $Is_VMS; -my $Is_Win32 = $^O eq 'MSWin32'; - -if( $Is_VMS ) { - my $vms_unix_rpt; - my $vms_efs; - my $vms_case; - - if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { - $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); - $vms_efs = VMS::Feature::current("efs_charset"); - $vms_case = VMS::Feature::current("efs_case_preserve"); - } else { - my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; - my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; - my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; - $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; - $vms_efs = $efs_charset =~ /^[ET1]/i; - $vms_case = $efs_case =~ /^[ET1]/i; - } - $Is_VMS_mode = 0 if $vms_unix_rpt; - $Is_VMS_noefs = 0 if ($vms_efs); -} - - -=head1 NAME - -ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc. - -=head1 SYNOPSIS - - perl -MExtUtils::Command -e cat files... > destination - perl -MExtUtils::Command -e mv source... destination - perl -MExtUtils::Command -e cp source... destination - perl -MExtUtils::Command -e touch files... - perl -MExtUtils::Command -e rm_f files... - perl -MExtUtils::Command -e rm_rf directories... - perl -MExtUtils::Command -e mkpath directories... - perl -MExtUtils::Command -e eqtime source destination - perl -MExtUtils::Command -e test_f file - perl -MExtUtils::Command -e test_d directory - perl -MExtUtils::Command -e chmod mode files... - ... - -=head1 DESCRIPTION - -The module is used to replace common UNIX commands. In all cases the -functions work from @ARGV rather than taking arguments. This makes -them easier to deal with in Makefiles. Call them like this: - - perl -MExtUtils::Command -e some_command some files to work on - -and I like this: - - perl -MExtUtils::Command -e 'some_command qw(some files to work on)' - -For that use L. - -Filenames with * and ? will be glob expanded. - - -=head2 FUNCTIONS - -=over 4 - -=cut - -# VMS uses % instead of ? to mean "one character" -my $wild_regex = $Is_VMS ? '*%' : '*?'; -sub expand_wildcards -{ - @ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV); -} - - -=item cat - - cat file ... - -Concatenates all files mentioned on command line to STDOUT. - -=cut - -sub cat () -{ - expand_wildcards(); - print while (<>); -} - -=item eqtime - - eqtime source destination - -Sets modified time of destination to that of source. - -=cut - -sub eqtime -{ - my ($src,$dst) = @ARGV; - local @ARGV = ($dst); touch(); # in case $dst doesn't exist - utime((stat($src))[8,9],$dst); -} - -=item rm_rf - - rm_rf files or directories ... - -Removes files and directories - recursively (even if readonly) - -=cut - -sub rm_rf -{ - expand_wildcards(); - rmtree([grep -e $_,@ARGV],0,0); -} - -=item rm_f - - rm_f file ... - -Removes files (even if readonly) - -=cut - -sub rm_f { - expand_wildcards(); - - foreach my $file (@ARGV) { - next unless -f $file; - - next if _unlink($file); - - chmod(0777, $file); - - next if _unlink($file); - - carp "Cannot delete $file: $!"; - } -} - -sub _unlink { - my $files_unlinked = 0; - foreach my $file (@_) { - my $delete_count = 0; - $delete_count++ while unlink $file; - $files_unlinked++ if $delete_count; - } - return $files_unlinked; -} - - -=item touch - - touch file ... - -Makes files exist, with current timestamp - -=cut - -sub touch { - my $t = time; - expand_wildcards(); - foreach my $file (@ARGV) { - open(FILE,">>$file") || die "Cannot write $file:$!"; - close(FILE); - utime($t,$t,$file); - } -} - -=item mv - - mv source_file destination_file - mv source_file source_file destination_dir - -Moves source to destination. Multiple sources are allowed if -destination is an existing directory. - -Returns true if all moves succeeded, false otherwise. - -=cut - -sub mv { - expand_wildcards(); - my @src = @ARGV; - my $dst = pop @src; - - croak("Too many arguments") if (@src > 1 && ! -d $dst); - - my $nok = 0; - foreach my $src (@src) { - $nok ||= !move($src,$dst); - } - return !$nok; -} - -=item cp - - cp source_file destination_file - cp source_file source_file destination_dir - -Copies sources to the destination. Multiple sources are allowed if -destination is an existing directory. - -Returns true if all copies succeeded, false otherwise. - -=cut - -sub cp { - expand_wildcards(); - my @src = @ARGV; - my $dst = pop @src; - - croak("Too many arguments") if (@src > 1 && ! -d $dst); - - my $nok = 0; - foreach my $src (@src) { - $nok ||= !copy($src,$dst); - - # Win32 does not update the mod time of a copied file, just the - # created time which make does not look at. - utime(time, time, $dst) if $Is_Win32; - } - return $nok; -} - -=item chmod - - chmod mode files ... - -Sets UNIX like permissions 'mode' on all the files. e.g. 0666 - -=cut - -sub chmod { - local @ARGV = @ARGV; - my $mode = shift(@ARGV); - expand_wildcards(); - - if( $Is_VMS_mode && $Is_VMS_noefs) { - foreach my $idx (0..$#ARGV) { - my $path = $ARGV[$idx]; - next unless -d $path; - - # chmod 0777, [.foo.bar] doesn't work on VMS, you have to do - # chmod 0777, [.foo]bar.dir - my @dirs = File::Spec->splitdir( $path ); - $dirs[-1] .= '.dir'; - $path = File::Spec->catfile(@dirs); - - $ARGV[$idx] = $path; - } - } - - chmod(oct $mode,@ARGV) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!"; -} - -=item mkpath - - mkpath directory ... - -Creates directories, including any parent directories. - -=cut - -sub mkpath -{ - expand_wildcards(); - File::Path::mkpath([@ARGV],0,0777); -} - -=item test_f - - test_f file - -Tests if a file exists. I with 0 if it does, 1 if it does not (ie. -shell's idea of true and false). - -=cut - -sub test_f -{ - exit(-f $ARGV[0] ? 0 : 1); -} - -=item test_d - - test_d directory - -Tests if a directory exists. I with 0 if it does, 1 if it does -not (ie. shell's idea of true and false). - -=cut - -sub test_d -{ - exit(-d $ARGV[0] ? 0 : 1); -} - -=item dos2unix - - dos2unix files or dirs ... - -Converts DOS and OS/2 linefeeds to Unix style recursively. - -=cut - -sub dos2unix { - require File::Find; - File::Find::find(sub { - return if -d; - return unless -w _; - return unless -r _; - return if -B _; - - local $\; - - my $orig = $_; - my $temp = '.dos2unix_tmp'; - open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return }; - open TEMP, ">$temp" or - do { warn "dos2unix can't create .dos2unix_tmp: $!"; return }; - while (my $line = ) { - $line =~ s/\015\012/\012/g; - print TEMP $line; - } - close ORIG; - close TEMP; - rename $temp, $orig; - - }, @ARGV); -} - -=back - -=head1 SEE ALSO - -Shell::Command which is these same functions but take arguments normally. - - -=head1 AUTHOR - -Nick Ing-Simmons C - -Maintained by Michael G Schwern C within the -ExtUtils-MakeMaker package and, as a separate CPAN package, by -Randy Kobes C. - -=cut - diff --git a/cpan/ExtUtils-Command/t/cp.t b/cpan/ExtUtils-Command/t/cp.t deleted file mode 100644 index 0b899bf876..0000000000 --- a/cpan/ExtUtils-Command/t/cp.t +++ /dev/null @@ -1,27 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - unshift @INC, 't/lib/'; -} -chdir 't'; - -use ExtUtils::Command; -use Test::More tests => 1; - -open FILE, ">source" or die $!; -print FILE "stuff\n"; -close FILE; - -# Instead of sleeping to make the file time older -utime time - 900, time - 900, "source"; - -END { 1 while unlink "source", "dest"; } - -# Win32 bug, cp wouldn't update mtime. -{ - local @ARGV = qw(source dest); - cp(); - my $mtime = (stat("dest"))[9]; - my $now = time; - cmp_ok( abs($mtime - $now), '<=', 1, 'cp updated mtime' ); -} diff --git a/cpan/ExtUtils-Command/t/eu_command.t b/cpan/ExtUtils-Command/t/eu_command.t deleted file mode 100644 index 71ec8c2b5f..0000000000 --- a/cpan/ExtUtils-Command/t/eu_command.t +++ /dev/null @@ -1,284 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - unshift @INC, 't/lib/'; -} -chdir 't'; - -BEGIN { - $Testfile = 'testfile.foo'; -} - -BEGIN { - 1 while unlink $Testfile, 'newfile'; - # forcibly remove ecmddir/temp2, but don't import mkpath - use File::Path (); - File::Path::rmtree( 'ecmddir' ); -} - -use Test::More tests => 40; -use File::Spec; - -BEGIN { - # bad neighbor, but test_f() uses exit() - *CORE::GLOBAL::exit = ''; # quiet 'only once' warning. - *CORE::GLOBAL::exit = sub (;$) { return $_[0] }; - use_ok( 'ExtUtils::Command' ); -} - -{ - # concatenate this file with itself - # be extra careful the regex doesn't match itself - use TieOut; - my $out = tie *STDOUT, 'TieOut'; - my $self = $0; - unless (-f $self) { - my ($vol, $dirs, $file) = File::Spec->splitpath($self); - my @dirs = File::Spec->splitdir($dirs); - unshift(@dirs, File::Spec->updir); - $dirs = File::Spec->catdir(@dirs); - $self = File::Spec->catpath($vol, $dirs, $file); - } - @ARGV = ($self, $self); - - cat(); - is( scalar( $$out =~ s/use_ok\( 'ExtUtils::Command'//g), 2, - 'concatenation worked' ); - - # the truth value here is reversed -- Perl true is shell false - @ARGV = ( $Testfile ); - is( test_f(), 1, 'testing non-existent file' ); - - # these are destructive, have to keep setting @ARGV - @ARGV = ( $Testfile ); - touch(); - - @ARGV = ( $Testfile ); - is( test_f(), 0, 'testing touch() and test_f()' ); - is_deeply( \@ARGV, [$Testfile], 'test_f preserves @ARGV' ); - - @ARGV = ( $Testfile ); - ok( -e $ARGV[0], 'created!' ); - - my ($now) = time; - utime ($now, $now, $ARGV[0]); - sleep 2; - - # Just checking modify time stamp, access time stamp is set - # to the beginning of the day in Win95. - # There's a small chance of a 1 second flutter here. - my $stamp = (stat($ARGV[0]))[9]; - cmp_ok( abs($now - $stamp), '<=', 1, 'checking modify time stamp' ) || - diag "mtime == $stamp, should be $now"; - - @ARGV = qw(newfile); - touch(); - - my $new_stamp = (stat('newfile'))[9]; - cmp_ok( abs($new_stamp - $stamp), '>=', 2, 'newer file created' ); - - @ARGV = ('newfile', $Testfile); - eqtime(); - - $stamp = (stat($Testfile))[9]; - cmp_ok( abs($new_stamp - $stamp), '<=', 1, 'eqtime' ); - - # eqtime use to clear the contents of the file being equalized! - open(FILE, ">>$Testfile") || die $!; - print FILE "Foo"; - close FILE; - - @ARGV = ('newfile', $Testfile); - eqtime(); - ok( -s $Testfile, "eqtime doesn't clear the file being equalized" ); - - SKIP: { - if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || - $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin' || - $^O eq 'MacOS' - ) { - skip( "different file permission semantics on $^O", 3); - } - - # change a file to execute-only - @ARGV = ( '0100', $Testfile ); - ExtUtils::Command::chmod(); - - is( ((stat($Testfile))[2] & 07777) & 0700, - 0100, 'change a file to execute-only' ); - - # change a file to read-only - @ARGV = ( '0400', $Testfile ); - ExtUtils::Command::chmod(); - - is( ((stat($Testfile))[2] & 07777) & 0700, - ($^O eq 'vos' ? 0500 : 0400), 'change a file to read-only' ); - - # change a file to write-only - @ARGV = ( '0200', $Testfile ); - ExtUtils::Command::chmod(); - - is( ((stat($Testfile))[2] & 07777) & 0700, - ($^O eq 'vos' ? 0700 : 0200), 'change a file to write-only' ); - } - - # change a file to read-write - @ARGV = ( '0600', $Testfile ); - my @orig_argv = @ARGV; - ExtUtils::Command::chmod(); - is_deeply( \@ARGV, \@orig_argv, 'chmod preserves @ARGV' ); - - is( ((stat($Testfile))[2] & 07777) & 0700, - ($^O eq 'vos' ? 0700 : 0600), 'change a file to read-write' ); - - - SKIP: { - if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || - $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin' || - $^O eq 'MacOS' - ) { - skip( "different file permission semantics on $^O", 5); - } - - @ARGV = ('testdir'); - mkpath; - ok( -e 'testdir' ); - - # change a dir to execute-only - @ARGV = ( '0100', 'testdir' ); - ExtUtils::Command::chmod(); - - is( ((stat('testdir'))[2] & 07777) & 0700, - 0100, 'change a dir to execute-only' ); - - # change a dir to read-only - @ARGV = ( '0400', 'testdir' ); - ExtUtils::Command::chmod(); - - is( ((stat('testdir'))[2] & 07777) & 0700, - ($^O eq 'vos' ? 0500 : 0400), 'change a dir to read-only' ); - - # change a dir to write-only - @ARGV = ( '0200', 'testdir' ); - ExtUtils::Command::chmod(); - - is( ((stat('testdir'))[2] & 07777) & 0700, - ($^O eq 'vos' ? 0700 : 0200), 'change a dir to write-only' ); - - @ARGV = ('testdir'); - rm_rf; - ok( ! -e 'testdir', 'rm_rf can delete a read-only dir' ); - } - - - # mkpath - my $test_dir = File::Spec->join( 'ecmddir', 'temp2' ); - @ARGV = ( $test_dir ); - ok( ! -e $ARGV[0], 'temp directory not there yet' ); - is( test_d(), 1, 'testing non-existent directory' ); - - @ARGV = ( $test_dir ); - mkpath(); - ok( -e $ARGV[0], 'temp directory created' ); - is( test_d(), 0, 'testing existing dir' ); - - @ARGV = ( $test_dir ); - # copy a file to a nested subdirectory - unshift @ARGV, $Testfile; - @orig_argv = @ARGV; - cp(); - is_deeply( \@ARGV, \@orig_argv, 'cp preserves @ARGV' ); - - ok( -e File::Spec->join( 'ecmddir', 'temp2', $Testfile ), 'copied okay' ); - - # cp should croak if destination isn't directory (not a great warning) - @ARGV = ( $Testfile ) x 3; - eval { cp() }; - - like( $@, qr/Too many arguments/, 'cp croaks on error' ); - - # move a file to a subdirectory - @ARGV = ( $Testfile, 'ecmddir' ); - @orig_argv = @ARGV; - ok( mv() ); - is_deeply( \@ARGV, \@orig_argv, 'mv preserves @ARGV' ); - - ok( ! -e $Testfile, 'moved file away' ); - ok( -e File::Spec->join( 'ecmddir', $Testfile ), 'file in new location' ); - - # mv should also croak with the same wacky warning - @ARGV = ( $Testfile ) x 3; - - eval { mv() }; - like( $@, qr/Too many arguments/, 'mv croaks on error' ); - - # Test expand_wildcards() - { - my $file = $Testfile; - @ARGV = (); - chdir 'ecmddir'; - - # % means 'match one character' on VMS. Everything else is ? - my $match_char = $^O eq 'VMS' ? '%' : '?'; - ($ARGV[0] = $file) =~ s/.\z/$match_char/; - - # this should find the file - ExtUtils::Command::expand_wildcards(); - - is_deeply( \@ARGV, [$file], 'expanded wildcard ? successfully' ); - - # try it with the asterisk now - ($ARGV[0] = $file) =~ s/.{3}\z/\*/; - ExtUtils::Command::expand_wildcards(); - - is_deeply( \@ARGV, [$file], 'expanded wildcard * successfully' ); - - chdir File::Spec->updir; - } - - # remove some files - my @files = @ARGV = ( File::Spec->catfile( 'ecmddir', $Testfile ), - File::Spec->catfile( 'ecmddir', 'temp2', $Testfile ) ); - rm_f(); - - ok( ! -e $_, "removed $_ successfully" ) for (@ARGV); - - # rm_f dir - @ARGV = my $dir = File::Spec->catfile( 'ecmddir' ); - rm_rf(); - ok( ! -e $dir, "removed $dir successfully" ); -} - -{ - { local @ARGV = 'd2utest'; mkpath; } - open(FILE, '>d2utest/foo'); - binmode(FILE); - print FILE "stuff\015\012and thing\015\012"; - close FILE; - - open(FILE, '>d2utest/bar'); - binmode(FILE); - my $bin = "\c@\c@\c@\c@\c@\c@\cA\c@\c@\c@\015\012". - "\@\c@\cA\c@\c@\c@8__LIN\015\012"; - print FILE $bin; - close FILE; - - local @ARGV = 'd2utest'; - ExtUtils::Command::dos2unix(); - - open(FILE, 'd2utest/foo'); - is( join('', ), "stuff\012and thing\012", 'dos2unix' ); - close FILE; - - open(FILE, 'd2utest/bar'); - binmode(FILE); - ok( -B 'd2utest/bar' ); - is( join('', ), $bin, 'dos2unix preserves binaries'); - close FILE; -} - -END { - 1 while unlink $Testfile, 'newfile'; - File::Path::rmtree( 'ecmddir' ); - File::Path::rmtree( 'd2utest' ); -} diff --git a/cpan/ExtUtils-Command/t/lib/TieOut.pm b/cpan/ExtUtils-Command/t/lib/TieOut.pm deleted file mode 100644 index 0a0f5f9cfe..0000000000 --- a/cpan/ExtUtils-Command/t/lib/TieOut.pm +++ /dev/null @@ -1,28 +0,0 @@ -package TieOut; - -sub TIEHANDLE { - my $scalar = ''; - bless( \$scalar, $_[0]); -} - -sub PRINT { - my $self = shift; - $$self .= join('', @_); -} - -sub PRINTF { - my $self = shift; - my $fmt = shift; - $$self .= sprintf $fmt, @_; -} - -sub FILENO {} - -sub read { - my $self = shift; - my $data = $$self; - $$self = ''; - return $data; -} - -1; diff --git a/dist/ExtUtils-Command/lib/ExtUtils/Command.pm b/dist/ExtUtils-Command/lib/ExtUtils/Command.pm new file mode 100644 index 0000000000..7de4095445 --- /dev/null +++ b/dist/ExtUtils-Command/lib/ExtUtils/Command.pm @@ -0,0 +1,368 @@ +package ExtUtils::Command; + +use 5.00503; +use strict; +use Carp; +use File::Copy; +use File::Compare; +use File::Basename; +use File::Path qw(rmtree); +require Exporter; +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); +@ISA = qw(Exporter); +@EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod + dos2unix); +$VERSION = '1.16'; + +my $Is_VMS = $^O eq 'VMS'; +my $Is_VMS_mode = $Is_VMS; +my $Is_VMS_noefs = $Is_VMS; +my $Is_Win32 = $^O eq 'MSWin32'; + +if( $Is_VMS ) { + my $vms_unix_rpt; + my $vms_efs; + my $vms_case; + + if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { + $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); + $vms_efs = VMS::Feature::current("efs_charset"); + $vms_case = VMS::Feature::current("efs_case_preserve"); + } else { + my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; + my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; + $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; + $vms_efs = $efs_charset =~ /^[ET1]/i; + $vms_case = $efs_case =~ /^[ET1]/i; + } + $Is_VMS_mode = 0 if $vms_unix_rpt; + $Is_VMS_noefs = 0 if ($vms_efs); +} + + +=head1 NAME + +ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc. + +=head1 SYNOPSIS + + perl -MExtUtils::Command -e cat files... > destination + perl -MExtUtils::Command -e mv source... destination + perl -MExtUtils::Command -e cp source... destination + perl -MExtUtils::Command -e touch files... + perl -MExtUtils::Command -e rm_f files... + perl -MExtUtils::Command -e rm_rf directories... + perl -MExtUtils::Command -e mkpath directories... + perl -MExtUtils::Command -e eqtime source destination + perl -MExtUtils::Command -e test_f file + perl -MExtUtils::Command -e test_d directory + perl -MExtUtils::Command -e chmod mode files... + ... + +=head1 DESCRIPTION + +The module is used to replace common UNIX commands. In all cases the +functions work from @ARGV rather than taking arguments. This makes +them easier to deal with in Makefiles. Call them like this: + + perl -MExtUtils::Command -e some_command some files to work on + +and I like this: + + perl -MExtUtils::Command -e 'some_command qw(some files to work on)' + +For that use L. + +Filenames with * and ? will be glob expanded. + + +=head2 FUNCTIONS + +=over 4 + +=cut + +# VMS uses % instead of ? to mean "one character" +my $wild_regex = $Is_VMS ? '*%' : '*?'; +sub expand_wildcards +{ + @ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV); +} + + +=item cat + + cat file ... + +Concatenates all files mentioned on command line to STDOUT. + +=cut + +sub cat () +{ + expand_wildcards(); + print while (<>); +} + +=item eqtime + + eqtime source destination + +Sets modified time of destination to that of source. + +=cut + +sub eqtime +{ + my ($src,$dst) = @ARGV; + local @ARGV = ($dst); touch(); # in case $dst doesn't exist + utime((stat($src))[8,9],$dst); +} + +=item rm_rf + + rm_rf files or directories ... + +Removes files and directories - recursively (even if readonly) + +=cut + +sub rm_rf +{ + expand_wildcards(); + rmtree([grep -e $_,@ARGV],0,0); +} + +=item rm_f + + rm_f file ... + +Removes files (even if readonly) + +=cut + +sub rm_f { + expand_wildcards(); + + foreach my $file (@ARGV) { + next unless -f $file; + + next if _unlink($file); + + chmod(0777, $file); + + next if _unlink($file); + + carp "Cannot delete $file: $!"; + } +} + +sub _unlink { + my $files_unlinked = 0; + foreach my $file (@_) { + my $delete_count = 0; + $delete_count++ while unlink $file; + $files_unlinked++ if $delete_count; + } + return $files_unlinked; +} + + +=item touch + + touch file ... + +Makes files exist, with current timestamp + +=cut + +sub touch { + my $t = time; + expand_wildcards(); + foreach my $file (@ARGV) { + open(FILE,">>$file") || die "Cannot write $file:$!"; + close(FILE); + utime($t,$t,$file); + } +} + +=item mv + + mv source_file destination_file + mv source_file source_file destination_dir + +Moves source to destination. Multiple sources are allowed if +destination is an existing directory. + +Returns true if all moves succeeded, false otherwise. + +=cut + +sub mv { + expand_wildcards(); + my @src = @ARGV; + my $dst = pop @src; + + croak("Too many arguments") if (@src > 1 && ! -d $dst); + + my $nok = 0; + foreach my $src (@src) { + $nok ||= !move($src,$dst); + } + return !$nok; +} + +=item cp + + cp source_file destination_file + cp source_file source_file destination_dir + +Copies sources to the destination. Multiple sources are allowed if +destination is an existing directory. + +Returns true if all copies succeeded, false otherwise. + +=cut + +sub cp { + expand_wildcards(); + my @src = @ARGV; + my $dst = pop @src; + + croak("Too many arguments") if (@src > 1 && ! -d $dst); + + my $nok = 0; + foreach my $src (@src) { + $nok ||= !copy($src,$dst); + + # Win32 does not update the mod time of a copied file, just the + # created time which make does not look at. + utime(time, time, $dst) if $Is_Win32; + } + return $nok; +} + +=item chmod + + chmod mode files ... + +Sets UNIX like permissions 'mode' on all the files. e.g. 0666 + +=cut + +sub chmod { + local @ARGV = @ARGV; + my $mode = shift(@ARGV); + expand_wildcards(); + + if( $Is_VMS_mode && $Is_VMS_noefs) { + foreach my $idx (0..$#ARGV) { + my $path = $ARGV[$idx]; + next unless -d $path; + + # chmod 0777, [.foo.bar] doesn't work on VMS, you have to do + # chmod 0777, [.foo]bar.dir + my @dirs = File::Spec->splitdir( $path ); + $dirs[-1] .= '.dir'; + $path = File::Spec->catfile(@dirs); + + $ARGV[$idx] = $path; + } + } + + chmod(oct $mode,@ARGV) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!"; +} + +=item mkpath + + mkpath directory ... + +Creates directories, including any parent directories. + +=cut + +sub mkpath +{ + expand_wildcards(); + File::Path::mkpath([@ARGV],0,0777); +} + +=item test_f + + test_f file + +Tests if a file exists. I with 0 if it does, 1 if it does not (ie. +shell's idea of true and false). + +=cut + +sub test_f +{ + exit(-f $ARGV[0] ? 0 : 1); +} + +=item test_d + + test_d directory + +Tests if a directory exists. I with 0 if it does, 1 if it does +not (ie. shell's idea of true and false). + +=cut + +sub test_d +{ + exit(-d $ARGV[0] ? 0 : 1); +} + +=item dos2unix + + dos2unix files or dirs ... + +Converts DOS and OS/2 linefeeds to Unix style recursively. + +=cut + +sub dos2unix { + require File::Find; + File::Find::find(sub { + return if -d; + return unless -w _; + return unless -r _; + return if -B _; + + local $\; + + my $orig = $_; + my $temp = '.dos2unix_tmp'; + open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return }; + open TEMP, ">$temp" or + do { warn "dos2unix can't create .dos2unix_tmp: $!"; return }; + while (my $line = ) { + $line =~ s/\015\012/\012/g; + print TEMP $line; + } + close ORIG; + close TEMP; + rename $temp, $orig; + + }, @ARGV); +} + +=back + +=head1 SEE ALSO + +Shell::Command which is these same functions but take arguments normally. + + +=head1 AUTHOR + +Nick Ing-Simmons C + +Maintained by Michael G Schwern C within the +ExtUtils-MakeMaker package and, as a separate CPAN package, by +Randy Kobes C. + +=cut diff --git a/dist/ExtUtils-Command/t/cp.t b/dist/ExtUtils-Command/t/cp.t new file mode 100644 index 0000000000..0b899bf876 --- /dev/null +++ b/dist/ExtUtils-Command/t/cp.t @@ -0,0 +1,27 @@ +#!/usr/bin/perl -w + +BEGIN { + unshift @INC, 't/lib/'; +} +chdir 't'; + +use ExtUtils::Command; +use Test::More tests => 1; + +open FILE, ">source" or die $!; +print FILE "stuff\n"; +close FILE; + +# Instead of sleeping to make the file time older +utime time - 900, time - 900, "source"; + +END { 1 while unlink "source", "dest"; } + +# Win32 bug, cp wouldn't update mtime. +{ + local @ARGV = qw(source dest); + cp(); + my $mtime = (stat("dest"))[9]; + my $now = time; + cmp_ok( abs($mtime - $now), '<=', 1, 'cp updated mtime' ); +} diff --git a/dist/ExtUtils-Command/t/eu_command.t b/dist/ExtUtils-Command/t/eu_command.t new file mode 100644 index 0000000000..90374649ef --- /dev/null +++ b/dist/ExtUtils-Command/t/eu_command.t @@ -0,0 +1,284 @@ +#!/usr/bin/perl -w + +BEGIN { + unshift @INC, 't/lib/'; +} +chdir 't'; + +BEGIN { + $Testfile = 'testfile.foo'; +} + +BEGIN { + 1 while unlink $Testfile, 'newfile'; + # forcibly remove ecmddir/temp2, but don't import mkpath + use File::Path (); + File::Path::rmtree( 'ecmddir' ); +} + +use Test::More tests => 40; +use File::Spec; + +BEGIN { + # bad neighbor, but test_f() uses exit() + *CORE::GLOBAL::exit = ''; # quiet 'only once' warning. + *CORE::GLOBAL::exit = sub (;$) { return $_[0] }; + use_ok( 'ExtUtils::Command' ); +} + +{ + # concatenate this file with itself + # be extra careful the regex doesn't match itself + use TieOut; + my $out = tie *STDOUT, 'TieOut'; + my $self = $0; + unless (-f $self) { + my ($vol, $dirs, $file) = File::Spec->splitpath($self); + my @dirs = File::Spec->splitdir($dirs); + unshift(@dirs, File::Spec->updir); + $dirs = File::Spec->catdir(@dirs); + $self = File::Spec->catpath($vol, $dirs, $file); + } + @ARGV = ($self, $self); + + cat(); + is( scalar( $$out =~ s/use_ok\( 'ExtUtils::Command'//g), 2, + 'concatenation worked' ); + + # the truth value here is reversed -- Perl true is shell false + @ARGV = ( $Testfile ); + is( test_f(), 1, 'testing non-existent file' ); + + # these are destructive, have to keep setting @ARGV + @ARGV = ( $Testfile ); + touch(); + + @ARGV = ( $Testfile ); + is( test_f(), 0, 'testing touch() and test_f()' ); + is_deeply( \@ARGV, [$Testfile], 'test_f preserves @ARGV' ); + + @ARGV = ( $Testfile ); + ok( -e $ARGV[0], 'created!' ); + + my ($now) = time; + utime ($now, $now, $ARGV[0]); + sleep 2; + + # Just checking modify time stamp, access time stamp is set + # to the beginning of the day in Win95. + # There's a small chance of a 1 second flutter here. + my $stamp = (stat($ARGV[0]))[9]; + cmp_ok( abs($now - $stamp), '<=', 1, 'checking modify time stamp' ) || + diag "mtime == $stamp, should be $now"; + + @ARGV = qw(newfile); + touch(); + + my $new_stamp = (stat('newfile'))[9]; + cmp_ok( abs($new_stamp - $stamp), '>=', 2, 'newer file created' ); + + @ARGV = ('newfile', $Testfile); + eqtime(); + + $stamp = (stat($Testfile))[9]; + cmp_ok( abs($new_stamp - $stamp), '<=', 1, 'eqtime' ); + + # eqtime use to clear the contents of the file being equalized! + open(FILE, ">>$Testfile") || die $!; + print FILE "Foo"; + close FILE; + + @ARGV = ('newfile', $Testfile); + eqtime(); + ok( -s $Testfile, "eqtime doesn't clear the file being equalized" ); + + SKIP: { + if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || + $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin' || + $^O eq 'MacOS' + ) { + skip( "different file permission semantics on $^O", 3); + } + + # change a file to execute-only + @ARGV = ( '0100', $Testfile ); + ExtUtils::Command::chmod(); + + is( ((stat($Testfile))[2] & 07777) & 0700, + 0100, 'change a file to execute-only' ); + + # change a file to read-only + @ARGV = ( '0400', $Testfile ); + ExtUtils::Command::chmod(); + + is( ((stat($Testfile))[2] & 07777) & 0700, + ($^O eq 'vos' ? 0500 : 0400), 'change a file to read-only' ); + + # change a file to write-only + @ARGV = ( '0200', $Testfile ); + ExtUtils::Command::chmod(); + + is( ((stat($Testfile))[2] & 07777) & 0700, + ($^O eq 'vos' ? 0700 : 0200), 'change a file to write-only' ); + } + + # change a file to read-write + @ARGV = ( '0600', $Testfile ); + my @orig_argv = @ARGV; + ExtUtils::Command::chmod(); + is_deeply( \@ARGV, \@orig_argv, 'chmod preserves @ARGV' ); + + is( ((stat($Testfile))[2] & 07777) & 0700, + ($^O eq 'vos' ? 0700 : 0600), 'change a file to read-write' ); + + + SKIP: { + if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || + $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin' || + $^O eq 'MacOS' + ) { + skip( "different file permission semantics on $^O", 5); + } + + @ARGV = ('testdir'); + mkpath; + ok( -e 'testdir' ); + + # change a dir to execute-only + @ARGV = ( '0100', 'testdir' ); + ExtUtils::Command::chmod(); + + is( ((stat('testdir'))[2] & 07777) & 0700, + 0100, 'change a dir to execute-only' ); + + # change a dir to read-only + @ARGV = ( '0400', 'testdir' ); + ExtUtils::Command::chmod(); + + is( ((stat('testdir'))[2] & 07777) & 0700, + ($^O eq 'vos' ? 0500 : 0400), 'change a dir to read-only' ); + + # change a dir to write-only + @ARGV = ( '0200', 'testdir' ); + ExtUtils::Command::chmod(); + + is( ((stat('testdir'))[2] & 07777) & 0700, + ($^O eq 'vos' ? 0700 : 0200), 'change a dir to write-only' ); + + @ARGV = ('testdir'); + rm_rf; + ok( ! -e 'testdir', 'rm_rf can delete a read-only dir' ); + } + + + # mkpath + my $test_dir = File::Spec->join( 'ecmddir', 'temp2' ); + @ARGV = ( $test_dir ); + ok( ! -e $ARGV[0], 'temp directory not there yet' ); + is( test_d(), 1, 'testing non-existent directory' ); + + @ARGV = ( $test_dir ); + mkpath(); + ok( -e $ARGV[0], 'temp directory created' ); + is( test_d(), 0, 'testing existing dir' ); + + @ARGV = ( $test_dir ); + # copy a file to a nested subdirectory + unshift @ARGV, $Testfile; + @orig_argv = @ARGV; + cp(); + is_deeply( \@ARGV, \@orig_argv, 'cp preserves @ARGV' ); + + ok( -e File::Spec->join( 'ecmddir', 'temp2', $Testfile ), 'copied okay' ); + + # cp should croak if destination isn't directory (not a great warning) + @ARGV = ( $Testfile ) x 3; + eval { cp() }; + + like( $@, qr/Too many arguments/, 'cp croaks on error' ); + + # move a file to a subdirectory + @ARGV = ( $Testfile, 'ecmddir' ); + @orig_argv = @ARGV; + ok( mv() ); + is_deeply( \@ARGV, \@orig_argv, 'mv preserves @ARGV' ); + + ok( ! -e $Testfile, 'moved file away' ); + ok( -e File::Spec->join( 'ecmddir', $Testfile ), 'file in new location' ); + + # mv should also croak with the same wacky warning + @ARGV = ( $Testfile ) x 3; + + eval { mv() }; + like( $@, qr/Too many arguments/, 'mv croaks on error' ); + + # Test expand_wildcards() + { + my $file = $Testfile; + @ARGV = (); + chdir 'ecmddir'; + + # % means 'match one character' on VMS. Everything else is ? + my $match_char = $^O eq 'VMS' ? '%' : '?'; + ($ARGV[0] = $file) =~ s/.\z/$match_char/; + + # this should find the file + ExtUtils::Command::expand_wildcards(); + + is_deeply( \@ARGV, [$file], 'expanded wildcard ? successfully' ); + + # try it with the asterisk now + ($ARGV[0] = $file) =~ s/.{3}\z/\*/; + ExtUtils::Command::expand_wildcards(); + + is_deeply( \@ARGV, [$file], 'expanded wildcard * successfully' ); + + chdir File::Spec->updir; + } + + # remove some files + my @files = @ARGV = ( File::Spec->catfile( 'ecmddir', $Testfile ), + File::Spec->catfile( 'ecmddir', 'temp2', $Testfile ) ); + rm_f(); + + ok( ! -e $_, "removed $_ successfully" ) for (@ARGV); + + # rm_f dir + @ARGV = my $dir = File::Spec->catfile( 'ecmddir' ); + rm_rf(); + ok( ! -e $dir, "removed $dir successfully" ); +} + +{ + { local @ARGV = 'd2utest'; mkpath; } + open(FILE, '>d2utest/foo'); + binmode(FILE); + print FILE "stuff\015\012and thing\015\012"; + close FILE; + + open(FILE, '>d2utest/bar'); + binmode(FILE); + my $bin = "\c@\c@\c@\c@\c@\c@\cA\c@\c@\c@\015\012". + "\@\c@\cA\c@\c@\c@8__LIN\015\012"; + print FILE $bin; + close FILE; + + local @ARGV = 'd2utest'; + ExtUtils::Command::dos2unix(); + + open(FILE, 'd2utest/foo'); + is( join('', ), "stuff\012and thing\012", 'dos2unix' ); + close FILE; + + open(FILE, 'd2utest/bar'); + binmode(FILE); + ok( -B 'd2utest/bar' ); + is( join('', ), $bin, 'dos2unix preserves binaries'); + close FILE; +} + +END { + 1 while unlink $Testfile, 'newfile'; + File::Path::rmtree( 'ecmddir' ); + File::Path::rmtree( 'd2utest' ); +} diff --git a/dist/ExtUtils-Command/t/lib/TieOut.pm b/dist/ExtUtils-Command/t/lib/TieOut.pm new file mode 100644 index 0000000000..0a0f5f9cfe --- /dev/null +++ b/dist/ExtUtils-Command/t/lib/TieOut.pm @@ -0,0 +1,28 @@ +package TieOut; + +sub TIEHANDLE { + my $scalar = ''; + bless( \$scalar, $_[0]); +} + +sub PRINT { + my $self = shift; + $$self .= join('', @_); +} + +sub PRINTF { + my $self = shift; + my $fmt = shift; + $$self .= sprintf $fmt, @_; +} + +sub FILENO {} + +sub read { + my $self = shift; + my $data = $$self; + $$self = ''; + return $data; +} + +1; diff --git a/make_ext.pl b/make_ext.pl index 34ff2121cb..56a5188163 100644 --- a/make_ext.pl +++ b/make_ext.pl @@ -29,7 +29,7 @@ my $is_Unix = !$is_Win32 && !$is_VMS; # environment variables on VMS my @toolchain = qw(cpan/AutoLoader/lib dist/Cwd dist/Cwd/lib - cpan/ExtUtils-Command/lib + dist/ExtUtils-Command/lib dist/ExtUtils-Install/lib cpan/ExtUtils-MakeMaker/lib dist/ExtUtils-Manifest/lib diff --git a/t/TEST b/t/TEST index 6bcaa41896..945015f6b0 100755 --- a/t/TEST +++ b/t/TEST @@ -35,7 +35,6 @@ my %abs = ( '../cpan/Class-ISA' => 1, '../cpan/Devel-PPPort' => 1, '../cpan/Encode' => 1, - '../cpan/ExtUtils-Command' => 1, '../cpan/ExtUtils-Constant' => 1, '../cpan/ExtUtils-MakeMaker' => 1, '../cpan/File-Fetch' => 1, @@ -56,6 +55,7 @@ my %abs = ( '../cpan/Tie-File' => 1, '../cpan/podlators' => 1, '../dist/Cwd' => 1, + '../dist/ExtUtils-Command' => 1, '../dist/ExtUtils-Install' => 1, '../dist/ExtUtils-Manifest' => 1, '../dist/ExtUtils-ParseXS' => 1, -- cgit v1.2.1