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';
269 $out .= "\n" . tab . '&& print("$name\n")';
275 eval 'exec $perlpath -S \$0 \${1+"\$@"}'
276 if 0; #\$running_under_some_shell
281 # Set the variable \$File::Find::dont_use_nlink if you're using AFS,
284 # for the convenience of &wanted calls, including -eval statements:
285 use vars qw/*name *dir *prune/;
286 *name = *File::Find::name;
287 *dir = *File::Find::dir;
288 *prune = *File::Find::prune;
294 if (exists $init{doexec}) {
297 my $cwd = Cwd::cwd();
302 if (exists $init{ls}) {
304 my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx);
305 my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
310 if (exists $init{user} || exists $init{ls} || exists $init{tar}) {
311 print "my (%uid, %user);\n";
312 print "while (my (\$name, \$pw, \$uid) = getpwent) {\n";
313 print ' $uid{$name} = $uid{$uid} = $uid;', "\n"
314 if exists $init{user};
315 print ' $user{$uid} = $name unless exists $user{$uid};', "\n"
316 if exists $init{ls} || exists $init{tar};
320 if (exists $init{group} || exists $init{ls} || exists $init{tar}) {
321 print "my (%gid, %group);\n";
322 print "while (my (\$name, \$pw, \$gid) = getgrent) {\n";
323 print ' $gid{$name} = $gid{$gid} = $gid;', "\n"
324 if exists $init{group};
325 print ' $group{$gid} = $name unless exists $group{$gid};', "\n"
326 if exists $init{ls} || exists $init{tar};
330 print $initnewer, "\n" if $initnewer ne '';
331 print $initfile, "\n" if $initfile ne '';
332 $flushall .= "exit;\n";
333 if (exists $init{declarestat}) {
334 $out = <<'END' . $out;
335 my ($dev,$ino,$mode,$nlink,$uid,$gid);
340 if ( $follow_in_effect ) {
341 $out =~ s/lstat\(\$_\)/lstat(_)/;
344 # Traverse desired filesystems
345 File::Find::$find( {wanted => \\&wanted, follow => 1}, $roots);
356 # Traverse desired filesystems
357 File::Find::$find({wanted => \\&wanted}, $roots);
367 if (exists $init{doexec}) {
372 my @command = @_; # copy so we don't try to s/// aliases to constants
373 for my $word (@command)
374 { $word =~ s#{}#$name#g }
376 my $old = select(STDOUT);
380 return 0 unless <STDIN> =~ /^y/;
384 chdir $File::Find::dir;
391 if (exists $init{ls}) {
392 print <<'INTRO', <<"SUB", <<'END';
396 sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
400 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
402 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
407 or $blocks = int(($size + 1023) / 1024);
409 my $perms = $rwx[$mode & 7];
411 $perms = $rwx[$mode & 7] . $perms;
413 $perms = $rwx[$mode & 7] . $perms;
414 substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _;
415 substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _;
416 substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _;
417 if (-f _) { $perms = '-' . $perms; }
418 elsif (-d _) { $perms = 'd' . $perms; }
419 elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); }
420 elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); }
421 elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); }
422 elsif (-p _) { $perms = 'p' . $perms; }
423 elsif (-S _) { $perms = 's' . $perms; }
424 else { $perms = '?' . $perms; }
426 my $user = $user{$uid} || $uid;
427 my $group = $group{$gid} || $gid;
429 my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime);
430 if (-M _ > 365.25 / 2) {
433 $timeyear = sprintf("%02d:%02d", $hour, $min);
436 printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n",
455 if (exists $init{cpio} || exists $init{tar}) {
461 my ($fh, $varref, $blksz) = @_;
463 while (length($$varref) >= $blksz) {
465 syswrite($fh, $$varref, $blksz);
466 substr($$varref, 0, $blksz) = '';
475 if (exists $init{cpio}) {
476 print <<'INTRO', <<"SUB", <<'END';
482 my ($fh, $fname, $nc) = @_;
484 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
485 $atime,$mtime,$ctime,$blksize,$blocks);
488 if ( ! defined $fname ) {
489 $fname = 'TRAILER!!!';
490 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
491 $atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13;
493 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
495 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
498 open(IN, "./$_\0") || do {
499 warn "Couldn't open $fname: $!\n";
503 $text = readlink($_);
504 $size = 0 unless defined $text;
512 sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
526 $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
527 $cpout{$fh} .= pack("SSSSSSSSLSLa*",
528 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
529 length($fname)+1, $size,
530 $fname . (length($fname) & 1 ? "\0" : "\0\0"));
534 $cpout{$fh} .= $text;
537 flush($fh, \$cpout{$fh}, 5120)
538 while ($l = length($cpout{$fh})) >= 5120;
539 while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
540 flush($fh, \$cpout{$fh}, 5120);
541 $l = length($cpout{$fh});
548 for my $fh (keys %cpout) {
549 cpio($fh, undef, $nc{$fh});
550 $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
551 flush($fh, \$cpout{$fh}, 5120);
552 print $blocks{$fh} * 10, " blocks\n";
559 if (exists $init{tar}) {
560 print <<'INTRO', <<"SUB", <<'END';
566 my ($fh, $fname) = @_;
570 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
572 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
577 if ($linkname = $linkseen{$fh, $dev, $ino}) {
578 if (length($linkname) > 100) {
579 warn "$0: omitting file with linkname ",
580 "too long for tar output: $linkname\n";
586 $linkseen{$fh, $dev, $ino} = $fname;
589 if ($typeflag eq '0') {
591 open(IN, "./$_\0") || do {
592 warn "Couldn't open $fname: $!\n";
596 $linkname = readlink($_);
597 if (defined $linkname) { $typeflag = '2' }
598 elsif (-c _) { $typeflag = '3' }
599 elsif (-b _) { $typeflag = '4' }
600 elsif (-d _) { $typeflag = '5' }
601 elsif (-p _) { $typeflag = '6' }
605 if (length($fname) > 100) {
606 ($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#);
607 if (!defined($fname) || length($prefix) > 155) {
608 warn "$0: omitting file with name too long for tar output: ",
614 $size = 0 if $typeflag ne '0';
615 my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155",
617 sprintf("%7o ", $mode & 0777),
618 sprintf("%7o ", $uid & 0777777),
619 sprintf("%7o ", $gid & 0777777),
620 sprintf("%11o ", $size),
621 sprintf("%11o ", $mtime),
624 defined $linkname ? $linkname : '',
633 substr($header, 148, 8) = sprintf("%7o ", unpack("%16C*", $header));
634 my $l = length($header) % 512;
635 $tarout{$fh} .= $header;
636 $tarout{$fh} .= "\0" x (512 - $l) if $l;
639 flush($fh, \$tarout{$fh}, 10240)
640 while ($l = length($tarout{$fh})) >= 10240;
641 while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
642 my $slop = length($tarout{$fh}) % 512;
643 $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
644 flush($fh, \$tarout{$fh}, 10240);
645 $l = length($tarout{$fh});
653 for my $fh (keys %tarout) {
654 $len = 10240 - length($tarout{$fh});
655 $len += 10240 if $len < 1024;
656 $tarout{$fh} .= "\0" x $len;
657 flush($fh, \$tarout{$fh}, 10240);
666 ############################################################################
671 $tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4);
673 if ($_ =~ /^(?:name|print|prune|exec|ok|\(|\))/) {
674 $init{delayedstat} = 1;
676 my $statcall = '(($dev,$ino,$mode,$nlink,$uid,$gid) = '
678 if (exists $init{saw_or}) {
679 $tabstring .= "(\$nlink || $statcall) &&\n" . $tabstring;
681 $tabstring .= "$statcall &&\n" . $tabstring;
684 $init{declarestat} = 1;
687 $tabstring =~ s/^\s+/ / if $out =~ /!$/;
691 sub fileglob_to_re ($) {
693 $x =~ s#([./^\$()+])#\\$1#g;
694 $x =~ s#([?*])#.$1#g;
700 $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
701 $n =~ s/ 0*(\d)/ $1/;
707 $string =~ s/\\/\\\\/g;
708 $string =~ s/'/\\'/g;
716 find2perl - translate find command lines to Perl code
720 find2perl [paths] [predicates] | perl
724 find2perl is a little translator to convert find command lines to
725 equivalent Perl code. The resulting code is typically faster than
728 "paths" are a set of paths where find2perl will start its searches and
729 "predicates" are taken from the following list.
735 Negate the sense of the following predicate. The C<!> must be passed as
736 a distinct argument, so it may need to be surrounded by whitespace and/or
737 quoted from interpretation by the shell using a backslash (just as with
740 =item C<( PREDICATES )>
742 Group the given PREDICATES. The parentheses must be passed as distinct
743 arguments, so they may need to be surrounded by whitespace and/or
744 quoted from interpretation by the shell using a backslash (just as with
747 =item C<PREDICATE1 PREDICATE2>
749 True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not
750 evaluated if PREDICATE1 is false.
752 =item C<PREDICATE1 -o PREDICATE2>
754 True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is
755 not evaluated if PREDICATE1 is true.
759 Follow (dereference) symlinks. The checking of file attributes depends
760 on the position of the C<-follow> option. If it precedes the file
761 check option, an C<stat> is done which means the file check applies to the
762 file the symbolic link is pointing to. If C<-follow> option follows the
763 file check option, this now applies to the symbolic link itself, i.e.
768 Change directory traversal algorithm from breadth-first to depth-first.
772 Do not descend into the directory currently matched.
776 Do not traverse mount points (prunes search at mount-point directories).
780 File name matches specified GLOB wildcard pattern. GLOB may need to be
781 quoted to avoid interpretation by the shell (just as with using
786 Low-order 9 bits of permission match octal value PERM.
790 The bits specified in PERM are all set in file's permissions.
794 The file's type matches perl's C<-X> operator.
796 =item C<-fstype TYPE>
798 Filesystem of current path is of type TYPE (only NFS/non-NFS distinction
803 True if USER is owner of file.
805 =item C<-group GROUP>
807 True if file's group is GROUP.
811 True if file's owner is not in password database.
815 True if file's group is not in group database.
819 True file's inode number is INUM.
823 True if (hard) link count of file matches N (see below).
827 True if file's size matches N (see below) N is normally counted in
828 512-byte blocks, but a suffix of "c" specifies that size should be
829 counted in characters (bytes) and a suffix of "k" specifes that
830 size should be counted in 1024-byte blocks.
834 True if last-access time of file matches N (measured in days) (see
839 True if last-changed time of file's inode matches N (measured in days,
844 True if last-modified time of file matches N (measured in days, see below).
848 True if last-modified time of file matches N.
852 Print out path of file (always true). If none of C<-exec>, C<-ls>,
853 C<-print0>, or C<-ok> is specified, then C<-print> will be added
858 Like -print, but terminates with \0 instead of \n.
860 =item C<-exec OPTIONS ;>
862 exec() the arguments in OPTIONS in a subprocess; any occurrence of {} in
863 OPTIONS will first be substituted with the path of the current
864 file. Note that the command "rm" has been special-cased to use perl's
865 unlink() function instead (as an optimization). The C<;> must be passed as
866 a distinct argument, so it may need to be surrounded by whitespace and/or
867 quoted from interpretation by the shell using a backslash (just as with
870 =item C<-ok OPTIONS ;>
872 Like -exec, but first prompts user; if user's response does not begin
873 with a y, skip the exec. The C<;> must be passed as
874 a distinct argument, so it may need to be surrounded by whitespace and/or
875 quoted from interpretation by the shell using a backslash (just as with
880 Has the perl script eval() the EXPR.
884 Simulates C<-exec ls -dils {} ;>
888 Adds current output to tar-format FILE.
892 Adds current output to old-style cpio-format FILE.
896 Adds current output to "new"-style cpio-format FILE.
900 Predicates which take a numeric argument N can come in three forms:
902 * N is prefixed with a +: match values greater than N
903 * N is prefixed with a -: match values less than N
904 * N is not prefixed with either + or -: match only values equal to N
913 close OUT or die "Can't close $file: $!";
914 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
915 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';