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";
46 # Modified September 26, 1993 to provide proper handling of years after 1999
47 # Tom Link <tml+@pitt.edu>
48 # University of Pittsburgh
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
54 # Modified 1999-06-10, 1999-07-07 to migrate to cleaner perl5 usage
55 # Ken Pizzini <ken@halcyon.com>
57 # Modified 2000-01-28 to use the 'follow' option of File::Find
60 # $ find2perl -name a|wc #produces a shorter program
62 # $ find2perl |wc #than this:
67 sub fileglob_to_re ($);
71 while ($ARGV[0] =~ /^[^-!(]/) {
74 @roots = (curdir()) unless @roots;
75 for (@roots) { $_ = quote($_) }
76 my $roots = join(', ', @roots);
86 my $declaresubs = "sub wanted;\n";
88 my ($follow_in_effect,$Skip_And) = (0,0);
93 s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
101 } elsif ($_ eq 'follow') {
102 $follow_in_effect= 1;
105 } elsif ($_ eq '!') {
108 } elsif (/^(i)?name$/) {
109 $out .= tab . '/' . fileglob_to_re(shift) . "/s$1";
110 } elsif (/^(i)?path$/) {
111 $out .= tab . '$File::Find::name =~ /' . fileglob_to_re(shift) . "/s$1";
112 } elsif ($_ eq 'perm') {
114 $onum =~ /^-?[0-7]+$/
115 || die "Malformed -perm argument: $onum\n";
117 if ($onum =~ s/^-//) {
118 $onum = sprintf("0%o", oct($onum) & 07777);
119 $out .= "((\$mode & $onum) == $onum)";
122 $out .= "((\$mode & 0777) == $onum)";
124 } elsif ($_ eq 'type') {
125 (my $filetest = shift) =~ tr/s/S/;
126 $out .= tab . "-$filetest _";
127 } elsif ($_ eq 'print') {
128 $out .= tab . 'print("$name\n")';
130 } elsif ($_ eq 'print0') {
131 $out .= tab . 'print("$name\0")';
133 } elsif ($_ eq 'fstype') {
136 if ($type eq 'nfs') {
137 $out .= '($dev < 0)';
139 $out .= '($dev >= 0)'; #XXX
141 } elsif ($_ eq 'user') {
143 $out .= tab . "(\$uid == \$uid{'$uname'})";
145 } elsif ($_ eq 'group') {
147 $out .= tab . "(\$gid == \$gid{'$gname'})";
149 } elsif ($_ eq 'nouser') {
150 $out .= tab . '!exists $uid{$uid}';
152 } elsif ($_ eq 'nogroup') {
153 $out .= tab . '!exists $gid{$gid}';
155 } elsif ($_ eq 'links') {
156 $out .= tab . n('$nlink', shift);
157 } elsif ($_ eq 'inum') {
158 $out .= tab . n('$ino', shift);
159 } elsif ($_ eq 'size') {
161 my $n = 'int(((-s _) + 511) / 512)';
165 $n = 'int(((-s _) + 1023) / 1024)';
167 $out .= tab . n($n, $_);
168 } elsif ($_ eq 'atime') {
169 $out .= tab . n('int(-A _)', shift);
170 } elsif ($_ eq 'mtime') {
171 $out .= tab . n('int(-M _)', shift);
172 } elsif ($_ eq 'ctime') {
173 $out .= tab . n('int(-C _)', shift);
174 } elsif ($_ eq 'exec') {
176 while (@ARGV && $ARGV[0] ne ';')
177 { push(@cmd, shift) }
180 if ($cmd[0] =~m#^(?:(?:/usr)?/bin/)?rm$#
181 && $cmd[$#cmd] eq '{}'
182 && (@cmd == 2 || (@cmd == 3 && $cmd[1] eq '-f'))) {
184 $out .= '(unlink($_) || warn "$name: $!\n")';
186 $out .= 'unlink($_)';
188 $out .= '(unlink($_) || 1)';
193 { local $" = "','"; $out .= "doexec(0, '@cmd')"; }
194 $declaresubs .= "sub doexec (\$\@);\n";
198 } elsif ($_ eq 'ok') {
200 while (@ARGV && $ARGV[0] ne ';')
201 { push(@cmd, shift) }
206 { local $" = "','"; $out .= "doexec(1, '@cmd')"; }
207 $declaresubs .= "sub doexec (\$\@);\n";
210 } elsif ($_ eq 'prune') {
211 $out .= tab . '($File::Find::prune = 1)';
212 } elsif ($_ eq 'xdev') {
213 $out .= tab . '!($File::Find::prune |= ($dev != $File::Find::topdev))'
215 } elsif ($_ eq 'newer') {
217 my $newername = 'AGE_OF' . $file;
218 $newername =~ s/\W/_/g;
219 $newername = '$' . $newername;
220 $out .= tab . "(-M _ < $newername)";
221 $initnewer .= "my $newername = -M " . quote($file) . ";\n";
222 } elsif ($_ eq 'eval') {
225 $out .= tab . "eval {$prog}";
227 } elsif ($_ eq 'depth') {
230 } elsif ($_ eq 'ls') {
232 $declaresubs .= "sub ls ();\n";
235 } elsif ($_ eq 'tar') {
236 die "-tar must have a filename argument\n" unless @ARGV;
238 my $fh = 'FH' . $file;
240 $out .= tab . "tar(*$fh, \$name)";
241 $flushall .= "tflushall;\n";
242 $declaresubs .= "sub tar;\nsub tflushall ();\n";
243 $initfile .= "open($fh, " . quote('> ' . $file) .
244 qq{) || die "Can't open $fh: \$!\\n";\n};
246 } elsif (/^(n?)cpio\z/) {
247 die "-$_ must have a filename argument\n" unless @ARGV;
249 my $fh = 'FH' . $file;
251 $out .= tab . "cpio(*$fh, \$name, '$1')";
253 $flushall .= "cflushall;\n";
254 $declaresubs .= "sub cpio;\nsub cflushall ();\n";
255 $initfile .= "open($fh, " . quote('> ' . $file) .
256 qq{) || die "Can't open $fh: \$!\\n";\n};
259 die "Unrecognized switch: -$_\n";
263 if ($ARGV[0] eq '-o') {
264 { local($statdone) = 1; $out .= "\n" . tab . "||\n"; }
265 $statdone = 0 if $indent_depth == 1 && exists $init{delayedstat};
269 $out .= " &&" unless $Skip_And || $ARGV[0] eq ')';
271 shift if $ARGV[0] eq '-a';
278 if ($t !~ /&&\s*$/) { $t .= '&& ' }
279 $out .= "\n" . $t . 'print("$name\n")';
285 eval 'exec $perlpath -S \$0 \${1+"\$@"}'
286 if 0; #\$running_under_some_shell
291 # Set the variable \$File::Find::dont_use_nlink if you're using AFS,
294 # for the convenience of &wanted calls, including -eval statements:
295 use vars qw/*name *dir *prune/;
296 *name = *File::Find::name;
297 *dir = *File::Find::dir;
298 *prune = *File::Find::prune;
304 if (exists $init{doexec}) {
307 my $cwd = Cwd::cwd();
312 if (exists $init{ls}) {
314 my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx);
315 my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
320 if (exists $init{user} || exists $init{ls} || exists $init{tar}) {
321 print "my (%uid, %user);\n";
322 print "while (my (\$name, \$pw, \$uid) = getpwent) {\n";
323 print ' $uid{$name} = $uid{$uid} = $uid;', "\n"
324 if exists $init{user};
325 print ' $user{$uid} = $name unless exists $user{$uid};', "\n"
326 if exists $init{ls} || exists $init{tar};
330 if (exists $init{group} || exists $init{ls} || exists $init{tar}) {
331 print "my (%gid, %group);\n";
332 print "while (my (\$name, \$pw, \$gid) = getgrent) {\n";
333 print ' $gid{$name} = $gid{$gid} = $gid;', "\n"
334 if exists $init{group};
335 print ' $group{$gid} = $name unless exists $group{$gid};', "\n"
336 if exists $init{ls} || exists $init{tar};
340 print $initnewer, "\n" if $initnewer ne '';
341 print $initfile, "\n" if $initfile ne '';
342 $flushall .= "exit;\n";
343 if (exists $init{declarestat}) {
344 $out = <<'END' . $out;
345 my ($dev,$ino,$mode,$nlink,$uid,$gid);
350 if ( $follow_in_effect ) {
351 $out =~ s/lstat\(\$_\)/lstat(_)/;
354 # Traverse desired filesystems
355 File::Find::$find( {wanted => \\&wanted, follow => 1}, $roots);
366 # Traverse desired filesystems
367 File::Find::$find({wanted => \\&wanted}, $roots);
377 if (exists $init{doexec}) {
382 my @command = @_; # copy so we don't try to s/// aliases to constants
383 for my $word (@command)
384 { $word =~ s#{}#$name#g }
386 my $old = select(STDOUT);
390 return 0 unless <STDIN> =~ /^y/;
394 chdir $File::Find::dir;
401 if (exists $init{ls}) {
402 print <<'INTRO', <<"SUB", <<'END';
406 sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
410 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
412 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
417 or $blocks = int(($size + 1023) / 1024);
419 my $perms = $rwx[$mode & 7];
421 $perms = $rwx[$mode & 7] . $perms;
423 $perms = $rwx[$mode & 7] . $perms;
424 substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _;
425 substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _;
426 substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _;
427 if (-f _) { $perms = '-' . $perms; }
428 elsif (-d _) { $perms = 'd' . $perms; }
429 elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); }
430 elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); }
431 elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); }
432 elsif (-p _) { $perms = 'p' . $perms; }
433 elsif (-S _) { $perms = 's' . $perms; }
434 else { $perms = '?' . $perms; }
436 my $user = $user{$uid} || $uid;
437 my $group = $group{$gid} || $gid;
439 my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime);
440 if (-M _ > 365.25 / 2) {
443 $timeyear = sprintf("%02d:%02d", $hour, $min);
446 printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n",
465 if (exists $init{cpio} || exists $init{tar}) {
471 my ($fh, $varref, $blksz) = @_;
473 while (length($$varref) >= $blksz) {
475 syswrite($fh, $$varref, $blksz);
476 substr($$varref, 0, $blksz) = '';
485 if (exists $init{cpio}) {
486 print <<'INTRO', <<"SUB", <<'END';
492 my ($fh, $fname, $nc) = @_;
494 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
495 $atime,$mtime,$ctime,$blksize,$blocks);
498 if ( ! defined $fname ) {
499 $fname = 'TRAILER!!!';
500 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
501 $atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13;
503 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
505 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
508 open(IN, "./$_\0") || do {
509 warn "Couldn't open $fname: $!\n";
513 $text = readlink($_);
514 $size = 0 unless defined $text;
522 sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
536 $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
537 $cpout{$fh} .= pack("SSSSSSSSLSLa*",
538 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
539 length($fname)+1, $size,
540 $fname . (length($fname) & 1 ? "\0" : "\0\0"));
544 $cpout{$fh} .= $text;
547 flush($fh, \$cpout{$fh}, 5120)
548 while ($l = length($cpout{$fh})) >= 5120;
549 while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
550 flush($fh, \$cpout{$fh}, 5120);
551 $l = length($cpout{$fh});
558 for my $fh (keys %cpout) {
559 cpio($fh, undef, $nc{$fh});
560 $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
561 flush($fh, \$cpout{$fh}, 5120);
562 print $blocks{$fh} * 10, " blocks\n";
569 if (exists $init{tar}) {
570 print <<'INTRO', <<"SUB", <<'END';
576 my ($fh, $fname) = @_;
580 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
582 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
587 if ($linkname = $linkseen{$fh, $dev, $ino}) {
588 if (length($linkname) > 100) {
589 warn "$0: omitting file with linkname ",
590 "too long for tar output: $linkname\n";
596 $linkseen{$fh, $dev, $ino} = $fname;
599 if ($typeflag eq '0') {
601 open(IN, "./$_\0") || do {
602 warn "Couldn't open $fname: $!\n";
606 $linkname = readlink($_);
607 if (defined $linkname) { $typeflag = '2' }
608 elsif (-c _) { $typeflag = '3' }
609 elsif (-b _) { $typeflag = '4' }
610 elsif (-d _) { $typeflag = '5' }
611 elsif (-p _) { $typeflag = '6' }
615 if (length($fname) > 100) {
616 ($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#);
617 if (!defined($fname) || length($prefix) > 155) {
618 warn "$0: omitting file with name too long for tar output: ",
624 $size = 0 if $typeflag ne '0';
625 my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155",
627 sprintf("%7o ", $mode & 0777),
628 sprintf("%7o ", $uid & 0777777),
629 sprintf("%7o ", $gid & 0777777),
630 sprintf("%11o ", $size),
631 sprintf("%11o ", $mtime),
634 defined $linkname ? $linkname : '',
643 substr($header, 148, 8) = sprintf("%7o ", unpack("%16C*", $header));
644 my $l = length($header) % 512;
645 $tarout{$fh} .= $header;
646 $tarout{$fh} .= "\0" x (512 - $l) if $l;
649 flush($fh, \$tarout{$fh}, 10240)
650 while ($l = length($tarout{$fh})) >= 10240;
651 while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
652 my $slop = length($tarout{$fh}) % 512;
653 $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
654 flush($fh, \$tarout{$fh}, 10240);
655 $l = length($tarout{$fh});
663 for my $fh (keys %tarout) {
664 $len = 10240 - length($tarout{$fh});
665 $len += 10240 if $len < 1024;
666 $tarout{$fh} .= "\0" x $len;
667 flush($fh, \$tarout{$fh}, 10240);
676 ############################################################################
681 $tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4);
683 if ($_ =~ /^(?:name|print|prune|exec|ok|\(|\))/) {
684 $init{delayedstat} = 1;
686 my $statcall = '(($dev,$ino,$mode,$nlink,$uid,$gid) = '
688 if (exists $init{saw_or}) {
689 $tabstring .= "(\$nlink || $statcall) &&\n" . $tabstring;
691 $tabstring .= "$statcall &&\n" . $tabstring;
694 $init{declarestat} = 1;
697 $tabstring =~ s/^\s+/ / if $out =~ /!$/;
701 sub fileglob_to_re ($) {
703 $x =~ s#([./^\$()+])#\\$1#g;
704 $x =~ s#([?*])#.$1#g;
710 $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
711 $n =~ s/ 0*(\d)/ $1/;
717 $string =~ s/\\/\\\\/g;
718 $string =~ s/'/\\'/g;
726 find2perl - translate find command lines to Perl code
730 find2perl [paths] [predicates] | perl
734 find2perl is a little translator to convert find command lines to
735 equivalent Perl code. The resulting code is typically faster than
738 "paths" are a set of paths where find2perl will start its searches and
739 "predicates" are taken from the following list.
745 Negate the sense of the following predicate. The C<!> must be passed as
746 a distinct argument, so it may need to be surrounded by whitespace and/or
747 quoted from interpretation by the shell using a backslash (just as with
750 =item C<( PREDICATES )>
752 Group the given PREDICATES. The parentheses must be passed as distinct
753 arguments, so they may need to be surrounded by whitespace and/or
754 quoted from interpretation by the shell using a backslash (just as with
757 =item C<PREDICATE1 PREDICATE2>
759 True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not
760 evaluated if PREDICATE1 is false.
762 =item C<PREDICATE1 -o PREDICATE2>
764 True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is
765 not evaluated if PREDICATE1 is true.
769 Follow (dereference) symlinks. The checking of file attributes depends
770 on the position of the C<-follow> option. If it precedes the file
771 check option, an C<stat> is done which means the file check applies to the
772 file the symbolic link is pointing to. If C<-follow> option follows the
773 file check option, this now applies to the symbolic link itself, i.e.
778 Change directory traversal algorithm from breadth-first to depth-first.
782 Do not descend into the directory currently matched.
786 Do not traverse mount points (prunes search at mount-point directories).
790 File name matches specified GLOB wildcard pattern. GLOB may need to be
791 quoted to avoid interpretation by the shell (just as with using
796 Like C<-name>, but the match is case insensitive.
800 Path name matches specified GLOB wildcard pattern.
804 Like C<-path>, but the match is case insensitive.
808 Low-order 9 bits of permission match octal value PERM.
812 The bits specified in PERM are all set in file's permissions.
816 The file's type matches perl's C<-X> operator.
818 =item C<-fstype TYPE>
820 Filesystem of current path is of type TYPE (only NFS/non-NFS distinction
825 True if USER is owner of file.
827 =item C<-group GROUP>
829 True if file's group is GROUP.
833 True if file's owner is not in password database.
837 True if file's group is not in group database.
841 True file's inode number is INUM.
845 True if (hard) link count of file matches N (see below).
849 True if file's size matches N (see below) N is normally counted in
850 512-byte blocks, but a suffix of "c" specifies that size should be
851 counted in characters (bytes) and a suffix of "k" specifies that
852 size should be counted in 1024-byte blocks.
856 True if last-access time of file matches N (measured in days) (see
861 True if last-changed time of file's inode matches N (measured in days,
866 True if last-modified time of file matches N (measured in days, see below).
870 True if last-modified time of file matches N.
874 Print out path of file (always true). If none of C<-exec>, C<-ls>,
875 C<-print0>, or C<-ok> is specified, then C<-print> will be added
880 Like -print, but terminates with \0 instead of \n.
882 =item C<-exec OPTIONS ;>
884 exec() the arguments in OPTIONS in a subprocess; any occurrence of {} in
885 OPTIONS will first be substituted with the path of the current
886 file. Note that the command "rm" has been special-cased to use perl's
887 unlink() function instead (as an optimization). The C<;> must be passed as
888 a distinct argument, so it may need to be surrounded by whitespace and/or
889 quoted from interpretation by the shell using a backslash (just as with
892 =item C<-ok OPTIONS ;>
894 Like -exec, but first prompts user; if user's response does not begin
895 with a y, skip the exec. The C<;> must be passed as
896 a distinct argument, so it may need to be surrounded by whitespace and/or
897 quoted from interpretation by the shell using a backslash (just as with
902 Has the perl script eval() the EXPR.
906 Simulates C<-exec ls -dils {} ;>
910 Adds current output to tar-format FILE.
914 Adds current output to old-style cpio-format FILE.
918 Adds current output to "new"-style cpio-format FILE.
922 Predicates which take a numeric argument N can come in three forms:
924 * N is prefixed with a +: match values greater than N
925 * N is prefixed with a -: match values less than N
926 * N is not prefixed with either + or -: match only values equal to N
935 close OUT or die "Can't close $file: $!";
936 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
937 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';