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 = "$Config{perlpath}";
35 # In the following, perl variables are not expanded during extraction.
37 print OUT <<'!NO!SUBS!';
39 use vars qw/$statdone/;
40 my $startperl = "#! $perlpath -w";
43 # Modified September 26, 1993 to provide proper handling of years after 1999
44 # Tom Link <tml+@pitt.edu>
45 # University of Pittsburgh
47 # Modified April 7, 1998 with nasty hacks to implement the troublesome -follow
48 # Billy Constantine <wdconsta@cs.adelaide.edu.au> <billy@smug.adelaide.edu.au>
49 # University of Adelaide, Adelaide, South Australia
51 # Modified 1999-06-10, 1999-07-07 to migrate to cleaner perl5 usage
52 # Ken Pizzini <ken@halcyon.com>
55 while ($ARGV[0] =~ /^[^-!(]/) {
58 @roots = ('.') unless @roots;
59 for (@roots) { $_ = "e($_) }
60 my $roots = join(', ', @roots);
74 s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
82 } elsif ($_ eq 'follow') {
84 $decl = "\nmy %already_seen = ();\n";
85 $out .= &tab . '(not $already_seen{"$dev,$ino"}) &&' . "\n";
86 $out .= &tab . '(($already_seen{"$dev,$ino"} = !(-d _)) || 1)';
90 } elsif ($_ eq 'name') {
91 $out .= &tab . '/' . &fileglob_to_re(shift) . "/";
92 } elsif ($_ eq 'perm') {
95 || die "Malformed -perm argument: $onum\n";
97 if ($onum =~ s/^-//) {
98 $onum = sprintf("0%o", oct($onum) & 07777);
99 $out .= "((\$mode & $onum) == $onum)";
102 $out .= "((\$mode & 0777) == $onum)";
104 } elsif ($_ eq 'type') {
105 (my $filetest = shift) =~ tr/s/S/;
106 $out .= &tab . "-$filetest _";
107 } elsif ($_ eq 'print') {
108 $out .= &tab . 'print("$name\n")';
109 } elsif ($_ eq 'print0') {
110 $out .= &tab . 'print("$name\0")';
111 } elsif ($_ eq 'fstype') {
114 if ($type eq 'nfs') {
115 $out .= '($dev < 0)';
117 $out .= '($dev >= 0)'; #XXX
119 } elsif ($_ eq 'user') {
121 $out .= &tab . "(\$uid == \$uid{'$uname'})";
123 } elsif ($_ eq 'group') {
125 $out .= &tab . "(\$gid == \$gid{'$gname'})";
127 } elsif ($_ eq 'nouser') {
128 $out .= &tab . '!exists $uid{$uid}';
130 } elsif ($_ eq 'nogroup') {
131 $out .= &tab . '!exists $gid{$gid}';
133 } elsif ($_ eq 'links') {
134 $out .= &tab . &n('$nlink', shift);
135 } elsif ($_ eq 'inum') {
136 $out .= &tab . &n('$ino', shift);
137 } elsif ($_ eq 'size') {
139 my $n = 'int(((-s _) + 511) / 512)';
143 $n = 'int(((-s _) + 1023) / 1024)';
145 $out .= &tab . &n($n, $_);
146 } elsif ($_ eq 'atime') {
147 $out .= &tab . &n('int(-A _)', shift);
148 } elsif ($_ eq 'mtime') {
149 $out .= &tab . &n('int(-M _)', shift);
150 } elsif ($_ eq 'ctime') {
151 $out .= &tab . &n('int(-C _)', shift);
152 } elsif ($_ eq 'exec') {
154 while (@ARGV && $ARGV[0] ne ';')
155 { push(@cmd, shift) }
158 if ($cmd[0] =~m#^(?:(?:/usr)?/bin/)?rm$#
159 && $cmd[$#cmd] eq '{}'
160 && (@cmd == 2 || (@cmd == 3 && $cmd[1] eq '-f'))) {
162 $out .= '(unlink($_) || warn "$name: $!\n")';
164 $out .= 'unlink($_)';
166 $out .= '(unlink($_) || 1)';
171 { local $" = "','"; $out .= "&doexec(0, '@cmd')"; }
174 } elsif ($_ eq 'ok') {
176 while (@ARGV && $ARGV[0] ne ';')
177 { push(@cmd, shift) }
182 { local $" = "','"; $out .= "&doexec(0, '@cmd')"; }
184 } elsif ($_ eq 'prune') {
185 $out .= &tab . '($File::Find::prune = 1)';
186 } elsif ($_ eq 'xdev') {
187 $out .= &tab . '!($File::Find::prune |= ($dev != $File::Find::topdev))'
189 } elsif ($_ eq 'newer') {
191 my $newername = 'AGE_OF' . $file;
192 $newername =~ s/\W/_/g;
193 $newername = '$' . $newername;
194 $out .= &tab . "(-M _ < $newername)";
195 $initnewer .= "my $newername = -M " . "e($file) . ";\n";
196 } elsif ($_ eq 'eval') {
199 $out .= &tab . "eval {$prog}";
200 } elsif ($_ eq 'depth') {
203 } elsif ($_ eq 'ls') {
204 $out .= &tab . "&ls";
206 } elsif ($_ eq 'tar') {
207 die "-tar must have a filename argument\n" unless @ARGV;
209 my $fh = 'FH' . $file;
211 $out .= &tab . "&tar(*$fh, \$name)";
212 $flushall .= "&tflushall;\n";
213 $initfile .= "open($fh, " . "e('> ' . $file) .
214 qq{) || die "Can't open $fh: \$!\\n";\n};
216 } elsif (/^(n?)cpio$/) {
217 die "-$_ must have a filename argument\n" unless @ARGV;
219 my $fh = 'FH' . $file;
221 $out .= &tab . "&cpio(*$fh, \$name, '$1')";
223 $flushall .= "&cflushall;\n";
224 $initfile .= "open($fh, " . "e('> ' . $file) .
225 qq{) || die "Can't open $fh: \$!\\n";\n};
228 die "Unrecognized switch: -$_\n";
232 if ($ARGV[0] eq '-o') {
233 { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; }
234 $statdone = 0 if $indent_depth == 1 && exists $init{delayedstat};
238 $out .= " &&" unless $ARGV[0] eq ')';
240 shift if $ARGV[0] eq '-a';
248 eval 'exec $perlpath -S \$0 \${1+"\$@"}'
249 if 0; #\$running_under_some_shell
254 # Set the variable \$File::Find::dont_use_nlink if you're using AFS,
257 # for the convenience of &wanted calls, including -eval statements:
258 use vars qw/*name *dir *prune/;
259 *name = *File::Find::name;
260 *dir = *File::Find::dir;
261 *prune = *File::Find::prune;
266 if (exists $init{ls}) {
268 my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx);
269 my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
274 if (exists $init{user} || exists $init{ls} || exists $init{tar}) {
275 print "my (%uid, %user);\n";
276 print "while (my (\$name, \$pw, \$uid) = getpwent) {\n";
277 print ' $uid{$name} = $uid{$uid} = $uid;', "\n"
278 if exists $init{user};
279 print ' $user{$uid} = $name unless exists $user{$uid};', "\n"
280 if exists $init{ls} || exists $init{tar};
284 if (exists $init{group} || exists $init{ls} || exists $init{tar}) {
285 print "my (%gid, %group);\n";
286 print "while (my (\$name, \$pw, \$gid) = getgrent) {\n";
287 print ' $gid{$name} = $gid{$gid} = $gid;', "\n"
288 if exists $init{group};
289 print ' $group{$gid} = $name unless exists $group{$gid};', "\n"
290 if exists $init{ls} || exists $init{tar};
294 print $initnewer, "\n" if $initnewer ne '';
295 print $initfile, "\n" if $initfile ne '';
296 $flushall .= "exit;\n";
297 if (exists $init{declarestat}) {
298 $out = <<'END' . $out;
299 my ($dev,$ino,$mode,$nlink,$uid,$gid);
306 # Traverse desired filesystems
307 File::Find::$find(\\&wanted, $roots);
317 if (exists $init{doexec}) {
322 my $cwd = Cwd::cwd();
328 { $word =~ s#{}#$name#g }
330 my $old = select(STDOUT);
334 return 0 unless <STDIN> =~ /^y/;
338 chdir $File::Find::dir;
345 if (exists $init{ls}) {
346 print <<'INTRO', <<"SUB", <<'END';
350 sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
354 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
356 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
361 or $blocks = int(($size + 1023) / 1024);
363 my $perms = $rwx[$mode & 7];
365 $perms = $rwx[$mode & 7] . $perms;
367 $perms = $rwx[$mode & 7] . $perms;
368 substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _;
369 substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _;
370 substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _;
371 if (-f _) { $perms = '-' . $perms; }
372 elsif (-d _) { $perms = 'd' . $perms; }
373 elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); }
374 elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); }
375 elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); }
376 elsif (-p _) { $perms = 'p' . $perms; }
377 elsif (-S _) { $perms = 's' . $perms; }
378 else { $perms = '?' . $perms; }
380 my $user = $user{$uid} || $uid;
381 my $group = $group{$gid} || $gid;
383 my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime);
384 if (-M _ > 365.25 / 2) {
387 $timeyear = sprintf("%02d:%02d", $hour, $min);
390 printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n",
409 if (exists $init{cpio} || exists $init{tar}) {
415 my ($fh, $varref, $blksz) = @_;
417 while (length($$varref) >= $blksz) {
419 syswrite($fh, $$varref, $blksz);
420 substr($$varref, 0, $blksz) = '';
429 if (exists $init{cpio}) {
430 print <<'INTRO', <<"SUB", <<'END';
436 my ($fh, $fname, $nc) = @_;
438 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
439 $atime,$mtime,$ctime,$blksize,$blocks);
442 if ( ! defined $fname ) {
443 $fname = 'TRAILER!!!';
444 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
445 $atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13;
447 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
449 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
452 open(IN, "./$_\0") || do {
453 warn "Couldn't open $fname: $!\n";
457 $text = readlink($_);
458 $size = 0 unless defined $text;
466 sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
480 $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
481 $cpout{$fh} .= pack("SSSSSSSSLSLa*",
482 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
483 length($fname)+1, $size,
484 $fname . (length($fname) & 1 ? "\0" : "\0\0"));
488 $cpout{$fh} .= $text;
491 flush($fh, \$cpout{$fh}, 5120)
492 while ($l = length($cpout{$fh})) >= 5120;
493 while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
494 flush($fh, \$cpout{$fh}, 5120);
495 $l = length($cpout{$fh});
502 for my $fh (keys %cpout) {
503 &cpio($fh, undef, $nc{$fh});
504 $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
505 flush($fh, \$cpout{$fh}, 5120);
506 print $blocks{$fh} * 10, " blocks\n";
513 if (exists $init{tar}) {
514 print <<'INTRO', <<"SUB", <<'END';
520 my ($fh, $fname) = @_;
524 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
526 \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
531 if ($linkname = $linkseen{$fh, $dev, $ino}) {
532 if (length($linkname) > 100) {
533 warn "$0: omitting file with linkname ",
534 "too long for tar output: $linkname\n";
540 $linkseen{$fh, $dev, $ino} = $fname;
543 if ($typeflag eq '0') {
545 open(IN, "./$_\0") || do {
546 warn "Couldn't open $fname: $!\n";
550 $linkname = readlink($_);
551 if (defined $linkname) { $typeflag = '2' }
552 elsif (-c _) { $typeflag = '3' }
553 elsif (-b _) { $typeflag = '4' }
554 elsif (-d _) { $typeflag = '5' }
555 elsif (-p _) { $typeflag = '6' }
559 if (length($fname) > 100) {
560 ($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#);
561 if (!defined($fname) || length($prefix) > 155) {
562 warn "$0: omitting file with name too long for tar output: ",
568 $size = 0 if $typeflag ne '0';
569 my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155",
571 sprintf("%7o ", $mode & 0777),
572 sprintf("%7o ", $uid & 0777777),
573 sprintf("%7o ", $gid & 0777777),
574 sprintf("%11o ", $size),
575 sprintf("%11o ", $mtime),
578 defined $linkname ? $linkname : '',
587 substr($header, 148, 8) = sprintf("%7o ", unpack("%16C*", $header));
588 my $l = length($header) % 512;
589 $tarout{$fh} .= $header;
590 $tarout{$fh} .= "\0" x (512 - $l) if $l;
593 flush($fh, \$tarout{$fh}, 10240)
594 while ($l = length($tarout{$fh})) >= 10240;
595 while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
596 my $slop = length($tarout{$fh}) % 512;
597 $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
598 flush($fh, \$tarout{$fh}, 10240);
599 $l = length($tarout{$fh});
607 for my $fh (keys %tarout) {
608 $len = 10240 - length($tarout{$fh});
609 $len += 10240 if $len < 1024;
610 $tarout{$fh} .= "\0" x $len;
611 flush($fh, \$tarout{$fh}, 10240);
620 ############################################################################
625 $tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4);
627 if ($_ =~ /^(?:name|print|prune|exec|ok|\(|\))/) {
628 $init{delayedstat} = 1;
630 my $statcall = '(($dev,$ino,$mode,$nlink,$uid,$gid) = '
632 if (exists $init{saw_or}) {
633 $tabstring .= "(\$nlink || $statcall) &&\n" . $tabstring;
635 $tabstring .= "$statcall &&\n" . $tabstring;
638 $init{declarestat} = 1;
641 $tabstring =~ s/^\s+/ / if $out =~ /!$/;
647 $x =~ s#([./^\$()])#\\$1#g;
648 $x =~ s#([?*])#.$1#g;
654 $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
655 $n =~ s/ 0*(\d)/ $1/;
661 $string =~ s/'/\\'/g;
669 find2perl - translate find command lines to Perl code
673 find2perl [paths] [predicates] | perl
677 find2perl is a little translator to convert find command lines to
678 equivalent Perl code. The resulting code is typically faster than
681 "paths" are a set of paths where find2perl will start its searches and
682 "predicates" are taken from the following list.
688 Negate the sense of the following predicate. The C<!> must be passed as
689 a distinct argument, so it may need to be surrounded by whitespace and/or
690 quoted from interpretation by the shell using a backslash (just as with
693 =item C<( PREDICATES )>
695 Group the given PREDICATES. The parentheses must be passed as distinct
696 arguments, so they may need to be surrounded by whitespace and/or
697 quoted from interpretation by the shell using a backslash (just as with
700 =item C<PREDICATE1 PREDICATE2>
702 True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not
703 evaluated if PREDICATE1 is false.
705 =item C<PREDICATE1 -o PREDICATE2>
707 True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is
708 not evaluated if PREDICATE1 is true.
712 Follow (dereference) symlinks. [XXX doesn't work fully, see L<BUGS>]
716 Change directory traversal algorithm from breadth-first to depth-first.
720 Do not descend into the directory currently matched.
724 Do not traverse mount points (prunes search at mount-point directories).
728 File name matches specified GLOB wildcard pattern. GLOB may need to be
729 quoted to avoid interpretation by the shell (just as with using
734 Low-order 9 bits of permission match octal value PERM.
738 The bits specified in PERM are all set in file's permissions.
742 The file's type matches perl's C<-X> operator.
744 =item C<-fstype TYPE>
746 Filesystem of current path is of type TYPE (only NFS/non-NFS distinction
751 True if USER is owner of file.
753 =item C<-group GROUP>
755 True if file's group is GROUP.
759 True if file's owner is not in password database.
763 True if file's group is not in group database.
767 True file's inode number is INUM.
771 True if (hard) link count of file matches N (see below).
775 True if file's size matches N (see below) N is normally counted in
776 512-byte blocks, but a suffix of "c" specifies that size should be
777 counted in characters (bytes) and a suffix of "k" specifes that
778 size should be counted in 1024-byte blocks.
782 True if last-access time of file matches N (measured in days) (see
787 True if last-changed time of file's inode matches N (measured in days,
792 True if last-modified time of file matches N (measured in days, see below).
796 True if last-modified time of file matches N.
800 Print out path of file (always true).
804 Like -print, but terminates with \0 instead of \n.
806 =item C<-exec OPTIONS ;>
808 exec() the arguments in OPTIONS in a subprocess; any occurence of {} in
809 OPTIONS will first be substituted with the path of the current
810 file. Note that the command "rm" has been special-cased to use perl's
811 unlink() function instead (as an optimization). The C<;> must be passed as
812 a distinct argument, so it may need to be surrounded by whitespace and/or
813 quoted from interpretation by the shell using a backslash (just as with
816 =item C<-ok OPTIONS ;>
818 Like -exec, but first prompts user; if user's response does not begin
819 with a y, skip the exec. The C<;> must be passed as
820 a distinct argument, so it may need to be surrounded by whitespace and/or
821 quoted from interpretation by the shell using a backslash (just as with
824 =item C<-eval EXPR ;>
826 Has the perl script eval() the EXPR. The C<;> must be passed as
827 a distinct argument, so it may need to be surrounded by whitespace and/or
828 quoted from interpretation by the shell using a backslash (just as with
833 Simulates C<-exec ls -dils {} ;>
837 Adds current output to tar-format FILE.
841 Adds current output to old-style cpio-format FILE.
845 Adds current output to "new"-style cpio-format FILE.
849 Predicates which take a numeric argument N can come in three forms:
851 * N is prefixed with a +: match values greater than N
852 * N is prefixed with a -: match values less than N
853 * N is not prefixed with either + or -: match only values equal to N
857 The -follow option doesn't really work yet, because File::Find doesn't
858 support following symlinks.
867 close OUT or die "Can't close $file: $!";
868 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
869 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';