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