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 = <<'/../') =~ s/\\s*\\z//;
37 # In the following, perl variables are not expanded during extraction.
39 print OUT <<'!NO!SUBS!';
41 use vars qw/$statdone/;
42 use File::Spec::Functions 'curdir';
43 my $startperl = "#! $perlpath -w";
47 sub fileglob_to_re ($);
51 while ($ARGV[0] =~ /^[^-!(]/) {
54 @roots = (curdir()) unless @roots;
55 for (@roots) { $_ = quote($_) }
56 my $roots = join(', ', @roots);
66 my $declaresubs = "sub wanted;\n";
68 my ($follow_in_effect,$Skip_And) = (0,0);
73 s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
81 } elsif ($_ eq 'follow') {
88 } elsif (/^(i)?name$/) {
89 $out .= tab . '/' . fileglob_to_re(shift) . "/s$1";
90 } elsif (/^(i)?path$/) {
91 $out .= tab . '$File::Find::name =~ /' . fileglob_to_re(shift) . "/s$1";
92 } elsif ($_ eq 'perm') {
95 || die "Malformed -perm argument: $onum\n";
97 if ($onum =~ s/^-//) {
98 $onum = sprintf("0%o", oct($onum) & 07777);
99 $out .= "((\$mode & $onum) == $onum)";
102 $out .= "((\$mode & 0777) == $onum)";
104 } elsif ($_ eq 'type') {
105 (my $filetest = shift) =~ tr/s/S/;
106 $out .= tab . "-$filetest _";
107 } elsif ($_ eq 'print') {
108 $out .= tab . 'print("$name\n")';
110 } elsif ($_ eq 'print0') {
111 $out .= tab . 'print("$name\0")';
113 } elsif ($_ eq 'fstype') {
116 if ($type eq 'nfs') {
117 $out .= '($dev < 0)';
119 $out .= '($dev >= 0)'; #XXX
121 } elsif ($_ eq 'user') {
123 $out .= tab . "(\$uid == \$uid{'$uname'})";
125 } elsif ($_ eq 'group') {
127 $out .= tab . "(\$gid == \$gid{'$gname'})";
129 } elsif ($_ eq 'nouser') {
130 $out .= tab . '!exists $uid{$uid}';
132 } elsif ($_ eq 'nogroup') {
133 $out .= tab . '!exists $gid{$gid}';
135 } elsif ($_ eq 'links') {
136 $out .= tab . n('$nlink', shift);
137 } elsif ($_ eq 'inum') {
138 $out .= tab . n('$ino', shift);
139 } elsif ($_ eq 'size') {
141 my $n = 'int(((-s _) + 511) / 512)';
145 $n = 'int(((-s _) + 1023) / 1024)';
147 $out .= tab . n($n, $_);
148 } elsif ($_ eq 'atime') {
149 $out .= tab . n('int(-A _)', shift);
150 } elsif ($_ eq 'mtime') {
151 $out .= tab . n('int(-M _)', shift);
152 } elsif ($_ eq 'ctime') {
153 $out .= tab . n('int(-C _)', shift);
154 } elsif ($_ eq 'exec') {
156 while (@ARGV && $ARGV[0] ne ';')
157 { push(@cmd, shift) }
160 if ($cmd[0] =~m#^(?:(?:/usr)?/bin/)?rm$#
161 && $cmd[$#cmd] eq '{}'
162 && (@cmd == 2 || (@cmd == 3 && $cmd[1] eq '-f'))) {
164 $out .= '(unlink($_) || warn "$name: $!\n")';
166 $out .= 'unlink($_)';
168 $out .= '(unlink($_) || 1)';
173 { local $" = "','"; $out .= "doexec(0, '@cmd')"; }
174 $declaresubs .= "sub doexec (\$\@);\n";
178 } elsif ($_ eq 'ok') {
180 while (@ARGV && $ARGV[0] ne ';')
181 { push(@cmd, shift) }
186 { local $" = "','"; $out .= "doexec(1, '@cmd')"; }
187 $declaresubs .= "sub doexec (\$\@);\n";
190 } elsif ($_ eq 'prune') {
191 $out .= tab . '($File::Find::prune = 1)';
192 } elsif ($_ eq 'xdev') {
193 $out .= tab . '!($File::Find::prune |= ($dev != $File::Find::topdev))'
195 } elsif ($_ eq 'newer') {
197 my $newername = 'AGE_OF' . $file;
198 $newername =~ s/\W/_/g;
199 $newername = '$' . $newername;
200 $out .= tab . "(-M _ < $newername)";
201 $initnewer .= "my $newername = -M " . quote($file) . ";\n";
202 } elsif ($_ eq 'eval') {
205 $out .= tab . "eval {$prog}";
207 } elsif ($_ eq 'depth') {
210 } elsif ($_ eq 'ls') {
212 $declaresubs .= "sub ls ();\n";
215 } elsif ($_ eq 'tar') {
216 die "-tar must have a filename argument\n" unless @ARGV;
218 my $fh = 'FH' . $file;
220 $out .= tab . "tar(*$fh, \$name)";
221 $flushall .= "tflushall;\n";
222 $declaresubs .= "sub tar;\nsub tflushall ();\n";
223 $initfile .= "open($fh, " . quote('> ' . $file) .
224 qq{) || die "Can't open $fh: \$!\\n";\n};
226 } elsif (/^(n?)cpio\z/) {
227 die "-$_ must have a filename argument\n" unless @ARGV;
229 my $fh = 'FH' . $file;
231 $out .= tab . "cpio(*$fh, \$name, '$1')";
233 $flushall .= "cflushall;\n";
234 $declaresubs .= "sub cpio;\nsub cflushall ();\n";
235 $initfile .= "open($fh, " . quote('> ' . $file) .
236 qq{) || die "Can't open $fh: \$!\\n";\n};
239 die "Unrecognized switch: -$_\n";
243 if ($ARGV[0] eq '-o') {
244 { local($statdone) = 1; $out .= "\n" . tab . "||\n"; }
245 $statdone = 0 if $indent_depth == 1 && exists $init{delayedstat};
249 $out .= " &&" unless $Skip_And || $ARGV[0] eq ')';
251 shift if $ARGV[0] eq '-a';
258 if ($t !~ /&&\s*$/) { $t .= '&& ' }
259 $out .= "\n" . $t . 'print("$name\n")';
265 eval 'exec $perlpath -S \$0 \${1+"\$@"}'
266 if 0; #\$running_under_some_shell
271 # Set the variable \$File::Find::dont_use_nlink if you're using AFS,
274 # for the convenience of &wanted calls, including -eval statements:
275 use vars qw/*name *dir *prune/;
276 *name = *File::Find::name;
277 *dir = *File::Find::dir;
278 *prune = *File::Find::prune;
284 if (exists $init{doexec}) {
287 my $cwd = Cwd::cwd();
292 if (exists $init{ls}) {
294 my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx);
295 my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
300 if (exists $init{user} || exists $init{ls} || exists $init{tar}) {
301 print "my (%uid, %user);\n";
302 print "while (my (\$name, \$pw, \$uid) = getpwent) {\n";
303 print ' $uid{$name} = $uid{$uid} = $uid;', "\n"
304 if exists $init{user};
305 print ' $user{$uid} = $name unless exists $user{$uid};', "\n"
306 if exists $init{ls} || exists $init{tar};
310 if (exists $init{group} || exists $init{ls} || exists $init{tar}) {
311 print "my (%gid, %group);\n";
312 print "while (my (\$name, \$pw, \$gid) = getgrent) {\n";
313 print ' $gid{$name} = $gid{$gid} = $gid;', "\n"
314 if exists $init{group};
315 print ' $group{$gid} = $name unless exists $group{$gid};', "\n"
316 if exists $init{ls} || exists $init{tar};
320 print $initnewer, "\n" if $initnewer ne '';
321 print $initfile, "\n" if $initfile ne '';
322 $flushall .= "exit;\n";
323 if (exists $init{declarestat}) {
324 $out = <<'END' . $out;
325 my ($dev,$ino,$mode,$nlink,$uid,$gid);
330 if ( $follow_in_effect ) {
331 $out =~ s/lstat\(\$_\)/lstat(_)/;
334 # Traverse desired filesystems
335 File::Find::$find( {wanted => \\&wanted, follow => 1}, $roots);
346 # Traverse desired filesystems
347 File::Find::$find({wanted => \\&wanted}, $roots);
357 if (exists $init{doexec}) {
362 my @command = @_; # copy so we don't try to s/// aliases to constants
363 for my $word (@command)
364 { $word =~ s#{}#$name#g }
366 my $old = select(STDOUT);
370 return 0 unless <STDIN> =~ /^y/;
374 chdir $File::Find::dir;
381 if (exists $init{ls}) {
382 print <<'INTRO', <<"SUB", <<'END';
386 sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
390 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
392 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
397 or $blocks = int(($size + 1023) / 1024);
399 my $perms = $rwx[$mode & 7];
401 $perms = $rwx[$mode & 7] . $perms;
403 $perms = $rwx[$mode & 7] . $perms;
404 substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _;
405 substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _;
406 substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _;
407 if (-f _) { $perms = '-' . $perms; }
408 elsif (-d _) { $perms = 'd' . $perms; }
409 elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); }
410 elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); }
411 elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); }
412 elsif (-p _) { $perms = 'p' . $perms; }
413 elsif (-S _) { $perms = 's' . $perms; }
414 else { $perms = '?' . $perms; }
416 my $user = $user{$uid} || $uid;
417 my $group = $group{$gid} || $gid;
419 my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime);
420 if (-M _ > 365.25 / 2) {
423 $timeyear = sprintf("%02d:%02d", $hour, $min);
426 printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n",
445 if (exists $init{cpio} || exists $init{tar}) {
451 my ($fh, $varref, $blksz) = @_;
453 while (length($$varref) >= $blksz) {
455 syswrite($fh, $$varref, $blksz);
456 substr($$varref, 0, $blksz) = '';
465 if (exists $init{cpio}) {
466 print <<'INTRO', <<"SUB", <<'END';
472 my ($fh, $fname, $nc) = @_;
474 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
475 $atime,$mtime,$ctime,$blksize,$blocks);
478 if ( ! defined $fname ) {
479 $fname = 'TRAILER!!!';
480 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
481 $atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13;
483 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
485 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
488 open(IN, "./$_\0") || do {
489 warn "Couldn't open $fname: $!\n";
493 $text = readlink($_);
494 $size = 0 unless defined $text;
502 sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
516 $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
517 $cpout{$fh} .= pack("SSSSSSSSLSLa*",
518 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
519 length($fname)+1, $size,
520 $fname . (length($fname) & 1 ? "\0" : "\0\0"));
524 $cpout{$fh} .= $text;
527 flush($fh, \$cpout{$fh}, 5120)
528 while ($l = length($cpout{$fh})) >= 5120;
529 while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
530 flush($fh, \$cpout{$fh}, 5120);
531 $l = length($cpout{$fh});
538 for my $fh (keys %cpout) {
539 cpio($fh, undef, $nc{$fh});
540 $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
541 flush($fh, \$cpout{$fh}, 5120);
542 print $blocks{$fh} * 10, " blocks\n";
549 if (exists $init{tar}) {
550 print <<'INTRO', <<"SUB", <<'END';
556 my ($fh, $fname) = @_;
560 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
562 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
567 if ($linkname = $linkseen{$fh, $dev, $ino}) {
568 if (length($linkname) > 100) {
569 warn "$0: omitting file with linkname ",
570 "too long for tar output: $linkname\n";
576 $linkseen{$fh, $dev, $ino} = $fname;
579 if ($typeflag eq '0') {
581 open(IN, "./$_\0") || do {
582 warn "Couldn't open $fname: $!\n";
586 $linkname = readlink($_);
587 if (defined $linkname) { $typeflag = '2' }
588 elsif (-c _) { $typeflag = '3' }
589 elsif (-b _) { $typeflag = '4' }
590 elsif (-d _) { $typeflag = '5' }
591 elsif (-p _) { $typeflag = '6' }
595 if (length($fname) > 100) {
596 ($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#);
597 if (!defined($fname) || length($prefix) > 155) {
598 warn "$0: omitting file with name too long for tar output: ",
604 $size = 0 if $typeflag ne '0';
605 my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155",
607 sprintf("%7o ", $mode & 0777),
608 sprintf("%7o ", $uid & 0777777),
609 sprintf("%7o ", $gid & 0777777),
610 sprintf("%11o ", $size),
611 sprintf("%11o ", $mtime),
614 defined $linkname ? $linkname : '',
623 substr($header, 148, 8) = sprintf("%7o ", unpack("%16C*", $header));
624 my $l = length($header) % 512;
625 $tarout{$fh} .= $header;
626 $tarout{$fh} .= "\0" x (512 - $l) if $l;
629 flush($fh, \$tarout{$fh}, 10240)
630 while ($l = length($tarout{$fh})) >= 10240;
631 while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
632 my $slop = length($tarout{$fh}) % 512;
633 $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
634 flush($fh, \$tarout{$fh}, 10240);
635 $l = length($tarout{$fh});
643 for my $fh (keys %tarout) {
644 $len = 10240 - length($tarout{$fh});
645 $len += 10240 if $len < 1024;
646 $tarout{$fh} .= "\0" x $len;
647 flush($fh, \$tarout{$fh}, 10240);
656 ############################################################################
661 $tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4);
663 if ($_ =~ /^(?:name|print|prune|exec|ok|\(|\))/) {
664 $init{delayedstat} = 1;
666 my $statcall = '(($dev,$ino,$mode,$nlink,$uid,$gid) = '
668 if (exists $init{saw_or}) {
669 $tabstring .= "(\$nlink || $statcall) &&\n" . $tabstring;
671 $tabstring .= "$statcall &&\n" . $tabstring;
674 $init{declarestat} = 1;
677 $tabstring =~ s/^\s+/ / if $out =~ /!$/;
681 sub fileglob_to_re ($) {
683 $x =~ s#([./^\$()+])#\\$1#g;
691 $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
692 $n =~ s/ 0*(\d)/ $1/;
698 $string =~ s/\\/\\\\/g;
699 $string =~ s/'/\\'/g;
707 find2perl - translate find command lines to Perl code
711 find2perl [paths] [predicates] | perl
715 find2perl is a little translator to convert find command lines to
716 equivalent Perl code. The resulting code is typically faster than
719 "paths" are a set of paths where find2perl will start its searches and
720 "predicates" are taken from the following list.
726 Negate the sense of the following predicate. The C<!> must be passed as
727 a distinct argument, so it may need to be surrounded by whitespace and/or
728 quoted from interpretation by the shell using a backslash (just as with
731 =item C<( PREDICATES )>
733 Group the given PREDICATES. The parentheses must be passed as distinct
734 arguments, so they may need to be surrounded by whitespace and/or
735 quoted from interpretation by the shell using a backslash (just as with
738 =item C<PREDICATE1 PREDICATE2>
740 True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not
741 evaluated if PREDICATE1 is false.
743 =item C<PREDICATE1 -o PREDICATE2>
745 True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is
746 not evaluated if PREDICATE1 is true.
750 Follow (dereference) symlinks. The checking of file attributes depends
751 on the position of the C<-follow> option. If it precedes the file
752 check option, an C<stat> is done which means the file check applies to the
753 file the symbolic link is pointing to. If C<-follow> option follows the
754 file check option, this now applies to the symbolic link itself, i.e.
759 Change directory traversal algorithm from breadth-first to depth-first.
763 Do not descend into the directory currently matched.
767 Do not traverse mount points (prunes search at mount-point directories).
771 File name matches specified GLOB wildcard pattern. GLOB may need to be
772 quoted to avoid interpretation by the shell (just as with using
777 Like C<-name>, but the match is case insensitive.
781 Path name matches specified GLOB wildcard pattern.
785 Like C<-path>, but the match is case insensitive.
789 Low-order 9 bits of permission match octal value PERM.
793 The bits specified in PERM are all set in file's permissions.
797 The file's type matches perl's C<-X> operator.
799 =item C<-fstype TYPE>
801 Filesystem of current path is of type TYPE (only NFS/non-NFS distinction
806 True if USER is owner of file.
808 =item C<-group GROUP>
810 True if file's group is GROUP.
814 True if file's owner is not in password database.
818 True if file's group is not in group database.
822 True file's inode number is INUM.
826 True if (hard) link count of file matches N (see below).
830 True if file's size matches N (see below) N is normally counted in
831 512-byte blocks, but a suffix of "c" specifies that size should be
832 counted in characters (bytes) and a suffix of "k" specifies that
833 size should be counted in 1024-byte blocks.
837 True if last-access time of file matches N (measured in days) (see
842 True if last-changed time of file's inode matches N (measured in days,
847 True if last-modified time of file matches N (measured in days, see below).
851 True if last-modified time of file matches N.
855 Print out path of file (always true). If none of C<-exec>, C<-ls>,
856 C<-print0>, or C<-ok> is specified, then C<-print> will be added
861 Like -print, but terminates with \0 instead of \n.
863 =item C<-exec OPTIONS ;>
865 exec() the arguments in OPTIONS in a subprocess; any occurrence of {} in
866 OPTIONS will first be substituted with the path of the current
867 file. Note that the command "rm" has been special-cased to use perl's
868 unlink() function instead (as an optimization). The C<;> must be passed as
869 a distinct argument, so it may need to be surrounded by whitespace and/or
870 quoted from interpretation by the shell using a backslash (just as with
873 =item C<-ok OPTIONS ;>
875 Like -exec, but first prompts user; if user's response does not begin
876 with a y, skip the exec. The C<;> must be passed as
877 a distinct argument, so it may need to be surrounded by whitespace and/or
878 quoted from interpretation by the shell using a backslash (just as with
883 Has the perl script eval() the EXPR.
887 Simulates C<-exec ls -dils {} ;>
891 Adds current output to tar-format FILE.
895 Adds current output to old-style cpio-format FILE.
899 Adds current output to "new"-style cpio-format FILE.
903 Predicates which take a numeric argument N can come in three forms:
905 * N is prefixed with a +: match values greater than N
906 * N is prefixed with a -: match values less than N
907 * N is not prefixed with either + or -: match only values equal to N
916 close OUT or die "Can't close $file: $!";
917 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
918 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';