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