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}) {
339 my $cwd = Cwd::cwd();
345 { $word =~ s#{}#$name#g }
347 my $old = select(STDOUT);
351 return 0 unless <STDIN> =~ /^y/;
355 chdir $File::Find::dir;
362 if (exists $init{ls}) {
363 print <<'INTRO', <<"SUB", <<'END';
367 sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
371 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
373 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
378 or $blocks = int(($size + 1023) / 1024);
380 my $perms = $rwx[$mode & 7];
382 $perms = $rwx[$mode & 7] . $perms;
384 $perms = $rwx[$mode & 7] . $perms;
385 substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _;
386 substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _;
387 substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _;
388 if (-f _) { $perms = '-' . $perms; }
389 elsif (-d _) { $perms = 'd' . $perms; }
390 elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); }
391 elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); }
392 elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); }
393 elsif (-p _) { $perms = 'p' . $perms; }
394 elsif (-S _) { $perms = 's' . $perms; }
395 else { $perms = '?' . $perms; }
397 my $user = $user{$uid} || $uid;
398 my $group = $group{$gid} || $gid;
400 my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime);
401 if (-M _ > 365.25 / 2) {
404 $timeyear = sprintf("%02d:%02d", $hour, $min);
407 printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n",
426 if (exists $init{cpio} || exists $init{tar}) {
432 my ($fh, $varref, $blksz) = @_;
434 while (length($$varref) >= $blksz) {
436 syswrite($fh, $$varref, $blksz);
437 substr($$varref, 0, $blksz) = '';
446 if (exists $init{cpio}) {
447 print <<'INTRO', <<"SUB", <<'END';
453 my ($fh, $fname, $nc) = @_;
455 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
456 $atime,$mtime,$ctime,$blksize,$blocks);
459 if ( ! defined $fname ) {
460 $fname = 'TRAILER!!!';
461 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
462 $atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13;
464 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
466 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
469 open(IN, "./$_\0") || do {
470 warn "Couldn't open $fname: $!\n";
474 $text = readlink($_);
475 $size = 0 unless defined $text;
483 sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
497 $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
498 $cpout{$fh} .= pack("SSSSSSSSLSLa*",
499 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
500 length($fname)+1, $size,
501 $fname . (length($fname) & 1 ? "\0" : "\0\0"));
505 $cpout{$fh} .= $text;
508 flush($fh, \$cpout{$fh}, 5120)
509 while ($l = length($cpout{$fh})) >= 5120;
510 while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
511 flush($fh, \$cpout{$fh}, 5120);
512 $l = length($cpout{$fh});
519 for my $fh (keys %cpout) {
520 &cpio($fh, undef, $nc{$fh});
521 $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
522 flush($fh, \$cpout{$fh}, 5120);
523 print $blocks{$fh} * 10, " blocks\n";
530 if (exists $init{tar}) {
531 print <<'INTRO', <<"SUB", <<'END';
537 my ($fh, $fname) = @_;
541 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
543 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
548 if ($linkname = $linkseen{$fh, $dev, $ino}) {
549 if (length($linkname) > 100) {
550 warn "$0: omitting file with linkname ",
551 "too long for tar output: $linkname\n";
557 $linkseen{$fh, $dev, $ino} = $fname;
560 if ($typeflag eq '0') {
562 open(IN, "./$_\0") || do {
563 warn "Couldn't open $fname: $!\n";
567 $linkname = readlink($_);
568 if (defined $linkname) { $typeflag = '2' }
569 elsif (-c _) { $typeflag = '3' }
570 elsif (-b _) { $typeflag = '4' }
571 elsif (-d _) { $typeflag = '5' }
572 elsif (-p _) { $typeflag = '6' }
576 if (length($fname) > 100) {
577 ($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#);
578 if (!defined($fname) || length($prefix) > 155) {
579 warn "$0: omitting file with name too long for tar output: ",
585 $size = 0 if $typeflag ne '0';
586 my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155",
588 sprintf("%7o ", $mode & 0777),
589 sprintf("%7o ", $uid & 0777777),
590 sprintf("%7o ", $gid & 0777777),
591 sprintf("%11o ", $size),
592 sprintf("%11o ", $mtime),
595 defined $linkname ? $linkname : '',
604 substr($header, 148, 8) = sprintf("%7o ", unpack("%16C*", $header));
605 my $l = length($header) % 512;
606 $tarout{$fh} .= $header;
607 $tarout{$fh} .= "\0" x (512 - $l) if $l;
610 flush($fh, \$tarout{$fh}, 10240)
611 while ($l = length($tarout{$fh})) >= 10240;
612 while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
613 my $slop = length($tarout{$fh}) % 512;
614 $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
615 flush($fh, \$tarout{$fh}, 10240);
616 $l = length($tarout{$fh});
624 for my $fh (keys %tarout) {
625 $len = 10240 - length($tarout{$fh});
626 $len += 10240 if $len < 1024;
627 $tarout{$fh} .= "\0" x $len;
628 flush($fh, \$tarout{$fh}, 10240);
637 ############################################################################
642 $tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4);
644 if ($_ =~ /^(?:name|print|prune|exec|ok|\(|\))/) {
645 $init{delayedstat} = 1;
647 my $statcall = '(($dev,$ino,$mode,$nlink,$uid,$gid) = '
649 if (exists $init{saw_or}) {
650 $tabstring .= "(\$nlink || $statcall) &&\n" . $tabstring;
652 $tabstring .= "$statcall &&\n" . $tabstring;
655 $init{declarestat} = 1;
658 $tabstring =~ s/^\s+/ / if $out =~ /!$/;
664 $x =~ s#([./^\$()])#\\$1#g;
665 $x =~ s#([?*])#.$1#g;
671 $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
672 $n =~ s/ 0*(\d)/ $1/;
678 $string =~ s/\\/\\\\/g;
679 $string =~ s/'/\\'/g;
687 find2perl - translate find command lines to Perl code
691 find2perl [paths] [predicates] | perl
695 find2perl is a little translator to convert find command lines to
696 equivalent Perl code. The resulting code is typically faster than
699 "paths" are a set of paths where find2perl will start its searches and
700 "predicates" are taken from the following list.
706 Negate the sense of the following predicate. The C<!> must be passed as
707 a distinct argument, so it may need to be surrounded by whitespace and/or
708 quoted from interpretation by the shell using a backslash (just as with
711 =item C<( PREDICATES )>
713 Group the given PREDICATES. The parentheses must be passed as distinct
714 arguments, so they may need to be surrounded by whitespace and/or
715 quoted from interpretation by the shell using a backslash (just as with
718 =item C<PREDICATE1 PREDICATE2>
720 True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not
721 evaluated if PREDICATE1 is false.
723 =item C<PREDICATE1 -o PREDICATE2>
725 True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is
726 not evaluated if PREDICATE1 is true.
730 Follow (dereference) symlinks. The checking of file attributes depends
731 on the position of the C<-follow> option. If it precedes the file
732 check option, an C<stat> is done which means the file check applies to the
733 file the symbolic link is pointing to. If C<-follow> option follows the
734 file check option, this now applies to the symbolic link itself, i.e.
739 Change directory traversal algorithm from breadth-first to depth-first.
743 Do not descend into the directory currently matched.
747 Do not traverse mount points (prunes search at mount-point directories).
751 File name matches specified GLOB wildcard pattern. GLOB may need to be
752 quoted to avoid interpretation by the shell (just as with using
757 Low-order 9 bits of permission match octal value PERM.
761 The bits specified in PERM are all set in file's permissions.
765 The file's type matches perl's C<-X> operator.
767 =item C<-fstype TYPE>
769 Filesystem of current path is of type TYPE (only NFS/non-NFS distinction
774 True if USER is owner of file.
776 =item C<-group GROUP>
778 True if file's group is GROUP.
782 True if file's owner is not in password database.
786 True if file's group is not in group database.
790 True file's inode number is INUM.
794 True if (hard) link count of file matches N (see below).
798 True if file's size matches N (see below) N is normally counted in
799 512-byte blocks, but a suffix of "c" specifies that size should be
800 counted in characters (bytes) and a suffix of "k" specifes that
801 size should be counted in 1024-byte blocks.
805 True if last-access time of file matches N (measured in days) (see
810 True if last-changed time of file's inode matches N (measured in days,
815 True if last-modified time of file matches N (measured in days, see below).
819 True if last-modified time of file matches N.
823 Print out path of file (always true).
827 Like -print, but terminates with \0 instead of \n.
829 =item C<-exec OPTIONS ;>
831 exec() the arguments in OPTIONS in a subprocess; any occurence of {} in
832 OPTIONS will first be substituted with the path of the current
833 file. Note that the command "rm" has been special-cased to use perl's
834 unlink() function instead (as an optimization). The C<;> must be passed as
835 a distinct argument, so it may need to be surrounded by whitespace and/or
836 quoted from interpretation by the shell using a backslash (just as with
839 =item C<-ok OPTIONS ;>
841 Like -exec, but first prompts user; if user's response does not begin
842 with a y, skip the exec. The C<;> must be passed as
843 a distinct argument, so it may need to be surrounded by whitespace and/or
844 quoted from interpretation by the shell using a backslash (just as with
849 Has the perl script eval() the EXPR.
853 Simulates C<-exec ls -dils {} ;>
857 Adds current output to tar-format FILE.
861 Adds current output to old-style cpio-format FILE.
865 Adds current output to "new"-style cpio-format FILE.
869 Predicates which take a numeric argument N can come in three forms:
871 * N is prefixed with a +: match values greater than N
872 * N is prefixed with a -: match values less than N
873 * N is not prefixed with either + or -: match only values equal to N
882 close OUT or die "Can't close $file: $!";
883 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
884 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';