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;
684 $x =~ s#([?*])#.$1#g;
690 $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
691 $n =~ s/ 0*(\d)/ $1/;
697 $string =~ s/\\/\\\\/g;
698 $string =~ s/'/\\'/g;
706 find2perl - translate find command lines to Perl code
710 find2perl [paths] [predicates] | perl
714 find2perl is a little translator to convert find command lines to
715 equivalent Perl code. The resulting code is typically faster than
718 "paths" are a set of paths where find2perl will start its searches and
719 "predicates" are taken from the following list.
725 Negate the sense of the following predicate. The C<!> must be passed as
726 a distinct argument, so it may need to be surrounded by whitespace and/or
727 quoted from interpretation by the shell using a backslash (just as with
730 =item C<( PREDICATES )>
732 Group the given PREDICATES. The parentheses must be passed as distinct
733 arguments, so they may need to be surrounded by whitespace and/or
734 quoted from interpretation by the shell using a backslash (just as with
737 =item C<PREDICATE1 PREDICATE2>
739 True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not
740 evaluated if PREDICATE1 is false.
742 =item C<PREDICATE1 -o PREDICATE2>
744 True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is
745 not evaluated if PREDICATE1 is true.
749 Follow (dereference) symlinks. The checking of file attributes depends
750 on the position of the C<-follow> option. If it precedes the file
751 check option, an C<stat> is done which means the file check applies to the
752 file the symbolic link is pointing to. If C<-follow> option follows the
753 file check option, this now applies to the symbolic link itself, i.e.
758 Change directory traversal algorithm from breadth-first to depth-first.
762 Do not descend into the directory currently matched.
766 Do not traverse mount points (prunes search at mount-point directories).
770 File name matches specified GLOB wildcard pattern. GLOB may need to be
771 quoted to avoid interpretation by the shell (just as with using
776 Like C<-name>, but the match is case insensitive.
780 Path name matches specified GLOB wildcard pattern.
784 Like C<-path>, but the match is case insensitive.
788 Low-order 9 bits of permission match octal value PERM.
792 The bits specified in PERM are all set in file's permissions.
796 The file's type matches perl's C<-X> operator.
798 =item C<-fstype TYPE>
800 Filesystem of current path is of type TYPE (only NFS/non-NFS distinction
805 True if USER is owner of file.
807 =item C<-group GROUP>
809 True if file's group is GROUP.
813 True if file's owner is not in password database.
817 True if file's group is not in group database.
821 True file's inode number is INUM.
825 True if (hard) link count of file matches N (see below).
829 True if file's size matches N (see below) N is normally counted in
830 512-byte blocks, but a suffix of "c" specifies that size should be
831 counted in characters (bytes) and a suffix of "k" specifies that
832 size should be counted in 1024-byte blocks.
836 True if last-access time of file matches N (measured in days) (see
841 True if last-changed time of file's inode matches N (measured in days,
846 True if last-modified time of file matches N (measured in days, see below).
850 True if last-modified time of file matches N.
854 Print out path of file (always true). If none of C<-exec>, C<-ls>,
855 C<-print0>, or C<-ok> is specified, then C<-print> will be added
860 Like -print, but terminates with \0 instead of \n.
862 =item C<-exec OPTIONS ;>
864 exec() the arguments in OPTIONS in a subprocess; any occurrence of {} in
865 OPTIONS will first be substituted with the path of the current
866 file. Note that the command "rm" has been special-cased to use perl's
867 unlink() function instead (as an optimization). The C<;> must be passed as
868 a distinct argument, so it may need to be surrounded by whitespace and/or
869 quoted from interpretation by the shell using a backslash (just as with
872 =item C<-ok OPTIONS ;>
874 Like -exec, but first prompts user; if user's response does not begin
875 with a y, skip the exec. The C<;> must be passed as
876 a distinct argument, so it may need to be surrounded by whitespace and/or
877 quoted from interpretation by the shell using a backslash (just as with
882 Has the perl script eval() the EXPR.
886 Simulates C<-exec ls -dils {} ;>
890 Adds current output to tar-format FILE.
894 Adds current output to old-style cpio-format FILE.
898 Adds current output to "new"-style cpio-format FILE.
902 Predicates which take a numeric argument N can come in three forms:
904 * N is prefixed with a +: match values greater than N
905 * N is prefixed with a -: match values less than N
906 * N is not prefixed with either + or -: match only values equal to N
915 close OUT or die "Can't close $file: $!";
916 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
917 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';