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}";
219 } elsif ($_ eq 'depth') {
222 } elsif ($_ eq 'ls') {
224 $declaresubs .= "sub ls ();\n";
227 } elsif ($_ eq 'tar') {
228 die "-tar must have a filename argument\n" unless @ARGV;
230 my $fh = 'FH' . $file;
232 $out .= tab . "tar(*$fh, \$name)";
233 $flushall .= "tflushall;\n";
234 $declaresubs .= "sub tar;\nsub tflushall ();\n";
235 $initfile .= "open($fh, " . quote('> ' . $file) .
236 qq{) || die "Can't open $fh: \$!\\n";\n};
238 } elsif (/^(n?)cpio\z/) {
239 die "-$_ must have a filename argument\n" unless @ARGV;
241 my $fh = 'FH' . $file;
243 $out .= tab . "cpio(*$fh, \$name, '$1')";
245 $flushall .= "cflushall;\n";
246 $declaresubs .= "sub cpio;\nsub cflushall ();\n";
247 $initfile .= "open($fh, " . quote('> ' . $file) .
248 qq{) || die "Can't open $fh: \$!\\n";\n};
251 die "Unrecognized switch: -$_\n";
255 if ($ARGV[0] eq '-o') {
256 { local($statdone) = 1; $out .= "\n" . tab . "||\n"; }
257 $statdone = 0 if $indent_depth == 1 && exists $init{delayedstat};
261 $out .= " &&" unless $Skip_And || $ARGV[0] eq ')';
263 shift if $ARGV[0] eq '-a';
270 if ($t !~ /&&\s*$/) { $t .= '&& ' }
271 $out .= "\n" . $t . 'print("$name\n")';
277 eval 'exec $perlpath -S \$0 \${1+"\$@"}'
278 if 0; #\$running_under_some_shell
283 # Set the variable \$File::Find::dont_use_nlink if you're using AFS,
286 # for the convenience of &wanted calls, including -eval statements:
287 use vars qw/*name *dir *prune/;
288 *name = *File::Find::name;
289 *dir = *File::Find::dir;
290 *prune = *File::Find::prune;
296 if (exists $init{doexec}) {
299 my $cwd = Cwd::cwd();
304 if (exists $init{ls}) {
306 my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx);
307 my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
312 if (exists $init{user} || exists $init{ls} || exists $init{tar}) {
313 print "my (%uid, %user);\n";
314 print "while (my (\$name, \$pw, \$uid) = getpwent) {\n";
315 print ' $uid{$name} = $uid{$uid} = $uid;', "\n"
316 if exists $init{user};
317 print ' $user{$uid} = $name unless exists $user{$uid};', "\n"
318 if exists $init{ls} || exists $init{tar};
322 if (exists $init{group} || exists $init{ls} || exists $init{tar}) {
323 print "my (%gid, %group);\n";
324 print "while (my (\$name, \$pw, \$gid) = getgrent) {\n";
325 print ' $gid{$name} = $gid{$gid} = $gid;', "\n"
326 if exists $init{group};
327 print ' $group{$gid} = $name unless exists $group{$gid};', "\n"
328 if exists $init{ls} || exists $init{tar};
332 print $initnewer, "\n" if $initnewer ne '';
333 print $initfile, "\n" if $initfile ne '';
334 $flushall .= "exit;\n";
335 if (exists $init{declarestat}) {
336 $out = <<'END' . $out;
337 my ($dev,$ino,$mode,$nlink,$uid,$gid);
342 if ( $follow_in_effect ) {
343 $out =~ s/lstat\(\$_\)/lstat(_)/;
346 # Traverse desired filesystems
347 File::Find::$find( {wanted => \\&wanted, follow => 1}, $roots);
358 # Traverse desired filesystems
359 File::Find::$find({wanted => \\&wanted}, $roots);
369 if (exists $init{doexec}) {
374 my @command = @_; # copy so we don't try to s/// aliases to constants
375 for my $word (@command)
376 { $word =~ s#{}#$name#g }
378 my $old = select(STDOUT);
382 return 0 unless <STDIN> =~ /^y/;
386 chdir $File::Find::dir;
393 if (exists $init{ls}) {
394 print <<'INTRO', <<"SUB", <<'END';
398 sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
402 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
404 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
409 or $blocks = int(($size + 1023) / 1024);
411 my $perms = $rwx[$mode & 7];
413 $perms = $rwx[$mode & 7] . $perms;
415 $perms = $rwx[$mode & 7] . $perms;
416 substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _;
417 substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _;
418 substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _;
419 if (-f _) { $perms = '-' . $perms; }
420 elsif (-d _) { $perms = 'd' . $perms; }
421 elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); }
422 elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); }
423 elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); }
424 elsif (-p _) { $perms = 'p' . $perms; }
425 elsif (-S _) { $perms = 's' . $perms; }
426 else { $perms = '?' . $perms; }
428 my $user = $user{$uid} || $uid;
429 my $group = $group{$gid} || $gid;
431 my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime);
432 if (-M _ > 365.25 / 2) {
435 $timeyear = sprintf("%02d:%02d", $hour, $min);
438 printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n",
457 if (exists $init{cpio} || exists $init{tar}) {
463 my ($fh, $varref, $blksz) = @_;
465 while (length($$varref) >= $blksz) {
467 syswrite($fh, $$varref, $blksz);
468 substr($$varref, 0, $blksz) = '';
477 if (exists $init{cpio}) {
478 print <<'INTRO', <<"SUB", <<'END';
484 my ($fh, $fname, $nc) = @_;
486 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
487 $atime,$mtime,$ctime,$blksize,$blocks);
490 if ( ! defined $fname ) {
491 $fname = 'TRAILER!!!';
492 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
493 $atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13;
495 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
497 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
500 open(IN, "./$_\0") || do {
501 warn "Couldn't open $fname: $!\n";
505 $text = readlink($_);
506 $size = 0 unless defined $text;
514 sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
528 $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
529 $cpout{$fh} .= pack("SSSSSSSSLSLa*",
530 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
531 length($fname)+1, $size,
532 $fname . (length($fname) & 1 ? "\0" : "\0\0"));
536 $cpout{$fh} .= $text;
539 flush($fh, \$cpout{$fh}, 5120)
540 while ($l = length($cpout{$fh})) >= 5120;
541 while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
542 flush($fh, \$cpout{$fh}, 5120);
543 $l = length($cpout{$fh});
550 for my $fh (keys %cpout) {
551 cpio($fh, undef, $nc{$fh});
552 $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
553 flush($fh, \$cpout{$fh}, 5120);
554 print $blocks{$fh} * 10, " blocks\n";
561 if (exists $init{tar}) {
562 print <<'INTRO', <<"SUB", <<'END';
568 my ($fh, $fname) = @_;
572 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
574 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
579 if ($linkname = $linkseen{$fh, $dev, $ino}) {
580 if (length($linkname) > 100) {
581 warn "$0: omitting file with linkname ",
582 "too long for tar output: $linkname\n";
588 $linkseen{$fh, $dev, $ino} = $fname;
591 if ($typeflag eq '0') {
593 open(IN, "./$_\0") || do {
594 warn "Couldn't open $fname: $!\n";
598 $linkname = readlink($_);
599 if (defined $linkname) { $typeflag = '2' }
600 elsif (-c _) { $typeflag = '3' }
601 elsif (-b _) { $typeflag = '4' }
602 elsif (-d _) { $typeflag = '5' }
603 elsif (-p _) { $typeflag = '6' }
607 if (length($fname) > 100) {
608 ($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#);
609 if (!defined($fname) || length($prefix) > 155) {
610 warn "$0: omitting file with name too long for tar output: ",
616 $size = 0 if $typeflag ne '0';
617 my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155",
619 sprintf("%7o ", $mode & 0777),
620 sprintf("%7o ", $uid & 0777777),
621 sprintf("%7o ", $gid & 0777777),
622 sprintf("%11o ", $size),
623 sprintf("%11o ", $mtime),
626 defined $linkname ? $linkname : '',
635 substr($header, 148, 8) = sprintf("%7o ", unpack("%16C*", $header));
636 my $l = length($header) % 512;
637 $tarout{$fh} .= $header;
638 $tarout{$fh} .= "\0" x (512 - $l) if $l;
641 flush($fh, \$tarout{$fh}, 10240)
642 while ($l = length($tarout{$fh})) >= 10240;
643 while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
644 my $slop = length($tarout{$fh}) % 512;
645 $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
646 flush($fh, \$tarout{$fh}, 10240);
647 $l = length($tarout{$fh});
655 for my $fh (keys %tarout) {
656 $len = 10240 - length($tarout{$fh});
657 $len += 10240 if $len < 1024;
658 $tarout{$fh} .= "\0" x $len;
659 flush($fh, \$tarout{$fh}, 10240);
668 ############################################################################
673 $tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4);
675 if ($_ =~ /^(?:name|print|prune|exec|ok|\(|\))/) {
676 $init{delayedstat} = 1;
678 my $statcall = '(($dev,$ino,$mode,$nlink,$uid,$gid) = '
680 if (exists $init{saw_or}) {
681 $tabstring .= "(\$nlink || $statcall) &&\n" . $tabstring;
683 $tabstring .= "$statcall &&\n" . $tabstring;
686 $init{declarestat} = 1;
689 $tabstring =~ s/^\s+/ / if $out =~ /!$/;
693 sub fileglob_to_re ($) {
695 $x =~ s#([./^\$()+])#\\$1#g;
696 $x =~ s#([?*])#.$1#g;
702 $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
703 $n =~ s/ 0*(\d)/ $1/;
709 $string =~ s/\\/\\\\/g;
710 $string =~ s/'/\\'/g;
718 find2perl - translate find command lines to Perl code
722 find2perl [paths] [predicates] | perl
726 find2perl is a little translator to convert find command lines to
727 equivalent Perl code. The resulting code is typically faster than
730 "paths" are a set of paths where find2perl will start its searches and
731 "predicates" are taken from the following list.
737 Negate the sense of the following predicate. The C<!> must be passed as
738 a distinct argument, so it may need to be surrounded by whitespace and/or
739 quoted from interpretation by the shell using a backslash (just as with
742 =item C<( PREDICATES )>
744 Group the given PREDICATES. The parentheses must be passed as distinct
745 arguments, so they may need to be surrounded by whitespace and/or
746 quoted from interpretation by the shell using a backslash (just as with
749 =item C<PREDICATE1 PREDICATE2>
751 True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not
752 evaluated if PREDICATE1 is false.
754 =item C<PREDICATE1 -o PREDICATE2>
756 True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is
757 not evaluated if PREDICATE1 is true.
761 Follow (dereference) symlinks. The checking of file attributes depends
762 on the position of the C<-follow> option. If it precedes the file
763 check option, an C<stat> is done which means the file check applies to the
764 file the symbolic link is pointing to. If C<-follow> option follows the
765 file check option, this now applies to the symbolic link itself, i.e.
770 Change directory traversal algorithm from breadth-first to depth-first.
774 Do not descend into the directory currently matched.
778 Do not traverse mount points (prunes search at mount-point directories).
782 File name matches specified GLOB wildcard pattern. GLOB may need to be
783 quoted to avoid interpretation by the shell (just as with using
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" specifes 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 ':';