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{doexec}) {
296 my $cwd = Cwd::cwd();
301 if (exists $init{ls}) {
303 my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx);
304 my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
309 if (exists $init{user} || exists $init{ls} || exists $init{tar}) {
310 print "my (%uid, %user);\n";
311 print "while (my (\$name, \$pw, \$uid) = getpwent) {\n";
312 print ' $uid{$name} = $uid{$uid} = $uid;', "\n"
313 if exists $init{user};
314 print ' $user{$uid} = $name unless exists $user{$uid};', "\n"
315 if exists $init{ls} || exists $init{tar};
319 if (exists $init{group} || exists $init{ls} || exists $init{tar}) {
320 print "my (%gid, %group);\n";
321 print "while (my (\$name, \$pw, \$gid) = getgrent) {\n";
322 print ' $gid{$name} = $gid{$gid} = $gid;', "\n"
323 if exists $init{group};
324 print ' $group{$gid} = $name unless exists $group{$gid};', "\n"
325 if exists $init{ls} || exists $init{tar};
329 print $initnewer, "\n" if $initnewer ne '';
330 print $initfile, "\n" if $initfile ne '';
331 $flushall .= "exit;\n";
332 if (exists $init{declarestat}) {
333 $out = <<'END' . $out;
334 my ($dev,$ino,$mode,$nlink,$uid,$gid);
339 if ( $follow_in_effect ) {
340 $out =~ s/lstat\(\$_\)/lstat(_)/;
343 # Traverse desired filesystems
344 File::Find::$find( {wanted => \\&wanted, follow => 1}, $roots);
355 # Traverse desired filesystems
356 File::Find::$find({wanted => \\&wanted}, $roots);
366 if (exists $init{doexec}) {
371 my @command = @_; # copy so we don't try to s/// aliases to constants
372 for my $word (@command)
373 { $word =~ s#{}#$name#g }
375 my $old = select(STDOUT);
379 return 0 unless <STDIN> =~ /^y/;
383 chdir $File::Find::dir;
390 if (exists $init{ls}) {
391 print <<'INTRO', <<"SUB", <<'END';
395 sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
399 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
401 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
406 or $blocks = int(($size + 1023) / 1024);
408 my $perms = $rwx[$mode & 7];
410 $perms = $rwx[$mode & 7] . $perms;
412 $perms = $rwx[$mode & 7] . $perms;
413 substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _;
414 substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _;
415 substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _;
416 if (-f _) { $perms = '-' . $perms; }
417 elsif (-d _) { $perms = 'd' . $perms; }
418 elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); }
419 elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); }
420 elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); }
421 elsif (-p _) { $perms = 'p' . $perms; }
422 elsif (-S _) { $perms = 's' . $perms; }
423 else { $perms = '?' . $perms; }
425 my $user = $user{$uid} || $uid;
426 my $group = $group{$gid} || $gid;
428 my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime);
429 if (-M _ > 365.25 / 2) {
432 $timeyear = sprintf("%02d:%02d", $hour, $min);
435 printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n",
454 if (exists $init{cpio} || exists $init{tar}) {
460 my ($fh, $varref, $blksz) = @_;
462 while (length($$varref) >= $blksz) {
464 syswrite($fh, $$varref, $blksz);
465 substr($$varref, 0, $blksz) = '';
474 if (exists $init{cpio}) {
475 print <<'INTRO', <<"SUB", <<'END';
481 my ($fh, $fname, $nc) = @_;
483 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
484 $atime,$mtime,$ctime,$blksize,$blocks);
487 if ( ! defined $fname ) {
488 $fname = 'TRAILER!!!';
489 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
490 $atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13;
492 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
494 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
497 open(IN, "./$_\0") || do {
498 warn "Couldn't open $fname: $!\n";
502 $text = readlink($_);
503 $size = 0 unless defined $text;
511 sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
525 $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
526 $cpout{$fh} .= pack("SSSSSSSSLSLa*",
527 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
528 length($fname)+1, $size,
529 $fname . (length($fname) & 1 ? "\0" : "\0\0"));
533 $cpout{$fh} .= $text;
536 flush($fh, \$cpout{$fh}, 5120)
537 while ($l = length($cpout{$fh})) >= 5120;
538 while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
539 flush($fh, \$cpout{$fh}, 5120);
540 $l = length($cpout{$fh});
547 for my $fh (keys %cpout) {
548 cpio($fh, undef, $nc{$fh});
549 $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
550 flush($fh, \$cpout{$fh}, 5120);
551 print $blocks{$fh} * 10, " blocks\n";
558 if (exists $init{tar}) {
559 print <<'INTRO', <<"SUB", <<'END';
565 my ($fh, $fname) = @_;
569 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
571 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
576 if ($linkname = $linkseen{$fh, $dev, $ino}) {
577 if (length($linkname) > 100) {
578 warn "$0: omitting file with linkname ",
579 "too long for tar output: $linkname\n";
585 $linkseen{$fh, $dev, $ino} = $fname;
588 if ($typeflag eq '0') {
590 open(IN, "./$_\0") || do {
591 warn "Couldn't open $fname: $!\n";
595 $linkname = readlink($_);
596 if (defined $linkname) { $typeflag = '2' }
597 elsif (-c _) { $typeflag = '3' }
598 elsif (-b _) { $typeflag = '4' }
599 elsif (-d _) { $typeflag = '5' }
600 elsif (-p _) { $typeflag = '6' }
604 if (length($fname) > 100) {
605 ($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#);
606 if (!defined($fname) || length($prefix) > 155) {
607 warn "$0: omitting file with name too long for tar output: ",
613 $size = 0 if $typeflag ne '0';
614 my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155",
616 sprintf("%7o ", $mode & 0777),
617 sprintf("%7o ", $uid & 0777777),
618 sprintf("%7o ", $gid & 0777777),
619 sprintf("%11o ", $size),
620 sprintf("%11o ", $mtime),
623 defined $linkname ? $linkname : '',
632 substr($header, 148, 8) = sprintf("%7o ", unpack("%16C*", $header));
633 my $l = length($header) % 512;
634 $tarout{$fh} .= $header;
635 $tarout{$fh} .= "\0" x (512 - $l) if $l;
638 flush($fh, \$tarout{$fh}, 10240)
639 while ($l = length($tarout{$fh})) >= 10240;
640 while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
641 my $slop = length($tarout{$fh}) % 512;
642 $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
643 flush($fh, \$tarout{$fh}, 10240);
644 $l = length($tarout{$fh});
652 for my $fh (keys %tarout) {
653 $len = 10240 - length($tarout{$fh});
654 $len += 10240 if $len < 1024;
655 $tarout{$fh} .= "\0" x $len;
656 flush($fh, \$tarout{$fh}, 10240);
665 ############################################################################
670 $tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4);
672 if ($_ =~ /^(?:name|print|prune|exec|ok|\(|\))/) {
673 $init{delayedstat} = 1;
675 my $statcall = '(($dev,$ino,$mode,$nlink,$uid,$gid) = '
677 if (exists $init{saw_or}) {
678 $tabstring .= "(\$nlink || $statcall) &&\n" . $tabstring;
680 $tabstring .= "$statcall &&\n" . $tabstring;
683 $init{declarestat} = 1;
686 $tabstring =~ s/^\s+/ / if $out =~ /!$/;
690 sub fileglob_to_re ($) {
692 $x =~ s#([./^\$()+])#\\$1#g;
693 $x =~ s#([?*])#.$1#g;
699 $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
700 $n =~ s/ 0*(\d)/ $1/;
706 $string =~ s/\\/\\\\/g;
707 $string =~ s/'/\\'/g;
715 find2perl - translate find command lines to Perl code
719 find2perl [paths] [predicates] | perl
723 find2perl is a little translator to convert find command lines to
724 equivalent Perl code. The resulting code is typically faster than
727 "paths" are a set of paths where find2perl will start its searches and
728 "predicates" are taken from the following list.
734 Negate the sense of the following predicate. The C<!> must be passed as
735 a distinct argument, so it may need to be surrounded by whitespace and/or
736 quoted from interpretation by the shell using a backslash (just as with
739 =item C<( PREDICATES )>
741 Group the given PREDICATES. The parentheses must be passed as distinct
742 arguments, so they may need to be surrounded by whitespace and/or
743 quoted from interpretation by the shell using a backslash (just as with
746 =item C<PREDICATE1 PREDICATE2>
748 True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not
749 evaluated if PREDICATE1 is false.
751 =item C<PREDICATE1 -o PREDICATE2>
753 True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is
754 not evaluated if PREDICATE1 is true.
758 Follow (dereference) symlinks. The checking of file attributes depends
759 on the position of the C<-follow> option. If it precedes the file
760 check option, an C<stat> is done which means the file check applies to the
761 file the symbolic link is pointing to. If C<-follow> option follows the
762 file check option, this now applies to the symbolic link itself, i.e.
767 Change directory traversal algorithm from breadth-first to depth-first.
771 Do not descend into the directory currently matched.
775 Do not traverse mount points (prunes search at mount-point directories).
779 File name matches specified GLOB wildcard pattern. GLOB may need to be
780 quoted to avoid interpretation by the shell (just as with using
785 Low-order 9 bits of permission match octal value PERM.
789 The bits specified in PERM are all set in file's permissions.
793 The file's type matches perl's C<-X> operator.
795 =item C<-fstype TYPE>
797 Filesystem of current path is of type TYPE (only NFS/non-NFS distinction
802 True if USER is owner of file.
804 =item C<-group GROUP>
806 True if file's group is GROUP.
810 True if file's owner is not in password database.
814 True if file's group is not in group database.
818 True file's inode number is INUM.
822 True if (hard) link count of file matches N (see below).
826 True if file's size matches N (see below) N is normally counted in
827 512-byte blocks, but a suffix of "c" specifies that size should be
828 counted in characters (bytes) and a suffix of "k" specifes that
829 size should be counted in 1024-byte blocks.
833 True if last-access time of file matches N (measured in days) (see
838 True if last-changed time of file's inode matches N (measured in days,
843 True if last-modified time of file matches N (measured in days, see below).
847 True if last-modified time of file matches N.
851 Print out path of file (always true). If none of C<-exec>, C<-ls>,
852 C<-print0>, or C<-ok> is specified, then C<-print> will be added
857 Like -print, but terminates with \0 instead of \n.
859 =item C<-exec OPTIONS ;>
861 exec() the arguments in OPTIONS in a subprocess; any occurrence of {} in
862 OPTIONS will first be substituted with the path of the current
863 file. Note that the command "rm" has been special-cased to use perl's
864 unlink() function instead (as an optimization). The C<;> must be passed as
865 a distinct argument, so it may need to be surrounded by whitespace and/or
866 quoted from interpretation by the shell using a backslash (just as with
869 =item C<-ok OPTIONS ;>
871 Like -exec, but first prompts user; if user's response does not begin
872 with a y, skip the exec. The C<;> must be passed as
873 a distinct argument, so it may need to be surrounded by whitespace and/or
874 quoted from interpretation by the shell using a backslash (just as with
879 Has the perl script eval() the EXPR.
883 Simulates C<-exec ls -dils {} ;>
887 Adds current output to tar-format FILE.
891 Adds current output to old-style cpio-format FILE.
895 Adds current output to "new"-style cpio-format FILE.
899 Predicates which take a numeric argument N can come in three forms:
901 * N is prefixed with a +: match values greater than N
902 * N is prefixed with a -: match values less than N
903 * N is not prefixed with either + or -: match only values equal to N
912 close OUT or die "Can't close $file: $!";
913 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
914 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';