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
61 sub fileglob_to_re ($);
65 while ($ARGV[0] =~ /^[^-!(]/) {
68 @roots = (curdir()) unless @roots;
69 for (@roots) { $_ = quote($_) }
70 my $roots = join(', ', @roots);
80 my $declaresubs = "sub wanted;\n";
82 my ($follow_in_effect,$Skip_And) = (0,0);
87 s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
95 } elsif ($_ eq 'follow') {
102 } elsif ($_ eq 'name') {
103 $out .= tab . '/' . fileglob_to_re(shift) . "/s";
104 } elsif ($_ eq 'perm') {
106 $onum =~ /^-?[0-7]+$/
107 || die "Malformed -perm argument: $onum\n";
109 if ($onum =~ s/^-//) {
110 $onum = sprintf("0%o", oct($onum) & 07777);
111 $out .= "((\$mode & $onum) == $onum)";
114 $out .= "((\$mode & 0777) == $onum)";
116 } elsif ($_ eq 'type') {
117 (my $filetest = shift) =~ tr/s/S/;
118 $out .= tab . "-$filetest _";
119 } elsif ($_ eq 'print') {
120 $out .= tab . 'print("$name\n")';
122 } elsif ($_ eq 'print0') {
123 $out .= tab . 'print("$name\0")';
125 } elsif ($_ eq 'fstype') {
128 if ($type eq 'nfs') {
129 $out .= '($dev < 0)';
131 $out .= '($dev >= 0)'; #XXX
133 } elsif ($_ eq 'user') {
135 $out .= tab . "(\$uid == \$uid{'$uname'})";
137 } elsif ($_ eq 'group') {
139 $out .= tab . "(\$gid == \$gid{'$gname'})";
141 } elsif ($_ eq 'nouser') {
142 $out .= tab . '!exists $uid{$uid}';
144 } elsif ($_ eq 'nogroup') {
145 $out .= tab . '!exists $gid{$gid}';
147 } elsif ($_ eq 'links') {
148 $out .= tab . n('$nlink', shift);
149 } elsif ($_ eq 'inum') {
150 $out .= tab . n('$ino', shift);
151 } elsif ($_ eq 'size') {
153 my $n = 'int(((-s _) + 511) / 512)';
157 $n = 'int(((-s _) + 1023) / 1024)';
159 $out .= tab . n($n, $_);
160 } elsif ($_ eq 'atime') {
161 $out .= tab . n('int(-A _)', shift);
162 } elsif ($_ eq 'mtime') {
163 $out .= tab . n('int(-M _)', shift);
164 } elsif ($_ eq 'ctime') {
165 $out .= tab . n('int(-C _)', shift);
166 } elsif ($_ eq 'exec') {
168 while (@ARGV && $ARGV[0] ne ';')
169 { push(@cmd, shift) }
172 if ($cmd[0] =~m#^(?:(?:/usr)?/bin/)?rm$#
173 && $cmd[$#cmd] eq '{}'
174 && (@cmd == 2 || (@cmd == 3 && $cmd[1] eq '-f'))) {
176 $out .= '(unlink($_) || warn "$name: $!\n")';
178 $out .= 'unlink($_)';
180 $out .= '(unlink($_) || 1)';
185 { local $" = "','"; $out .= "doexec(0, '@cmd')"; }
186 $declaresubs .= "sub doexec (\$\@);\n";
190 } elsif ($_ eq 'ok') {
192 while (@ARGV && $ARGV[0] ne ';')
193 { push(@cmd, shift) }
198 { local $" = "','"; $out .= "doexec(1, '@cmd')"; }
199 $declaresubs .= "sub doexec (\$\@);\n";
202 } elsif ($_ eq 'prune') {
203 $out .= tab . '($File::Find::prune = 1)';
204 } elsif ($_ eq 'xdev') {
205 $out .= tab . '!($File::Find::prune |= ($dev != $File::Find::topdev))'
207 } elsif ($_ eq 'newer') {
209 my $newername = 'AGE_OF' . $file;
210 $newername =~ s/\W/_/g;
211 $newername = '$' . $newername;
212 $out .= tab . "(-M _ < $newername)";
213 $initnewer .= "my $newername = -M " . quote($file) . ";\n";
214 } elsif ($_ eq 'eval') {
217 $out .= tab . "eval {$prog}";
218 } elsif ($_ eq 'depth') {
221 } elsif ($_ eq 'ls') {
223 $declaresubs .= "sub ls ();\n";
226 } elsif ($_ eq 'tar') {
227 die "-tar must have a filename argument\n" unless @ARGV;
229 my $fh = 'FH' . $file;
231 $out .= tab . "tar(*$fh, \$name)";
232 $flushall .= "tflushall;\n";
233 $declaresubs .= "sub tar;\nsub tflushall ();\n";
234 $initfile .= "open($fh, " . quote('> ' . $file) .
235 qq{) || die "Can't open $fh: \$!\\n";\n};
237 } elsif (/^(n?)cpio\z/) {
238 die "-$_ must have a filename argument\n" unless @ARGV;
240 my $fh = 'FH' . $file;
242 $out .= tab . "cpio(*$fh, \$name, '$1')";
244 $flushall .= "cflushall;\n";
245 $declaresubs .= "sub cpio;\nsub cflushall ();\n";
246 $initfile .= "open($fh, " . quote('> ' . $file) .
247 qq{) || die "Can't open $fh: \$!\\n";\n};
250 die "Unrecognized switch: -$_\n";
254 if ($ARGV[0] eq '-o') {
255 { local($statdone) = 1; $out .= "\n" . tab . "||\n"; }
256 $statdone = 0 if $indent_depth == 1 && exists $init{delayedstat};
260 $out .= " &&" unless $Skip_And || $ARGV[0] eq ')';
262 shift if $ARGV[0] eq '-a';
268 $out .= "\n" . tab . '&& print("$name\n")';
274 eval 'exec $perlpath -S \$0 \${1+"\$@"}'
275 if 0; #\$running_under_some_shell
280 # Set the variable \$File::Find::dont_use_nlink if you're using AFS,
283 # for the convenience of &wanted calls, including -eval statements:
284 use vars qw/*name *dir *prune/;
285 *name = *File::Find::name;
286 *dir = *File::Find::dir;
287 *prune = *File::Find::prune;
293 if (exists $init{ls}) {
295 my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx);
296 my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
301 if (exists $init{user} || exists $init{ls} || exists $init{tar}) {
302 print "my (%uid, %user);\n";
303 print "while (my (\$name, \$pw, \$uid) = getpwent) {\n";
304 print ' $uid{$name} = $uid{$uid} = $uid;', "\n"
305 if exists $init{user};
306 print ' $user{$uid} = $name unless exists $user{$uid};', "\n"
307 if exists $init{ls} || exists $init{tar};
311 if (exists $init{group} || exists $init{ls} || exists $init{tar}) {
312 print "my (%gid, %group);\n";
313 print "while (my (\$name, \$pw, \$gid) = getgrent) {\n";
314 print ' $gid{$name} = $gid{$gid} = $gid;', "\n"
315 if exists $init{group};
316 print ' $group{$gid} = $name unless exists $group{$gid};', "\n"
317 if exists $init{ls} || exists $init{tar};
321 print $initnewer, "\n" if $initnewer ne '';
322 print $initfile, "\n" if $initfile ne '';
323 $flushall .= "exit;\n";
324 if (exists $init{declarestat}) {
325 $out = <<'END' . $out;
326 my ($dev,$ino,$mode,$nlink,$uid,$gid);
331 if ( $follow_in_effect ) {
332 $out =~ s/lstat\(\$_\)/lstat(_)/;
335 # Traverse desired filesystems
336 File::Find::$find( {wanted => \\&wanted, follow => 1}, $roots);
347 # Traverse desired filesystems
348 File::Find::$find({wanted => \\&wanted}, $roots);
358 if (exists $init{doexec}) {
362 my $cwd = Cwd::cwd();
366 my @command = @_; # copy so we don't try to s/// aliases to constants
367 for my $word (@command)
368 { $word =~ s#{}#$name#g }
370 my $old = select(STDOUT);
374 return 0 unless <STDIN> =~ /^y/;
378 chdir $File::Find::dir;
385 if (exists $init{ls}) {
386 print <<'INTRO', <<"SUB", <<'END';
390 sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
394 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
396 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
401 or $blocks = int(($size + 1023) / 1024);
403 my $perms = $rwx[$mode & 7];
405 $perms = $rwx[$mode & 7] . $perms;
407 $perms = $rwx[$mode & 7] . $perms;
408 substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _;
409 substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _;
410 substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _;
411 if (-f _) { $perms = '-' . $perms; }
412 elsif (-d _) { $perms = 'd' . $perms; }
413 elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); }
414 elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); }
415 elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); }
416 elsif (-p _) { $perms = 'p' . $perms; }
417 elsif (-S _) { $perms = 's' . $perms; }
418 else { $perms = '?' . $perms; }
420 my $user = $user{$uid} || $uid;
421 my $group = $group{$gid} || $gid;
423 my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime);
424 if (-M _ > 365.25 / 2) {
427 $timeyear = sprintf("%02d:%02d", $hour, $min);
430 printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n",
449 if (exists $init{cpio} || exists $init{tar}) {
455 my ($fh, $varref, $blksz) = @_;
457 while (length($$varref) >= $blksz) {
459 syswrite($fh, $$varref, $blksz);
460 substr($$varref, 0, $blksz) = '';
469 if (exists $init{cpio}) {
470 print <<'INTRO', <<"SUB", <<'END';
476 my ($fh, $fname, $nc) = @_;
478 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
479 $atime,$mtime,$ctime,$blksize,$blocks);
482 if ( ! defined $fname ) {
483 $fname = 'TRAILER!!!';
484 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
485 $atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13;
487 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
489 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
492 open(IN, "./$_\0") || do {
493 warn "Couldn't open $fname: $!\n";
497 $text = readlink($_);
498 $size = 0 unless defined $text;
506 sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
520 $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
521 $cpout{$fh} .= pack("SSSSSSSSLSLa*",
522 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
523 length($fname)+1, $size,
524 $fname . (length($fname) & 1 ? "\0" : "\0\0"));
528 $cpout{$fh} .= $text;
531 flush($fh, \$cpout{$fh}, 5120)
532 while ($l = length($cpout{$fh})) >= 5120;
533 while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
534 flush($fh, \$cpout{$fh}, 5120);
535 $l = length($cpout{$fh});
542 for my $fh (keys %cpout) {
543 cpio($fh, undef, $nc{$fh});
544 $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
545 flush($fh, \$cpout{$fh}, 5120);
546 print $blocks{$fh} * 10, " blocks\n";
553 if (exists $init{tar}) {
554 print <<'INTRO', <<"SUB", <<'END';
560 my ($fh, $fname) = @_;
564 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
566 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
571 if ($linkname = $linkseen{$fh, $dev, $ino}) {
572 if (length($linkname) > 100) {
573 warn "$0: omitting file with linkname ",
574 "too long for tar output: $linkname\n";
580 $linkseen{$fh, $dev, $ino} = $fname;
583 if ($typeflag eq '0') {
585 open(IN, "./$_\0") || do {
586 warn "Couldn't open $fname: $!\n";
590 $linkname = readlink($_);
591 if (defined $linkname) { $typeflag = '2' }
592 elsif (-c _) { $typeflag = '3' }
593 elsif (-b _) { $typeflag = '4' }
594 elsif (-d _) { $typeflag = '5' }
595 elsif (-p _) { $typeflag = '6' }
599 if (length($fname) > 100) {
600 ($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#);
601 if (!defined($fname) || length($prefix) > 155) {
602 warn "$0: omitting file with name too long for tar output: ",
608 $size = 0 if $typeflag ne '0';
609 my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155",
611 sprintf("%7o ", $mode & 0777),
612 sprintf("%7o ", $uid & 0777777),
613 sprintf("%7o ", $gid & 0777777),
614 sprintf("%11o ", $size),
615 sprintf("%11o ", $mtime),
618 defined $linkname ? $linkname : '',
627 substr($header, 148, 8) = sprintf("%7o ", unpack("%16C*", $header));
628 my $l = length($header) % 512;
629 $tarout{$fh} .= $header;
630 $tarout{$fh} .= "\0" x (512 - $l) if $l;
633 flush($fh, \$tarout{$fh}, 10240)
634 while ($l = length($tarout{$fh})) >= 10240;
635 while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
636 my $slop = length($tarout{$fh}) % 512;
637 $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
638 flush($fh, \$tarout{$fh}, 10240);
639 $l = length($tarout{$fh});
647 for my $fh (keys %tarout) {
648 $len = 10240 - length($tarout{$fh});
649 $len += 10240 if $len < 1024;
650 $tarout{$fh} .= "\0" x $len;
651 flush($fh, \$tarout{$fh}, 10240);
660 ############################################################################
665 $tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4);
667 if ($_ =~ /^(?:name|print|prune|exec|ok|\(|\))/) {
668 $init{delayedstat} = 1;
670 my $statcall = '(($dev,$ino,$mode,$nlink,$uid,$gid) = '
672 if (exists $init{saw_or}) {
673 $tabstring .= "(\$nlink || $statcall) &&\n" . $tabstring;
675 $tabstring .= "$statcall &&\n" . $tabstring;
678 $init{declarestat} = 1;
681 $tabstring =~ s/^\s+/ / if $out =~ /!$/;
685 sub fileglob_to_re ($) {
687 $x =~ s#([./^\$()+])#\\$1#g;
688 $x =~ s#([?*])#.$1#g;
694 $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
695 $n =~ s/ 0*(\d)/ $1/;
701 $string =~ s/\\/\\\\/g;
702 $string =~ s/'/\\'/g;
710 find2perl - translate find command lines to Perl code
714 find2perl [paths] [predicates] | perl
718 find2perl is a little translator to convert find command lines to
719 equivalent Perl code. The resulting code is typically faster than
722 "paths" are a set of paths where find2perl will start its searches and
723 "predicates" are taken from the following list.
729 Negate the sense of the following predicate. The C<!> must be passed as
730 a distinct argument, so it may need to be surrounded by whitespace and/or
731 quoted from interpretation by the shell using a backslash (just as with
734 =item C<( PREDICATES )>
736 Group the given PREDICATES. The parentheses must be passed as distinct
737 arguments, so they may need to be surrounded by whitespace and/or
738 quoted from interpretation by the shell using a backslash (just as with
741 =item C<PREDICATE1 PREDICATE2>
743 True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not
744 evaluated if PREDICATE1 is false.
746 =item C<PREDICATE1 -o PREDICATE2>
748 True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is
749 not evaluated if PREDICATE1 is true.
753 Follow (dereference) symlinks. The checking of file attributes depends
754 on the position of the C<-follow> option. If it precedes the file
755 check option, an C<stat> is done which means the file check applies to the
756 file the symbolic link is pointing to. If C<-follow> option follows the
757 file check option, this now applies to the symbolic link itself, i.e.
762 Change directory traversal algorithm from breadth-first to depth-first.
766 Do not descend into the directory currently matched.
770 Do not traverse mount points (prunes search at mount-point directories).
774 File name matches specified GLOB wildcard pattern. GLOB may need to be
775 quoted to avoid interpretation by the shell (just as with using
780 Low-order 9 bits of permission match octal value PERM.
784 The bits specified in PERM are all set in file's permissions.
788 The file's type matches perl's C<-X> operator.
790 =item C<-fstype TYPE>
792 Filesystem of current path is of type TYPE (only NFS/non-NFS distinction
797 True if USER is owner of file.
799 =item C<-group GROUP>
801 True if file's group is GROUP.
805 True if file's owner is not in password database.
809 True if file's group is not in group database.
813 True file's inode number is INUM.
817 True if (hard) link count of file matches N (see below).
821 True if file's size matches N (see below) N is normally counted in
822 512-byte blocks, but a suffix of "c" specifies that size should be
823 counted in characters (bytes) and a suffix of "k" specifes that
824 size should be counted in 1024-byte blocks.
828 True if last-access time of file matches N (measured in days) (see
833 True if last-changed time of file's inode matches N (measured in days,
838 True if last-modified time of file matches N (measured in days, see below).
842 True if last-modified time of file matches N.
846 Print out path of file (always true). If none of C<-exec>, C<-ls>,
847 C<-print0>, or C<-ok> is specified, then C<-print> will be added
852 Like -print, but terminates with \0 instead of \n.
854 =item C<-exec OPTIONS ;>
856 exec() the arguments in OPTIONS in a subprocess; any occurrence of {} in
857 OPTIONS will first be substituted with the path of the current
858 file. Note that the command "rm" has been special-cased to use perl's
859 unlink() function instead (as an optimization). The C<;> must be passed as
860 a distinct argument, so it may need to be surrounded by whitespace and/or
861 quoted from interpretation by the shell using a backslash (just as with
864 =item C<-ok OPTIONS ;>
866 Like -exec, but first prompts user; if user's response does not begin
867 with a y, skip the exec. 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
874 Has the perl script eval() the EXPR.
878 Simulates C<-exec ls -dils {} ;>
882 Adds current output to tar-format FILE.
886 Adds current output to old-style cpio-format FILE.
890 Adds current output to "new"-style cpio-format FILE.
894 Predicates which take a numeric argument N can come in three forms:
896 * N is prefixed with a +: match values greater than N
897 * N is prefixed with a -: match values less than N
898 * N is not prefixed with either + or -: match only values equal to N
907 close OUT or die "Can't close $file: $!";
908 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
909 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';