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