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) . "/s"; |
---|
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\z//) { |
---|
143 | $n = 'int(-s _)'; |
---|
144 | } elsif (s/k\z//) { |
---|
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\z/) { |
---|
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\\z"; |
---|
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. |
---|
848 | |
---|
849 | =item C<-ls> |
---|
850 | |
---|
851 | Simulates C<-exec ls -dils {} ;> |
---|
852 | |
---|
853 | =item C<-tar FILE> |
---|
854 | |
---|
855 | Adds current output to tar-format FILE. |
---|
856 | |
---|
857 | =item C<-cpio FILE> |
---|
858 | |
---|
859 | Adds current output to old-style cpio-format FILE. |
---|
860 | |
---|
861 | =item C<-ncpio FILE> |
---|
862 | |
---|
863 | Adds current output to "new"-style cpio-format FILE. |
---|
864 | |
---|
865 | =back |
---|
866 | |
---|
867 | Predicates which take a numeric argument N can come in three forms: |
---|
868 | |
---|
869 | * N is prefixed with a +: match values greater than N |
---|
870 | * N is prefixed with a -: match values less than N |
---|
871 | * N is not prefixed with either + or -: match only values equal to N |
---|
872 | |
---|
873 | =head1 SEE ALSO |
---|
874 | |
---|
875 | find |
---|
876 | |
---|
877 | =cut |
---|
878 | !NO!SUBS! |
---|
879 | |
---|
880 | close OUT or die "Can't close $file: $!"; |
---|
881 | chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; |
---|
882 | exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; |
---|
883 | chdir $origdir; |
---|