4 use File::Basename qw(&basename &dirname);
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
12 # to ensure Configure will look for $Config{startperl}.
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.
18 $file = basename($0, '.PL');
19 $file .= '.com' if $^O eq 'VMS';
21 open OUT,">$file" or die "Can't create $file: $!";
23 print "Extracting $file (with variable substitutions)\n";
25 # In this section, perl variables will be expanded during extraction.
26 # You can use $Config{...} to use Configure variables.
28 print OUT <<"!GROK!THIS!";
30 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
31 if \$running_under_some_shell;
32 my \$perlpath = '$Config{perlpath}';
35 # In the following, perl variables are not expanded during extraction.
37 print OUT <<'!NO!SUBS!';
39 use vars qw/$statdone/;
40 use File::Spec::Functions 'curdir';
41 my $startperl = "#! $perlpath -w";
44 # Modified September 26, 1993 to provide proper handling of years after 1999
45 # Tom Link <tml+@pitt.edu>
46 # University of Pittsburgh
48 # Modified April 7, 1998 with nasty hacks to implement the troublesome -follow
49 # Billy Constantine <wdconsta@cs.adelaide.edu.au> <billy@smug.adelaide.edu.au>
50 # University of Adelaide, Adelaide, South Australia
52 # Modified 1999-06-10, 1999-07-07 to migrate to cleaner perl5 usage
53 # Ken Pizzini <ken@halcyon.com>
55 # Modified 2000-01-28 to use the 'follow' option of File::Find
58 while ($ARGV[0] =~ /^[^-!(]/) {
61 @roots = (curdir()) unless @roots;
62 for (@roots) { $_ = "e($_) }
63 my $roots = join(', ', @roots);
74 my ($follow_in_effect,$Skip_And) = (0,0);
78 s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
86 } elsif ($_ eq 'follow') {
93 } elsif ($_ eq 'name') {
94 $out .= &tab . '/' . &fileglob_to_re(shift) . "/s";
95 } elsif ($_ eq 'perm') {
98 || die "Malformed -perm argument: $onum\n";
100 if ($onum =~ s/^-//) {
101 $onum = sprintf("0%o", oct($onum) & 07777);
102 $out .= "((\$mode & $onum) == $onum)";
105 $out .= "((\$mode & 0777) == $onum)";
107 } elsif ($_ eq 'type') {
108 (my $filetest = shift) =~ tr/s/S/;
109 $out .= &tab . "-$filetest _";
110 } elsif ($_ eq 'print') {
111 $out .= &tab . 'print("$name\n")';
112 } elsif ($_ eq 'print0') {
113 $out .= &tab . 'print("$name\0")';
114 } elsif ($_ eq 'fstype') {
117 if ($type eq 'nfs') {
118 $out .= '($dev < 0)';
120 $out .= '($dev >= 0)'; #XXX
122 } elsif ($_ eq 'user') {
124 $out .= &tab . "(\$uid == \$uid{'$uname'})";
126 } elsif ($_ eq 'group') {
128 $out .= &tab . "(\$gid == \$gid{'$gname'})";
130 } elsif ($_ eq 'nouser') {
131 $out .= &tab . '!exists $uid{$uid}';
133 } elsif ($_ eq 'nogroup') {
134 $out .= &tab . '!exists $gid{$gid}';
136 } elsif ($_ eq 'links') {
137 $out .= &tab . &n('$nlink', shift);
138 } elsif ($_ eq 'inum') {
139 $out .= &tab . &n('$ino', shift);
140 } elsif ($_ eq 'size') {
142 my $n = 'int(((-s _) + 511) / 512)';
146 $n = 'int(((-s _) + 1023) / 1024)';
148 $out .= &tab . &n($n, $_);
149 } elsif ($_ eq 'atime') {
150 $out .= &tab . &n('int(-A _)', shift);
151 } elsif ($_ eq 'mtime') {
152 $out .= &tab . &n('int(-M _)', shift);
153 } elsif ($_ eq 'ctime') {
154 $out .= &tab . &n('int(-C _)', shift);
155 } elsif ($_ eq 'exec') {
157 while (@ARGV && $ARGV[0] ne ';')
158 { push(@cmd, shift) }
161 if ($cmd[0] =~m#^(?:(?:/usr)?/bin/)?rm$#
162 && $cmd[$#cmd] eq '{}'
163 && (@cmd == 2 || (@cmd == 3 && $cmd[1] eq '-f'))) {
165 $out .= '(unlink($_) || warn "$name: $!\n")';
167 $out .= 'unlink($_)';
169 $out .= '(unlink($_) || 1)';
174 { local $" = "','"; $out .= "&doexec(0, '@cmd')"; }
177 } elsif ($_ eq 'ok') {
179 while (@ARGV && $ARGV[0] ne ';')
180 { push(@cmd, shift) }
185 { local $" = "','"; $out .= "&doexec(0, '@cmd')"; }
187 } elsif ($_ eq 'prune') {
188 $out .= &tab . '($File::Find::prune = 1)';
189 } elsif ($_ eq 'xdev') {
190 $out .= &tab . '!($File::Find::prune |= ($dev != $File::Find::topdev))'
192 } elsif ($_ eq 'newer') {
194 my $newername = 'AGE_OF' . $file;
195 $newername =~ s/\W/_/g;
196 $newername = '$' . $newername;
197 $out .= &tab . "(-M _ < $newername)";
198 $initnewer .= "my $newername = -M " . "e($file) . ";\n";
199 } elsif ($_ eq 'eval') {
202 $out .= &tab . "eval {$prog}";
203 } elsif ($_ eq 'depth') {
206 } elsif ($_ eq 'ls') {
207 $out .= &tab . "&ls";
209 } elsif ($_ eq 'tar') {
210 die "-tar must have a filename argument\n" unless @ARGV;
212 my $fh = 'FH' . $file;
214 $out .= &tab . "&tar(*$fh, \$name)";
215 $flushall .= "&tflushall;\n";
216 $initfile .= "open($fh, " . "e('> ' . $file) .
217 qq{) || die "Can't open $fh: \$!\\n";\n};
219 } elsif (/^(n?)cpio\z/) {
220 die "-$_ must have a filename argument\n" unless @ARGV;
222 my $fh = 'FH' . $file;
224 $out .= &tab . "&cpio(*$fh, \$name, '$1')";
226 $flushall .= "&cflushall;\n";
227 $initfile .= "open($fh, " . "e('> ' . $file) .
228 qq{) || die "Can't open $fh: \$!\\n";\n};
231 die "Unrecognized switch: -$_\n";
235 if ($ARGV[0] eq '-o') {
236 { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; }
237 $statdone = 0 if $indent_depth == 1 && exists $init{delayedstat};
241 $out .= " &&" unless $Skip_And || $ARGV[0] eq ')';
243 shift if $ARGV[0] eq '-a';
251 eval 'exec $perlpath -S \$0 \${1+"\$@"}'
252 if 0; #\$running_under_some_shell
257 # Set the variable \$File::Find::dont_use_nlink if you're using AFS,
260 # for the convenience of &wanted calls, including -eval statements:
261 use vars qw/*name *dir *prune/;
262 *name = *File::Find::name;
263 *dir = *File::Find::dir;
264 *prune = *File::Find::prune;
269 if (exists $init{ls}) {
271 my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx);
272 my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
277 if (exists $init{user} || exists $init{ls} || exists $init{tar}) {
278 print "my (%uid, %user);\n";
279 print "while (my (\$name, \$pw, \$uid) = getpwent) {\n";
280 print ' $uid{$name} = $uid{$uid} = $uid;', "\n"
281 if exists $init{user};
282 print ' $user{$uid} = $name unless exists $user{$uid};', "\n"
283 if exists $init{ls} || exists $init{tar};
287 if (exists $init{group} || exists $init{ls} || exists $init{tar}) {
288 print "my (%gid, %group);\n";
289 print "while (my (\$name, \$pw, \$gid) = getgrent) {\n";
290 print ' $gid{$name} = $gid{$gid} = $gid;', "\n"
291 if exists $init{group};
292 print ' $group{$gid} = $name unless exists $group{$gid};', "\n"
293 if exists $init{ls} || exists $init{tar};
297 print $initnewer, "\n" if $initnewer ne '';
298 print $initfile, "\n" if $initfile ne '';
299 $flushall .= "exit;\n";
300 if (exists $init{declarestat}) {
301 $out = <<'END' . $out;
302 my ($dev,$ino,$mode,$nlink,$uid,$gid);
307 if ( $follow_in_effect ) {
308 $out =~ s/lstat\(\$_\)/lstat(_)/;
311 # Traverse desired filesystems
312 File::Find::$find( {wanted => \\&wanted, follow => 1}, $roots);
323 # Traverse desired filesystems
324 File::Find::$find({wanted => \\&wanted}, $roots);
334 if (exists $init{doexec}) {
338 my $cwd = Cwd::cwd();
343 { $word =~ s#{}#$name#g }
345 my $old = select(STDOUT);
349 return 0 unless <STDIN> =~ /^y/;
353 chdir $File::Find::dir;
360 if (exists $init{ls}) {
361 print <<'INTRO', <<"SUB", <<'END';
365 sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
369 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
371 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
376 or $blocks = int(($size + 1023) / 1024);
378 my $perms = $rwx[$mode & 7];
380 $perms = $rwx[$mode & 7] . $perms;
382 $perms = $rwx[$mode & 7] . $perms;
383 substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _;
384 substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _;
385 substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _;
386 if (-f _) { $perms = '-' . $perms; }
387 elsif (-d _) { $perms = 'd' . $perms; }
388 elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); }
389 elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); }
390 elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); }
391 elsif (-p _) { $perms = 'p' . $perms; }
392 elsif (-S _) { $perms = 's' . $perms; }
393 else { $perms = '?' . $perms; }
395 my $user = $user{$uid} || $uid;
396 my $group = $group{$gid} || $gid;
398 my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime);
399 if (-M _ > 365.25 / 2) {
402 $timeyear = sprintf("%02d:%02d", $hour, $min);
405 printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n",
424 if (exists $init{cpio} || exists $init{tar}) {
430 my ($fh, $varref, $blksz) = @_;
432 while (length($$varref) >= $blksz) {
434 syswrite($fh, $$varref, $blksz);
435 substr($$varref, 0, $blksz) = '';
444 if (exists $init{cpio}) {
445 print <<'INTRO', <<"SUB", <<'END';
451 my ($fh, $fname, $nc) = @_;
453 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
454 $atime,$mtime,$ctime,$blksize,$blocks);
457 if ( ! defined $fname ) {
458 $fname = 'TRAILER!!!';
459 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
460 $atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13;
462 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
464 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
467 open(IN, "./$_\0") || do {
468 warn "Couldn't open $fname: $!\n";
472 $text = readlink($_);
473 $size = 0 unless defined $text;
481 sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
495 $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
496 $cpout{$fh} .= pack("SSSSSSSSLSLa*",
497 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
498 length($fname)+1, $size,
499 $fname . (length($fname) & 1 ? "\0" : "\0\0"));
503 $cpout{$fh} .= $text;
506 flush($fh, \$cpout{$fh}, 5120)
507 while ($l = length($cpout{$fh})) >= 5120;
508 while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
509 flush($fh, \$cpout{$fh}, 5120);
510 $l = length($cpout{$fh});
517 for my $fh (keys %cpout) {
518 &cpio($fh, undef, $nc{$fh});
519 $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
520 flush($fh, \$cpout{$fh}, 5120);
521 print $blocks{$fh} * 10, " blocks\n";
528 if (exists $init{tar}) {
529 print <<'INTRO', <<"SUB", <<'END';
535 my ($fh, $fname) = @_;
539 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
541 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
546 if ($linkname = $linkseen{$fh, $dev, $ino}) {
547 if (length($linkname) > 100) {
548 warn "$0: omitting file with linkname ",
549 "too long for tar output: $linkname\n";
555 $linkseen{$fh, $dev, $ino} = $fname;
558 if ($typeflag eq '0') {
560 open(IN, "./$_\0") || do {
561 warn "Couldn't open $fname: $!\n";
565 $linkname = readlink($_);
566 if (defined $linkname) { $typeflag = '2' }
567 elsif (-c _) { $typeflag = '3' }
568 elsif (-b _) { $typeflag = '4' }
569 elsif (-d _) { $typeflag = '5' }
570 elsif (-p _) { $typeflag = '6' }
574 if (length($fname) > 100) {
575 ($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#);
576 if (!defined($fname) || length($prefix) > 155) {
577 warn "$0: omitting file with name too long for tar output: ",
583 $size = 0 if $typeflag ne '0';
584 my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155",
586 sprintf("%7o ", $mode & 0777),
587 sprintf("%7o ", $uid & 0777777),
588 sprintf("%7o ", $gid & 0777777),
589 sprintf("%11o ", $size),
590 sprintf("%11o ", $mtime),
593 defined $linkname ? $linkname : '',
602 substr($header, 148, 8) = sprintf("%7o ", unpack("%16C*", $header));
603 my $l = length($header) % 512;
604 $tarout{$fh} .= $header;
605 $tarout{$fh} .= "\0" x (512 - $l) if $l;
608 flush($fh, \$tarout{$fh}, 10240)
609 while ($l = length($tarout{$fh})) >= 10240;
610 while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
611 my $slop = length($tarout{$fh}) % 512;
612 $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
613 flush($fh, \$tarout{$fh}, 10240);
614 $l = length($tarout{$fh});
622 for my $fh (keys %tarout) {
623 $len = 10240 - length($tarout{$fh});
624 $len += 10240 if $len < 1024;
625 $tarout{$fh} .= "\0" x $len;
626 flush($fh, \$tarout{$fh}, 10240);
635 ############################################################################
640 $tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4);
642 if ($_ =~ /^(?:name|print|prune|exec|ok|\(|\))/) {
643 $init{delayedstat} = 1;
645 my $statcall = '(($dev,$ino,$mode,$nlink,$uid,$gid) = '
647 if (exists $init{saw_or}) {
648 $tabstring .= "(\$nlink || $statcall) &&\n" . $tabstring;
650 $tabstring .= "$statcall &&\n" . $tabstring;
653 $init{declarestat} = 1;
656 $tabstring =~ s/^\s+/ / if $out =~ /!$/;
662 $x =~ s#([./^\$()])#\\$1#g;
663 $x =~ s#([?*])#.$1#g;
669 $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
670 $n =~ s/ 0*(\d)/ $1/;
676 $string =~ s/\\/\\\\/g;
677 $string =~ s/'/\\'/g;
685 find2perl - translate find command lines to Perl code
689 find2perl [paths] [predicates] | perl
693 find2perl is a little translator to convert find command lines to
694 equivalent Perl code. The resulting code is typically faster than
697 "paths" are a set of paths where find2perl will start its searches and
698 "predicates" are taken from the following list.
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
709 =item C<( PREDICATES )>
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
716 =item C<PREDICATE1 PREDICATE2>
718 True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not
719 evaluated if PREDICATE1 is false.
721 =item C<PREDICATE1 -o PREDICATE2>
723 True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is
724 not evaluated if PREDICATE1 is true.
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.
737 Change directory traversal algorithm from breadth-first to depth-first.
741 Do not descend into the directory currently matched.
745 Do not traverse mount points (prunes search at mount-point directories).
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
755 Low-order 9 bits of permission match octal value PERM.
759 The bits specified in PERM are all set in file's permissions.
763 The file's type matches perl's C<-X> operator.
765 =item C<-fstype TYPE>
767 Filesystem of current path is of type TYPE (only NFS/non-NFS distinction
772 True if USER is owner of file.
774 =item C<-group GROUP>
776 True if file's group is GROUP.
780 True if file's owner is not in password database.
784 True if file's group is not in group database.
788 True file's inode number is INUM.
792 True if (hard) link count of file matches N (see below).
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.
803 True if last-access time of file matches N (measured in days) (see
808 True if last-changed time of file's inode matches N (measured in days,
813 True if last-modified time of file matches N (measured in days, see below).
817 True if last-modified time of file matches N.
821 Print out path of file (always true).
825 Like -print, but terminates with \0 instead of \n.
827 =item C<-exec OPTIONS ;>
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
837 =item C<-ok OPTIONS ;>
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
847 Has the perl script eval() the EXPR.
851 Simulates C<-exec ls -dils {} ;>
855 Adds current output to tar-format FILE.
859 Adds current output to old-style cpio-format FILE.
863 Adds current output to "new"-style cpio-format FILE.
867 Predicates which take a numeric argument N can come in three forms:
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
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 ':';