| 1 | package ExtUtils::Command; |
| 2 | |
| 3 | use 5.00503; |
| 4 | use strict; |
| 5 | use Carp; |
| 6 | use File::Copy; |
| 7 | use File::Compare; |
| 8 | use File::Basename; |
| 9 | use File::Path qw(rmtree); |
| 10 | require Exporter; |
| 11 | use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); |
| 12 | @ISA = qw(Exporter); |
| 13 | @EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f chmod |
| 14 | dos2unix); |
| 15 | $VERSION = '1.09'; |
| 16 | |
| 17 | my $Is_VMS = $^O eq 'VMS'; |
| 18 | |
| 19 | =head1 NAME |
| 20 | |
| 21 | ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc. |
| 22 | |
| 23 | =head1 SYNOPSIS |
| 24 | |
| 25 | perl -MExtUtils::Command -e cat files... > destination |
| 26 | perl -MExtUtils::Command -e mv source... destination |
| 27 | perl -MExtUtils::Command -e cp source... destination |
| 28 | perl -MExtUtils::Command -e touch files... |
| 29 | perl -MExtUtils::Command -e rm_f files... |
| 30 | perl -MExtUtils::Command -e rm_rf directories... |
| 31 | perl -MExtUtils::Command -e mkpath directories... |
| 32 | perl -MExtUtils::Command -e eqtime source destination |
| 33 | perl -MExtUtils::Command -e test_f file |
| 34 | perl -MExtUtils::Command -e chmod mode files... |
| 35 | ... |
| 36 | |
| 37 | =head1 DESCRIPTION |
| 38 | |
| 39 | The module is used to replace common UNIX commands. In all cases the |
| 40 | functions work from @ARGV rather than taking arguments. This makes |
| 41 | them easier to deal with in Makefiles. |
| 42 | |
| 43 | perl -MExtUtils::Command -e some_command some files to work on |
| 44 | |
| 45 | I<NOT> |
| 46 | |
| 47 | perl -MExtUtils::Command -e 'some_command qw(some files to work on)' |
| 48 | |
| 49 | For that use L<Shell::Command>. |
| 50 | |
| 51 | Filenames with * and ? will be glob expanded. |
| 52 | |
| 53 | =over 4 |
| 54 | |
| 55 | =cut |
| 56 | |
| 57 | # VMS uses % instead of ? to mean "one character" |
| 58 | my $wild_regex = $Is_VMS ? '*%' : '*?'; |
| 59 | sub expand_wildcards |
| 60 | { |
| 61 | @ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV); |
| 62 | } |
| 63 | |
| 64 | |
| 65 | =item cat |
| 66 | |
| 67 | cat file ... |
| 68 | |
| 69 | Concatenates all files mentioned on command line to STDOUT. |
| 70 | |
| 71 | =cut |
| 72 | |
| 73 | sub cat () |
| 74 | { |
| 75 | expand_wildcards(); |
| 76 | print while (<>); |
| 77 | } |
| 78 | |
| 79 | =item eqtime |
| 80 | |
| 81 | eqtime source destination |
| 82 | |
| 83 | Sets modified time of destination to that of source. |
| 84 | |
| 85 | =cut |
| 86 | |
| 87 | sub eqtime |
| 88 | { |
| 89 | my ($src,$dst) = @ARGV; |
| 90 | local @ARGV = ($dst); touch(); # in case $dst doesn't exist |
| 91 | utime((stat($src))[8,9],$dst); |
| 92 | } |
| 93 | |
| 94 | =item rm_rf |
| 95 | |
| 96 | rm_rf files or directories ... |
| 97 | |
| 98 | Removes files and directories - recursively (even if readonly) |
| 99 | |
| 100 | =cut |
| 101 | |
| 102 | sub rm_rf |
| 103 | { |
| 104 | expand_wildcards(); |
| 105 | rmtree([grep -e $_,@ARGV],0,0); |
| 106 | } |
| 107 | |
| 108 | =item rm_f |
| 109 | |
| 110 | rm_f file ... |
| 111 | |
| 112 | Removes files (even if readonly) |
| 113 | |
| 114 | =cut |
| 115 | |
| 116 | sub rm_f { |
| 117 | expand_wildcards(); |
| 118 | |
| 119 | foreach my $file (@ARGV) { |
| 120 | next unless -f $file; |
| 121 | |
| 122 | next if _unlink($file); |
| 123 | |
| 124 | chmod(0777, $file); |
| 125 | |
| 126 | next if _unlink($file); |
| 127 | |
| 128 | carp "Cannot delete $file: $!"; |
| 129 | } |
| 130 | } |
| 131 | |
| 132 | sub _unlink { |
| 133 | my $files_unlinked = 0; |
| 134 | foreach my $file (@_) { |
| 135 | my $delete_count = 0; |
| 136 | $delete_count++ while unlink $file; |
| 137 | $files_unlinked++ if $delete_count; |
| 138 | } |
| 139 | return $files_unlinked; |
| 140 | } |
| 141 | |
| 142 | |
| 143 | =item touch |
| 144 | |
| 145 | touch file ... |
| 146 | |
| 147 | Makes files exist, with current timestamp |
| 148 | |
| 149 | =cut |
| 150 | |
| 151 | sub touch { |
| 152 | my $t = time; |
| 153 | expand_wildcards(); |
| 154 | foreach my $file (@ARGV) { |
| 155 | open(FILE,">>$file") || die "Cannot write $file:$!"; |
| 156 | close(FILE); |
| 157 | utime($t,$t,$file); |
| 158 | } |
| 159 | } |
| 160 | |
| 161 | =item mv |
| 162 | |
| 163 | mv source_file destination_file |
| 164 | mv source_file source_file destination_dir |
| 165 | |
| 166 | Moves source to destination. Multiple sources are allowed if |
| 167 | destination is an existing directory. |
| 168 | |
| 169 | Returns true if all moves succeeded, false otherwise. |
| 170 | |
| 171 | =cut |
| 172 | |
| 173 | sub mv { |
| 174 | expand_wildcards(); |
| 175 | my @src = @ARGV; |
| 176 | my $dst = pop @src; |
| 177 | |
| 178 | croak("Too many arguments") if (@src > 1 && ! -d $dst); |
| 179 | |
| 180 | my $nok = 0; |
| 181 | foreach my $src (@src) { |
| 182 | $nok ||= !move($src,$dst); |
| 183 | } |
| 184 | return !$nok; |
| 185 | } |
| 186 | |
| 187 | =item cp |
| 188 | |
| 189 | cp source_file destination_file |
| 190 | cp source_file source_file destination_dir |
| 191 | |
| 192 | Copies sources to the destination. Multiple sources are allowed if |
| 193 | destination is an existing directory. |
| 194 | |
| 195 | Returns true if all copies succeeded, false otherwise. |
| 196 | |
| 197 | =cut |
| 198 | |
| 199 | sub cp { |
| 200 | expand_wildcards(); |
| 201 | my @src = @ARGV; |
| 202 | my $dst = pop @src; |
| 203 | |
| 204 | croak("Too many arguments") if (@src > 1 && ! -d $dst); |
| 205 | |
| 206 | my $nok = 0; |
| 207 | foreach my $src (@src) { |
| 208 | $nok ||= !copy($src,$dst); |
| 209 | } |
| 210 | return $nok; |
| 211 | } |
| 212 | |
| 213 | =item chmod |
| 214 | |
| 215 | chmod mode files ... |
| 216 | |
| 217 | Sets UNIX like permissions 'mode' on all the files. e.g. 0666 |
| 218 | |
| 219 | =cut |
| 220 | |
| 221 | sub chmod { |
| 222 | local @ARGV = @ARGV; |
| 223 | my $mode = shift(@ARGV); |
| 224 | expand_wildcards(); |
| 225 | |
| 226 | if( $Is_VMS ) { |
| 227 | foreach my $idx (0..$#ARGV) { |
| 228 | my $path = $ARGV[$idx]; |
| 229 | next unless -d $path; |
| 230 | |
| 231 | # chmod 0777, [.foo.bar] doesn't work on VMS, you have to do |
| 232 | # chmod 0777, [.foo]bar.dir |
| 233 | my @dirs = File::Spec->splitdir( $path ); |
| 234 | $dirs[-1] .= '.dir'; |
| 235 | $path = File::Spec->catfile(@dirs); |
| 236 | |
| 237 | $ARGV[$idx] = $path; |
| 238 | } |
| 239 | } |
| 240 | |
| 241 | chmod(oct $mode,@ARGV) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!"; |
| 242 | } |
| 243 | |
| 244 | =item mkpath |
| 245 | |
| 246 | mkpath directory ... |
| 247 | |
| 248 | Creates directories, including any parent directories. |
| 249 | |
| 250 | =cut |
| 251 | |
| 252 | sub mkpath |
| 253 | { |
| 254 | expand_wildcards(); |
| 255 | File::Path::mkpath([@ARGV],0,0777); |
| 256 | } |
| 257 | |
| 258 | =item test_f |
| 259 | |
| 260 | test_f file |
| 261 | |
| 262 | Tests if a file exists |
| 263 | |
| 264 | =cut |
| 265 | |
| 266 | sub test_f |
| 267 | { |
| 268 | exit !-f $ARGV[0]; |
| 269 | } |
| 270 | |
| 271 | =item dos2unix |
| 272 | |
| 273 | dos2unix files or dirs ... |
| 274 | |
| 275 | Converts DOS and OS/2 linefeeds to Unix style recursively. |
| 276 | |
| 277 | =cut |
| 278 | |
| 279 | sub dos2unix { |
| 280 | require File::Find; |
| 281 | File::Find::find(sub { |
| 282 | return if -d; |
| 283 | return unless -w _; |
| 284 | return unless -r _; |
| 285 | return if -B _; |
| 286 | |
| 287 | local $\; |
| 288 | |
| 289 | my $orig = $_; |
| 290 | my $temp = '.dos2unix_tmp'; |
| 291 | open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return }; |
| 292 | open TEMP, ">$temp" or |
| 293 | do { warn "dos2unix can't create .dos2unix_tmp: $!"; return }; |
| 294 | while (my $line = <ORIG>) { |
| 295 | $line =~ s/\015\012/\012/g; |
| 296 | print TEMP $line; |
| 297 | } |
| 298 | close ORIG; |
| 299 | close TEMP; |
| 300 | rename $temp, $orig; |
| 301 | |
| 302 | }, @ARGV); |
| 303 | } |
| 304 | |
| 305 | =back |
| 306 | |
| 307 | =head1 SEE ALSO |
| 308 | |
| 309 | Shell::Command which is these same functions but take arguments normally. |
| 310 | |
| 311 | |
| 312 | =head1 AUTHOR |
| 313 | |
| 314 | Nick Ing-Simmons C<ni-s@cpan.org> |
| 315 | |
| 316 | Currently maintained by Michael G Schwern C<schwern@pobox.com>. |
| 317 | |
| 318 | =cut |
| 319 | |