| 1 | #!/usr/local/bin/perl |
| 2 | |
| 3 | use Config; |
| 4 | use File::Basename qw(&basename &dirname); |
| 5 | use Cwd; |
| 6 | |
| 7 | # List explicitly here the variables you want Configure to |
| 8 | # generate. Metaconfig only looks for shell variables, so you |
| 9 | # have to mention them as if they were shell variables, not |
| 10 | # %Config entries. Thus you write |
| 11 | # $startperl |
| 12 | # to ensure Configure will look for $Config{startperl}. |
| 13 | |
| 14 | # This forces PL files to create target in same directory as PL file. |
| 15 | # This is so that make depend always knows where to find PL derivatives. |
| 16 | $origdir = cwd; |
| 17 | chdir dirname($0); |
| 18 | $file = basename($0, '.PL'); |
| 19 | $file .= '.com' if $^O eq 'VMS'; |
| 20 | |
| 21 | open OUT,">$file" or die "Can't create $file: $!"; |
| 22 | |
| 23 | print "Extracting $file (with variable substitutions)\n"; |
| 24 | |
| 25 | # In this section, perl variables will be expanded during extraction. |
| 26 | # You can use $Config{...} to use Configure variables. |
| 27 | |
| 28 | print OUT <<"!GROK!THIS!"; |
| 29 | $Config{startperl} |
| 30 | eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' |
| 31 | if \$running_under_some_shell; |
| 32 | my \$perlpath = "$Config{perlpath}"; |
| 33 | !GROK!THIS! |
| 34 | |
| 35 | # In the following, perl variables are not expanded during extraction. |
| 36 | |
| 37 | print OUT <<'!NO!SUBS!'; |
| 38 | use strict; |
| 39 | use vars qw/$statdone/; |
| 40 | my $startperl = "#! $perlpath -w"; |
| 41 | |
| 42 | # |
| 43 | # Modified September 26, 1993 to provide proper handling of years after 1999 |
| 44 | # Tom Link <tml+@pitt.edu> |
| 45 | # University of Pittsburgh |
| 46 | # |
| 47 | # Modified April 7, 1998 with nasty hacks to implement the troublesome -follow |
| 48 | # Billy Constantine <wdconsta@cs.adelaide.edu.au> <billy@smug.adelaide.edu.au> |
| 49 | # University of Adelaide, Adelaide, South Australia |
| 50 | # |
| 51 | # Modified 1999-06-10, 1999-07-07 to migrate to cleaner perl5 usage |
| 52 | # Ken Pizzini <ken@halcyon.com> |
| 53 | # |
| 54 | # Modified 2000-01-28 to use the 'follow' option of File::Find |
| 55 | |
| 56 | my @roots = (); |
| 57 | while ($ARGV[0] =~ /^[^-!(]/) { |
| 58 | push(@roots, shift); |
| 59 | } |
| 60 | @roots = ('.') unless @roots; |
| 61 | for (@roots) { $_ = "e($_) } |
| 62 | my $roots = join(', ', @roots); |
| 63 | |
| 64 | my $find = "find"; |
| 65 | my $indent_depth = 1; |
| 66 | my $stat = 'lstat'; |
| 67 | my $decl = ''; |
| 68 | my $flushall = ''; |
| 69 | my $initfile = ''; |
| 70 | my $initnewer = ''; |
| 71 | my $out = ''; |
| 72 | my %init = (); |
| 73 | my ($follow_in_effect,$Skip_And) = (0,0); |
| 74 | |
| 75 | while (@ARGV) { |
| 76 | $_ = shift; |
| 77 | s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n"; |
| 78 | if ($_ eq '(') { |
| 79 | $out .= &tab . "(\n"; |
| 80 | $indent_depth++; |
| 81 | next; |
| 82 | } elsif ($_ eq ')') { |
| 83 | --$indent_depth; |
| 84 | $out .= &tab . ")"; |
| 85 | } elsif ($_ eq 'follow') { |
| 86 | $follow_in_effect= 1; |
| 87 | $stat = 'stat'; |
| 88 | $Skip_And= 1; |
| 89 | } elsif ($_ eq '!') { |
| 90 | $out .= &tab . "!"; |
| 91 | next; |
| 92 | } elsif ($_ eq 'name') { |
| 93 | $out .= &tab . '/' . &fileglob_to_re(shift) . "/"; |
| 94 | } elsif ($_ eq 'perm') { |
| 95 | my $onum = shift; |
| 96 | $onum =~ /^-?[0-7]+$/ |
| 97 | || die "Malformed -perm argument: $onum\n"; |
| 98 | $out .= &tab; |
| 99 | if ($onum =~ s/^-//) { |
| 100 | $onum = sprintf("0%o", oct($onum) & 07777); |
| 101 | $out .= "((\$mode & $onum) == $onum)"; |
| 102 | } else { |
| 103 | $onum =~ s/^0*/0/; |
| 104 | $out .= "((\$mode & 0777) == $onum)"; |
| 105 | } |
| 106 | } elsif ($_ eq 'type') { |
| 107 | (my $filetest = shift) =~ tr/s/S/; |
| 108 | $out .= &tab . "-$filetest _"; |
| 109 | } elsif ($_ eq 'print') { |
| 110 | $out .= &tab . 'print("$name\n")'; |
| 111 | } elsif ($_ eq 'print0') { |
| 112 | $out .= &tab . 'print("$name\0")'; |
| 113 | } elsif ($_ eq 'fstype') { |
| 114 | my $type = shift; |
| 115 | $out .= &tab; |
| 116 | if ($type eq 'nfs') { |
| 117 | $out .= '($dev < 0)'; |
| 118 | } else { |
| 119 | $out .= '($dev >= 0)'; #XXX |
| 120 | } |
| 121 | } elsif ($_ eq 'user') { |
| 122 | my $uname = shift; |
| 123 | $out .= &tab . "(\$uid == \$uid{'$uname'})"; |
| 124 | $init{user} = 1; |
| 125 | } elsif ($_ eq 'group') { |
| 126 | my $gname = shift; |
| 127 | $out .= &tab . "(\$gid == \$gid{'$gname'})"; |
| 128 | $init{group} = 1; |
| 129 | } elsif ($_ eq 'nouser') { |
| 130 | $out .= &tab . '!exists $uid{$uid}'; |
| 131 | $init{user} = 1; |
| 132 | } elsif ($_ eq 'nogroup') { |
| 133 | $out .= &tab . '!exists $gid{$gid}'; |
| 134 | $init{group} = 1; |
| 135 | } elsif ($_ eq 'links') { |
| 136 | $out .= &tab . &n('$nlink', shift); |
| 137 | } elsif ($_ eq 'inum') { |
| 138 | $out .= &tab . &n('$ino', shift); |
| 139 | } elsif ($_ eq 'size') { |
| 140 | $_ = shift; |
| 141 | my $n = 'int(((-s _) + 511) / 512)'; |
| 142 | if (s/c$//) { |
| 143 | $n = 'int(-s _)'; |
| 144 | } elsif (s/k$//) { |
| 145 | $n = 'int(((-s _) + 1023) / 1024)'; |
| 146 | } |
| 147 | $out .= &tab . &n($n, $_); |
| 148 | } elsif ($_ eq 'atime') { |
| 149 | $out .= &tab . &n('int(-A _)', shift); |
| 150 | } elsif ($_ eq 'mtime') { |
| 151 | $out .= &tab . &n('int(-M _)', shift); |
| 152 | } elsif ($_ eq 'ctime') { |
| 153 | $out .= &tab . &n('int(-C _)', shift); |
| 154 | } elsif ($_ eq 'exec') { |
| 155 | my @cmd = (); |
| 156 | while (@ARGV && $ARGV[0] ne ';') |
| 157 | { push(@cmd, shift) } |
| 158 | shift; |
| 159 | $out .= &tab; |
| 160 | if ($cmd[0] =~m#^(?:(?:/usr)?/bin/)?rm$# |
| 161 | && $cmd[$#cmd] eq '{}' |
| 162 | && (@cmd == 2 || (@cmd == 3 && $cmd[1] eq '-f'))) { |
| 163 | if (@cmd == 2) { |
| 164 | $out .= '(unlink($_) || warn "$name: $!\n")'; |
| 165 | } elsif (!@ARGV) { |
| 166 | $out .= 'unlink($_)'; |
| 167 | } else { |
| 168 | $out .= '(unlink($_) || 1)'; |
| 169 | } |
| 170 | } else { |
| 171 | for (@cmd) |
| 172 | { s/'/\\'/g } |
| 173 | { local $" = "','"; $out .= "&doexec(0, '@cmd')"; } |
| 174 | $init{doexec} = 1; |
| 175 | } |
| 176 | } elsif ($_ eq 'ok') { |
| 177 | my @cmd = (); |
| 178 | while (@ARGV && $ARGV[0] ne ';') |
| 179 | { push(@cmd, shift) } |
| 180 | shift; |
| 181 | $out .= &tab; |
| 182 | for (@cmd) |
| 183 | { s/'/\\'/g } |
| 184 | { local $" = "','"; $out .= "&doexec(0, '@cmd')"; } |
| 185 | $init{doexec} = 1; |
| 186 | } elsif ($_ eq 'prune') { |
| 187 | $out .= &tab . '($File::Find::prune = 1)'; |
| 188 | } elsif ($_ eq 'xdev') { |
| 189 | $out .= &tab . '!($File::Find::prune |= ($dev != $File::Find::topdev))' |
| 190 | ; |
| 191 | } elsif ($_ eq 'newer') { |
| 192 | my $file = shift; |
| 193 | my $newername = 'AGE_OF' . $file; |
| 194 | $newername =~ s/\W/_/g; |
| 195 | $newername = '$' . $newername; |
| 196 | $out .= &tab . "(-M _ < $newername)"; |
| 197 | $initnewer .= "my $newername = -M " . "e($file) . ";\n"; |
| 198 | } elsif ($_ eq 'eval') { |
| 199 | my $prog = shift; |
| 200 | $prog =~ s/'/\\'/g; |
| 201 | $out .= &tab . "eval {$prog}"; |
| 202 | } elsif ($_ eq 'depth') { |
| 203 | $find = 'finddepth'; |
| 204 | next; |
| 205 | } elsif ($_ eq 'ls') { |
| 206 | $out .= &tab . "&ls"; |
| 207 | $init{ls} = 1; |
| 208 | } elsif ($_ eq 'tar') { |
| 209 | die "-tar must have a filename argument\n" unless @ARGV; |
| 210 | my $file = shift; |
| 211 | my $fh = 'FH' . $file; |
| 212 | $fh =~ s/\W/_/g; |
| 213 | $out .= &tab . "&tar(*$fh, \$name)"; |
| 214 | $flushall .= "&tflushall;\n"; |
| 215 | $initfile .= "open($fh, " . "e('> ' . $file) . |
| 216 | qq{) || die "Can't open $fh: \$!\\n";\n}; |
| 217 | $init{tar} = 1; |
| 218 | } elsif (/^(n?)cpio$/) { |
| 219 | die "-$_ must have a filename argument\n" unless @ARGV; |
| 220 | my $file = shift; |
| 221 | my $fh = 'FH' . $file; |
| 222 | $fh =~ s/\W/_/g; |
| 223 | $out .= &tab . "&cpio(*$fh, \$name, '$1')"; |
| 224 | $find = 'finddepth'; |
| 225 | $flushall .= "&cflushall;\n"; |
| 226 | $initfile .= "open($fh, " . "e('> ' . $file) . |
| 227 | qq{) || die "Can't open $fh: \$!\\n";\n}; |
| 228 | $init{cpio} = 1; |
| 229 | } else { |
| 230 | die "Unrecognized switch: -$_\n"; |
| 231 | } |
| 232 | |
| 233 | if (@ARGV) { |
| 234 | if ($ARGV[0] eq '-o') { |
| 235 | { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; } |
| 236 | $statdone = 0 if $indent_depth == 1 && exists $init{delayedstat}; |
| 237 | $init{saw_or} = 1; |
| 238 | shift; |
| 239 | } else { |
| 240 | $out .= " &&" unless $Skip_And || $ARGV[0] eq ')'; |
| 241 | $out .= "\n"; |
| 242 | shift if $ARGV[0] eq '-a'; |
| 243 | } |
| 244 | } |
| 245 | } |
| 246 | |
| 247 | |
| 248 | print <<"END"; |
| 249 | $startperl |
| 250 | eval 'exec $perlpath -S \$0 \${1+"\$@"}' |
| 251 | if 0; #\$running_under_some_shell |
| 252 | |
| 253 | use strict; |
| 254 | use File::Find (); |
| 255 | |
| 256 | # Set the variable \$File::Find::dont_use_nlink if you're using AFS, |
| 257 | # since AFS cheats. |
| 258 | |
| 259 | # for the convenience of &wanted calls, including -eval statements: |
| 260 | use vars qw/*name *dir *prune/; |
| 261 | *name = *File::Find::name; |
| 262 | *dir = *File::Find::dir; |
| 263 | *prune = *File::Find::prune; |
| 264 | |
| 265 | END |
| 266 | |
| 267 | |
| 268 | if (exists $init{ls}) { |
| 269 | print <<'END'; |
| 270 | my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx); |
| 271 | my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); |
| 272 | |
| 273 | END |
| 274 | } |
| 275 | |
| 276 | if (exists $init{user} || exists $init{ls} || exists $init{tar}) { |
| 277 | print "my (%uid, %user);\n"; |
| 278 | print "while (my (\$name, \$pw, \$uid) = getpwent) {\n"; |
| 279 | print ' $uid{$name} = $uid{$uid} = $uid;', "\n" |
| 280 | if exists $init{user}; |
| 281 | print ' $user{$uid} = $name unless exists $user{$uid};', "\n" |
| 282 | if exists $init{ls} || exists $init{tar}; |
| 283 | print "}\n\n"; |
| 284 | } |
| 285 | |
| 286 | if (exists $init{group} || exists $init{ls} || exists $init{tar}) { |
| 287 | print "my (%gid, %group);\n"; |
| 288 | print "while (my (\$name, \$pw, \$gid) = getgrent) {\n"; |
| 289 | print ' $gid{$name} = $gid{$gid} = $gid;', "\n" |
| 290 | if exists $init{group}; |
| 291 | print ' $group{$gid} = $name unless exists $group{$gid};', "\n" |
| 292 | if exists $init{ls} || exists $init{tar}; |
| 293 | print "}\n\n"; |
| 294 | } |
| 295 | |
| 296 | print $initnewer, "\n" if $initnewer ne ''; |
| 297 | print $initfile, "\n" if $initfile ne ''; |
| 298 | $flushall .= "exit;\n"; |
| 299 | if (exists $init{declarestat}) { |
| 300 | $out = <<'END' . $out; |
| 301 | my ($dev,$ino,$mode,$nlink,$uid,$gid); |
| 302 | |
| 303 | END |
| 304 | } |
| 305 | |
| 306 | if ( $follow_in_effect ) { |
| 307 | $out =~ s/lstat\(\$_\)/lstat(_)/; |
| 308 | print <<"END"; |
| 309 | $decl |
| 310 | # Traverse desired filesystems |
| 311 | File::Find::$find( {wanted => \\&wanted, follow => 1}, $roots); |
| 312 | $flushall |
| 313 | |
| 314 | sub wanted { |
| 315 | $out; |
| 316 | } |
| 317 | |
| 318 | END |
| 319 | } else { |
| 320 | print <<"END"; |
| 321 | $decl |
| 322 | # Traverse desired filesystems |
| 323 | File::Find::$find({wanted => \\&wanted}, $roots); |
| 324 | $flushall |
| 325 | |
| 326 | sub wanted { |
| 327 | $out; |
| 328 | } |
| 329 | |
| 330 | END |
| 331 | } |
| 332 | |
| 333 | if (exists $init{doexec}) { |
| 334 | print <<'END'; |
| 335 | |
| 336 | BEGIN { |
| 337 | require Cwd; |
| 338 | my $cwd = Cwd::cwd(); |
| 339 | } |
| 340 | |
| 341 | sub doexec { |
| 342 | my $ok = shift; |
| 343 | for my $word (@_) |
| 344 | { $word =~ s#{}#$name#g } |
| 345 | if ($ok) { |
| 346 | my $old = select(STDOUT); |
| 347 | $| = 1; |
| 348 | print "@_"; |
| 349 | select($old); |
| 350 | return 0 unless <STDIN> =~ /^y/; |
| 351 | } |
| 352 | chdir $cwd; #sigh |
| 353 | system @_; |
| 354 | chdir $File::Find::dir; |
| 355 | return !$?; |
| 356 | } |
| 357 | |
| 358 | END |
| 359 | } |
| 360 | |
| 361 | if (exists $init{ls}) { |
| 362 | print <<'INTRO', <<"SUB", <<'END'; |
| 363 | |
| 364 | sub sizemm { |
| 365 | my $rdev = shift; |
| 366 | sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff); |
| 367 | } |
| 368 | |
| 369 | sub ls { |
| 370 | my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, |
| 371 | INTRO |
| 372 | \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_); |
| 373 | SUB |
| 374 | my $pname = $name; |
| 375 | |
| 376 | $blocks |
| 377 | or $blocks = int(($size + 1023) / 1024); |
| 378 | |
| 379 | my $perms = $rwx[$mode & 7]; |
| 380 | $mode >>= 3; |
| 381 | $perms = $rwx[$mode & 7] . $perms; |
| 382 | $mode >>= 3; |
| 383 | $perms = $rwx[$mode & 7] . $perms; |
| 384 | substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _; |
| 385 | substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _; |
| 386 | substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _; |
| 387 | if (-f _) { $perms = '-' . $perms; } |
| 388 | elsif (-d _) { $perms = 'd' . $perms; } |
| 389 | elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); } |
| 390 | elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); } |
| 391 | elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); } |
| 392 | elsif (-p _) { $perms = 'p' . $perms; } |
| 393 | elsif (-S _) { $perms = 's' . $perms; } |
| 394 | else { $perms = '?' . $perms; } |
| 395 | |
| 396 | my $user = $user{$uid} || $uid; |
| 397 | my $group = $group{$gid} || $gid; |
| 398 | |
| 399 | my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime); |
| 400 | if (-M _ > 365.25 / 2) { |
| 401 | $timeyear += 1900; |
| 402 | } else { |
| 403 | $timeyear = sprintf("%02d:%02d", $hour, $min); |
| 404 | } |
| 405 | |
| 406 | printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n", |
| 407 | $ino, |
| 408 | $blocks, |
| 409 | $perms, |
| 410 | $nlink, |
| 411 | $user, |
| 412 | $group, |
| 413 | $size, |
| 414 | $moname[$mon], |
| 415 | $mday, |
| 416 | $timeyear, |
| 417 | $pname; |
| 418 | 1; |
| 419 | } |
| 420 | |
| 421 | END |
| 422 | } |
| 423 | |
| 424 | |
| 425 | if (exists $init{cpio} || exists $init{tar}) { |
| 426 | print <<'END'; |
| 427 | |
| 428 | my %blocks = (); |
| 429 | |
| 430 | sub flush { |
| 431 | my ($fh, $varref, $blksz) = @_; |
| 432 | |
| 433 | while (length($$varref) >= $blksz) { |
| 434 | no strict qw/refs/; |
| 435 | syswrite($fh, $$varref, $blksz); |
| 436 | substr($$varref, 0, $blksz) = ''; |
| 437 | ++$blocks{$fh}; |
| 438 | } |
| 439 | } |
| 440 | |
| 441 | END |
| 442 | } |
| 443 | |
| 444 | |
| 445 | if (exists $init{cpio}) { |
| 446 | print <<'INTRO', <<"SUB", <<'END'; |
| 447 | |
| 448 | my %cpout = (); |
| 449 | my %nc = (); |
| 450 | |
| 451 | sub cpio { |
| 452 | my ($fh, $fname, $nc) = @_; |
| 453 | my $text = ''; |
| 454 | my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, |
| 455 | $atime,$mtime,$ctime,$blksize,$blocks); |
| 456 | local (*IN); |
| 457 | |
| 458 | if ( ! defined $fname ) { |
| 459 | $fname = 'TRAILER!!!'; |
| 460 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, |
| 461 | $atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13; |
| 462 | } else { |
| 463 | ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, |
| 464 | INTRO |
| 465 | \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_); |
| 466 | SUB |
| 467 | if (-f _) { |
| 468 | open(IN, "./$_\0") || do { |
| 469 | warn "Couldn't open $fname: $!\n"; |
| 470 | return; |
| 471 | } |
| 472 | } else { |
| 473 | $text = readlink($_); |
| 474 | $size = 0 unless defined $text; |
| 475 | } |
| 476 | } |
| 477 | |
| 478 | $fname =~ s#^\./##; |
| 479 | $nc{$fh} = $nc; |
| 480 | if ($nc eq 'n') { |
| 481 | $cpout{$fh} .= |
| 482 | sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0", |
| 483 | 070707, |
| 484 | $dev & 0777777, |
| 485 | $ino & 0777777, |
| 486 | $mode & 0777777, |
| 487 | $uid & 0777777, |
| 488 | $gid & 0777777, |
| 489 | $nlink & 0777777, |
| 490 | $rdev & 0177777, |
| 491 | $mtime, |
| 492 | length($fname)+1, |
| 493 | $size, |
| 494 | $fname); |
| 495 | } else { |
| 496 | $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1; |
| 497 | $cpout{$fh} .= pack("SSSSSSSSLSLa*", |
| 498 | 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime, |
| 499 | length($fname)+1, $size, |
| 500 | $fname . (length($fname) & 1 ? "\0" : "\0\0")); |
| 501 | } |
| 502 | |
| 503 | if ($text ne '') { |
| 504 | $cpout{$fh} .= $text; |
| 505 | } elsif ($size) { |
| 506 | my $l; |
| 507 | flush($fh, \$cpout{$fh}, 5120) |
| 508 | while ($l = length($cpout{$fh})) >= 5120; |
| 509 | while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) { |
| 510 | flush($fh, \$cpout{$fh}, 5120); |
| 511 | $l = length($cpout{$fh}); |
| 512 | } |
| 513 | close IN; |
| 514 | } |
| 515 | } |
| 516 | |
| 517 | sub cflushall { |
| 518 | for my $fh (keys %cpout) { |
| 519 | &cpio($fh, undef, $nc{$fh}); |
| 520 | $cpout{$fh} .= "0" x (5120 - length($cpout{$fh})); |
| 521 | flush($fh, \$cpout{$fh}, 5120); |
| 522 | print $blocks{$fh} * 10, " blocks\n"; |
| 523 | } |
| 524 | } |
| 525 | |
| 526 | END |
| 527 | } |
| 528 | |
| 529 | if (exists $init{tar}) { |
| 530 | print <<'INTRO', <<"SUB", <<'END'; |
| 531 | |
| 532 | my %tarout = (); |
| 533 | my %linkseen = (); |
| 534 | |
| 535 | sub tar { |
| 536 | my ($fh, $fname) = @_; |
| 537 | my $prefix = ''; |
| 538 | my $typeflag = '0'; |
| 539 | my $linkname; |
| 540 | my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, |
| 541 | INTRO |
| 542 | \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_); |
| 543 | SUB |
| 544 | local (*IN); |
| 545 | |
| 546 | if ($nlink > 1) { |
| 547 | if ($linkname = $linkseen{$fh, $dev, $ino}) { |
| 548 | if (length($linkname) > 100) { |
| 549 | warn "$0: omitting file with linkname ", |
| 550 | "too long for tar output: $linkname\n"; |
| 551 | return; |
| 552 | } |
| 553 | $typeflag = '1'; |
| 554 | $size = 0; |
| 555 | } else { |
| 556 | $linkseen{$fh, $dev, $ino} = $fname; |
| 557 | } |
| 558 | } |
| 559 | if ($typeflag eq '0') { |
| 560 | if (-f _) { |
| 561 | open(IN, "./$_\0") || do { |
| 562 | warn "Couldn't open $fname: $!\n"; |
| 563 | return; |
| 564 | } |
| 565 | } else { |
| 566 | $linkname = readlink($_); |
| 567 | if (defined $linkname) { $typeflag = '2' } |
| 568 | elsif (-c _) { $typeflag = '3' } |
| 569 | elsif (-b _) { $typeflag = '4' } |
| 570 | elsif (-d _) { $typeflag = '5' } |
| 571 | elsif (-p _) { $typeflag = '6' } |
| 572 | } |
| 573 | } |
| 574 | |
| 575 | if (length($fname) > 100) { |
| 576 | ($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#); |
| 577 | if (!defined($fname) || length($prefix) > 155) { |
| 578 | warn "$0: omitting file with name too long for tar output: ", |
| 579 | $fname, "\n"; |
| 580 | return; |
| 581 | } |
| 582 | } |
| 583 | |
| 584 | $size = 0 if $typeflag ne '0'; |
| 585 | my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155", |
| 586 | $fname, |
| 587 | sprintf("%7o ", $mode & 0777), |
| 588 | sprintf("%7o ", $uid & 0777777), |
| 589 | sprintf("%7o ", $gid & 0777777), |
| 590 | sprintf("%11o ", $size), |
| 591 | sprintf("%11o ", $mtime), |
| 592 | ' 'x8, |
| 593 | $typeflag, |
| 594 | defined $linkname ? $linkname : '', |
| 595 | "ustar\0", |
| 596 | "00", |
| 597 | $user{$uid}, |
| 598 | $group{$gid}, |
| 599 | ($rdev >> 8) & 0xff, |
| 600 | $rdev & 0xff, |
| 601 | $prefix, |
| 602 | ); |
| 603 | substr($header, 148, 8) = sprintf("%7o ", unpack("%16C*", $header)); |
| 604 | my $l = length($header) % 512; |
| 605 | $tarout{$fh} .= $header; |
| 606 | $tarout{$fh} .= "\0" x (512 - $l) if $l; |
| 607 | |
| 608 | if ($size) { |
| 609 | flush($fh, \$tarout{$fh}, 10240) |
| 610 | while ($l = length($tarout{$fh})) >= 10240; |
| 611 | while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) { |
| 612 | my $slop = length($tarout{$fh}) % 512; |
| 613 | $tarout{$fh} .= "\0" x (512 - $slop) if $slop; |
| 614 | flush($fh, \$tarout{$fh}, 10240); |
| 615 | $l = length($tarout{$fh}); |
| 616 | } |
| 617 | close IN; |
| 618 | } |
| 619 | } |
| 620 | |
| 621 | sub tflushall { |
| 622 | my $len; |
| 623 | for my $fh (keys %tarout) { |
| 624 | $len = 10240 - length($tarout{$fh}); |
| 625 | $len += 10240 if $len < 1024; |
| 626 | $tarout{$fh} .= "\0" x $len; |
| 627 | flush($fh, \$tarout{$fh}, 10240); |
| 628 | } |
| 629 | } |
| 630 | |
| 631 | END |
| 632 | } |
| 633 | |
| 634 | exit; |
| 635 | |
| 636 | ############################################################################ |
| 637 | |
| 638 | sub tab { |
| 639 | my $tabstring; |
| 640 | |
| 641 | $tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4); |
| 642 | if (!$statdone) { |
| 643 | if ($_ =~ /^(?:name|print|prune|exec|ok|\(|\))/) { |
| 644 | $init{delayedstat} = 1; |
| 645 | } else { |
| 646 | my $statcall = '(($dev,$ino,$mode,$nlink,$uid,$gid) = ' |
| 647 | . $stat . '($_))'; |
| 648 | if (exists $init{saw_or}) { |
| 649 | $tabstring .= "(\$nlink || $statcall) &&\n" . $tabstring; |
| 650 | } else { |
| 651 | $tabstring .= "$statcall &&\n" . $tabstring; |
| 652 | } |
| 653 | $statdone = 1; |
| 654 | $init{declarestat} = 1; |
| 655 | } |
| 656 | } |
| 657 | $tabstring =~ s/^\s+/ / if $out =~ /!$/; |
| 658 | $tabstring; |
| 659 | } |
| 660 | |
| 661 | sub fileglob_to_re { |
| 662 | my $x = shift; |
| 663 | $x =~ s#([./^\$()])#\\$1#g; |
| 664 | $x =~ s#([?*])#.$1#g; |
| 665 | "^$x\$"; |
| 666 | } |
| 667 | |
| 668 | sub n { |
| 669 | my ($pre, $n) = @_; |
| 670 | $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /; |
| 671 | $n =~ s/ 0*(\d)/ $1/; |
| 672 | "($pre $n)"; |
| 673 | } |
| 674 | |
| 675 | sub quote { |
| 676 | my $string = shift; |
| 677 | $string =~ s/'/\\'/g; |
| 678 | "'$string'"; |
| 679 | } |
| 680 | |
| 681 | __END__ |
| 682 | |
| 683 | =head1 NAME |
| 684 | |
| 685 | find2perl - translate find command lines to Perl code |
| 686 | |
| 687 | =head1 SYNOPSIS |
| 688 | |
| 689 | find2perl [paths] [predicates] | perl |
| 690 | |
| 691 | =head1 DESCRIPTION |
| 692 | |
| 693 | find2perl is a little translator to convert find command lines to |
| 694 | equivalent Perl code. The resulting code is typically faster than |
| 695 | running find itself. |
| 696 | |
| 697 | "paths" are a set of paths where find2perl will start its searches and |
| 698 | "predicates" are taken from the following list. |
| 699 | |
| 700 | =over 4 |
| 701 | |
| 702 | =item C<! PREDICATE> |
| 703 | |
| 704 | Negate the sense of the following predicate. The C<!> must be passed as |
| 705 | a distinct argument, so it may need to be surrounded by whitespace and/or |
| 706 | quoted from interpretation by the shell using a backslash (just as with |
| 707 | using C<find(1)>). |
| 708 | |
| 709 | =item C<( PREDICATES )> |
| 710 | |
| 711 | Group the given PREDICATES. The parentheses must be passed as distinct |
| 712 | arguments, so they may need to be surrounded by whitespace and/or |
| 713 | quoted from interpretation by the shell using a backslash (just as with |
| 714 | using C<find(1)>). |
| 715 | |
| 716 | =item C<PREDICATE1 PREDICATE2> |
| 717 | |
| 718 | True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not |
| 719 | evaluated if PREDICATE1 is false. |
| 720 | |
| 721 | =item C<PREDICATE1 -o PREDICATE2> |
| 722 | |
| 723 | True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is |
| 724 | not evaluated if PREDICATE1 is true. |
| 725 | |
| 726 | =item C<-follow> |
| 727 | |
| 728 | Follow (dereference) symlinks. The checking of file attributes depends |
| 729 | on the position of the C<-follow> option. If it precedes the file |
| 730 | check option, an C<stat> is done which means the file check applies to the |
| 731 | file the symbolic link is pointing to. If C<-follow> option follows the |
| 732 | file check option, this now applies to the symbolic link itself, i.e. |
| 733 | an C<lstat> is done. |
| 734 | |
| 735 | =item C<-depth> |
| 736 | |
| 737 | Change directory traversal algorithm from breadth-first to depth-first. |
| 738 | |
| 739 | =item C<-prune> |
| 740 | |
| 741 | Do not descend into the directory currently matched. |
| 742 | |
| 743 | =item C<-xdev> |
| 744 | |
| 745 | Do not traverse mount points (prunes search at mount-point directories). |
| 746 | |
| 747 | =item C<-name GLOB> |
| 748 | |
| 749 | File name matches specified GLOB wildcard pattern. GLOB may need to be |
| 750 | quoted to avoid interpretation by the shell (just as with using |
| 751 | C<find(1)>). |
| 752 | |
| 753 | =item C<-perm PERM> |
| 754 | |
| 755 | Low-order 9 bits of permission match octal value PERM. |
| 756 | |
| 757 | =item C<-perm -PERM> |
| 758 | |
| 759 | The bits specified in PERM are all set in file's permissions. |
| 760 | |
| 761 | =item C<-type X> |
| 762 | |
| 763 | The file's type matches perl's C<-X> operator. |
| 764 | |
| 765 | =item C<-fstype TYPE> |
| 766 | |
| 767 | Filesystem of current path is of type TYPE (only NFS/non-NFS distinction |
| 768 | is implemented). |
| 769 | |
| 770 | =item C<-user USER> |
| 771 | |
| 772 | True if USER is owner of file. |
| 773 | |
| 774 | =item C<-group GROUP> |
| 775 | |
| 776 | True if file's group is GROUP. |
| 777 | |
| 778 | =item C<-nouser> |
| 779 | |
| 780 | True if file's owner is not in password database. |
| 781 | |
| 782 | =item C<-nogroup> |
| 783 | |
| 784 | True if file's group is not in group database. |
| 785 | |
| 786 | =item C<-inum INUM> |
| 787 | |
| 788 | True file's inode number is INUM. |
| 789 | |
| 790 | =item C<-links N> |
| 791 | |
| 792 | True if (hard) link count of file matches N (see below). |
| 793 | |
| 794 | =item C<-size N> |
| 795 | |
| 796 | True if file's size matches N (see below) N is normally counted in |
| 797 | 512-byte blocks, but a suffix of "c" specifies that size should be |
| 798 | counted in characters (bytes) and a suffix of "k" specifes that |
| 799 | size should be counted in 1024-byte blocks. |
| 800 | |
| 801 | =item C<-atime N> |
| 802 | |
| 803 | True if last-access time of file matches N (measured in days) (see |
| 804 | below). |
| 805 | |
| 806 | =item C<-ctime N> |
| 807 | |
| 808 | True if last-changed time of file's inode matches N (measured in days, |
| 809 | see below). |
| 810 | |
| 811 | =item C<-mtime N> |
| 812 | |
| 813 | True if last-modified time of file matches N (measured in days, see below). |
| 814 | |
| 815 | =item C<-newer FILE> |
| 816 | |
| 817 | True if last-modified time of file matches N. |
| 818 | |
| 819 | =item C<-print> |
| 820 | |
| 821 | Print out path of file (always true). |
| 822 | |
| 823 | =item C<-print0> |
| 824 | |
| 825 | Like -print, but terminates with \0 instead of \n. |
| 826 | |
| 827 | =item C<-exec OPTIONS ;> |
| 828 | |
| 829 | exec() the arguments in OPTIONS in a subprocess; any occurence of {} in |
| 830 | OPTIONS will first be substituted with the path of the current |
| 831 | file. Note that the command "rm" has been special-cased to use perl's |
| 832 | unlink() function instead (as an optimization). The C<;> must be passed as |
| 833 | a distinct argument, so it may need to be surrounded by whitespace and/or |
| 834 | quoted from interpretation by the shell using a backslash (just as with |
| 835 | using C<find(1)>). |
| 836 | |
| 837 | =item C<-ok OPTIONS ;> |
| 838 | |
| 839 | Like -exec, but first prompts user; if user's response does not begin |
| 840 | with a y, skip the exec. The C<;> must be passed as |
| 841 | a distinct argument, so it may need to be surrounded by whitespace and/or |
| 842 | quoted from interpretation by the shell using a backslash (just as with |
| 843 | using C<find(1)>). |
| 844 | |
| 845 | =item C<-eval EXPR ;> |
| 846 | |
| 847 | Has the perl script eval() the EXPR. The C<;> must be passed as |
| 848 | a distinct argument, so it may need to be surrounded by whitespace and/or |
| 849 | quoted from interpretation by the shell using a backslash (just as with |
| 850 | using C<find(1)>). |
| 851 | |
| 852 | =item C<-ls> |
| 853 | |
| 854 | Simulates C<-exec ls -dils {} ;> |
| 855 | |
| 856 | =item C<-tar FILE> |
| 857 | |
| 858 | Adds current output to tar-format FILE. |
| 859 | |
| 860 | =item C<-cpio FILE> |
| 861 | |
| 862 | Adds current output to old-style cpio-format FILE. |
| 863 | |
| 864 | =item C<-ncpio FILE> |
| 865 | |
| 866 | Adds current output to "new"-style cpio-format FILE. |
| 867 | |
| 868 | =back |
| 869 | |
| 870 | Predicates which take a numeric argument N can come in three forms: |
| 871 | |
| 872 | * N is prefixed with a +: match values greater than N |
| 873 | * N is prefixed with a -: match values less than N |
| 874 | * N is not prefixed with either + or -: match only values equal to N |
| 875 | |
| 876 | =head1 SEE ALSO |
| 877 | |
| 878 | find |
| 879 | |
| 880 | =cut |
| 881 | !NO!SUBS! |
| 882 | |
| 883 | close OUT or die "Can't close $file: $!"; |
| 884 | chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; |
| 885 | exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; |
| 886 | chdir $origdir; |