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