[perl5.git] / x2p / find2perl.PL

#!/usr/local/bin/perl

use Config;
use File::Basename qw(&basename &dirname);
use Cwd;

# List explicitly here the variables you want Configure to
# generate.  Metaconfig only looks for shell variables, so you
# have to mention them as if they were shell variables, not
# %Config entries.  Thus you write
#  $startperl
# to ensure Configure will look for $Config{startperl}.

# This forces PL files to create target in same directory as PL file.
# This is so that make depend always knows where to find PL derivatives.
$origdir = cwd;
chdir dirname($0);
$file = basename($0, '.PL');
$file .= '.com' if $^O eq 'VMS';

open OUT,">$file" or die "Can't create $file: $!";

print "Extracting $file (with variable substitutions)\n";

# In this section, perl variables will be expanded during extraction.
# You can use $Config{...} to use Configure variables.

print OUT <<"!GROK!THIS!";
$Config{startperl}
    eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
      if \$running_under_some_shell;
\$startperl = "$Config{startperl}";
\$perlpath = "$Config{perlpath}";
!GROK!THIS!

# In the following, perl variables are not expanded during extraction.

print OUT <<'!NO!SUBS!';

# 
# Modified September 26, 1993 to provide proper handling of years after 1999
#   Tom Link <tml+@pitt.edu>
#   University of Pittsburgh
# 
# Modified April 7, 1998 with nasty hacks to implement the troublesome -follow
#  Billy Constantine <wdconsta@cs.adelaide.edu.au> <billy@smug.adelaide.edu.au>
#  University of Adelaide, Adelaide, South Australia
# 

while ($ARGV[0] =~ /^[^-!(]/) {
    push(@roots, shift);
}
@roots = ('.') unless @roots;
for (@roots) { $_ = &quote($_); }
$roots = join(',', @roots);

$indent = 1;
$stat = 'lstat';
$decl = '';

while (@ARGV) {
    $_ = shift;
    s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
    if ($_ eq '(') {
	$out .= &tab . "(\n";
	$indent++;
	next;
    }
    elsif ($_ eq ')') {
	$indent--;
	$out .= &tab . ")";
    }
    elsif ($_ eq 'follow') {
	$stat = 'stat';
	$decl = '%already_seen = ();';
	$out .= &tab . '(not $already_seen{"$dev,$ino"}) &&';
	$out .= "\n" . &tab . '(($already_seen{"$dev,$ino"} = !(-d _)) || 1)';
    }
    elsif ($_ eq '!') {
	$out .= &tab . "!";
	next;
    }
    elsif ($_ eq 'name') {
	$out .= &tab;
	$pat = &fileglob_to_re(shift);
	$out .= '/' . $pat . "/";
    }
    elsif ($_ eq 'perm') {
	$onum = shift;
	die "Malformed -perm argument: $onum\n" unless $onum =~ /^-?[0-7]+$/;
	if ($onum =~ s/^-//) {
	    $onum = '0' . sprintf("%o", oct($onum) & 017777);	# s/b 07777 ?
	    $out .= &tab . "((\$mode & $onum) == $onum)";
	}
	else {
	    $onum = '0' . $onum unless $onum =~ /^0/;
	    $out .= &tab . "((\$mode & 0777) == $onum)";
	}
    }
    elsif ($_ eq 'type') {
	($filetest = shift) =~ tr/s/S/;
	$out .= &tab . "-$filetest _";
    }
    elsif ($_ eq 'print') {
	$out .= &tab . 'print("$name\n")';
    }
    elsif ($_ eq 'print0') {
	$out .= &tab . 'print("$name\0")';
    }
    elsif ($_ eq 'fstype') {
	$out .= &tab;
	$type = shift;
	if ($type eq 'nfs')
	    { $out .= '($dev < 0)'; }
	else
	    { $out .= '($dev >= 0)'; }
    }
    elsif ($_ eq 'user') {
	$uname = shift;
	$out .= &tab . "(\$uid == \$uid{'$uname'})";
	$inituser++;
    }
    elsif ($_ eq 'group') {
	$gname = shift;
	$out .= &tab . "(\$gid == \$gid{'$gname'})";
	$initgroup++;
    }
    elsif ($_ eq 'nouser') {
	$out .= &tab . '!defined $uid{$uid}';
	$inituser++;
    }
    elsif ($_ eq 'nogroup') {
	$out .= &tab . '!defined $gid{$gid}';
	$initgroup++;
    }
    elsif ($_ eq 'links') {
	$out .= &tab . '($nlink ' . &n(shift);
    }
    elsif ($_ eq 'inum') {
	$out .= &tab . '($ino ' . &n(shift);
    }
    elsif ($_ eq 'size') {
	$out .= &tab . '(int(((-s _) + 511) / 512) ' . &n(shift);
    }
    elsif ($_ eq 'atime') {
	$out .= &tab . '(int(-A _) ' . &n(shift);
    }
    elsif ($_ eq 'mtime') {
	$out .= &tab . '(int(-M _) ' . &n(shift);
    }
    elsif ($_ eq 'ctime') {
	$out .= &tab . '(int(-C _) ' . &n(shift);
    }
    elsif ($_ eq 'exec') {
	for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
	shift;
	$_ = "@cmd";
	if (m#^(/bin/)?rm -f {}$#) {
	    if (!@ARGV) {
		$out .= &tab . 'unlink($_)';
	    }
	    else {
		$out .= &tab . '(unlink($_) || 1)';
	    }
	}
	elsif (m#^(/bin/)?rm {}$#) {
	    $out .= &tab . '(unlink($_) || warn "$name: $!\n")';
	}
	else {
	    for (@cmd) { s/'/\\'/g; }
	    $" = "','";
	    $out .= &tab . "&exec(0, '@cmd')";
	    $" = ' ';
	    $initexec++;
	}
    }
    elsif ($_ eq 'ok') {
	for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
	shift;
	for (@cmd) { s/'/\\'/g; }
	$" = "','";
	$out .= &tab . "&exec(1, '@cmd')";
	$" = ' ';
	$initexec++;
    }
    elsif ($_ eq 'prune') {
	$out .= &tab . '($prune = 1)';
    }
    elsif ($_ eq 'xdev') {
	$out .= &tab . '!($prune |= ($dev != $topdev))';
    }
    elsif ($_ eq 'newer') {
	$out .= &tab;
	$file = shift;
	$newername = 'AGE_OF' . $file;
	$newername =~ s/[^\w]/_/g;
	$newername = "\$$newername";
	$out .= "(-M _ < $newername)";
	$initnewer .= "$newername = -M " . &quote($file) . ";\n";
    }
    elsif ($_ eq 'eval') {
	$prog = &quote(shift);
	$out .= &tab . "eval $prog";
    }
    elsif ($_ eq 'depth') {
	$depth++;
	next;
    }
    elsif ($_ eq 'ls') {
	$out .= &tab . "&ls";
	$initls++;
    }
    elsif ($_ eq 'tar') {
	$out .= &tab;
	die "-tar must have a filename argument\n" unless @ARGV;
	$file = shift;
	$fh = 'FH' . $file;
	$fh =~ s/[^\w]/_/g;
	$out .= "&tar($fh)";
	$file = '>' . $file;
	$initfile .= "open($fh, " . &quote($file) .
	  qq{) || die "Can't open $fh: \$!\\n";\n};
	$inittar++;
	$flushall = "\n&tflushall;\n";
    }
    elsif (/^n?cpio$/) {
	$depth++;
	$out .= &tab;
	die "-$_ must have a filename argument\n" unless @ARGV;
	$file = shift;
	$fh = 'FH' . $file;
	$fh =~ s/[^\w]/_/g;
	$out .= "&cpio('" . substr($_,0,1) . "', $fh)";
	$file = '>' . $file;
	$initfile .= "open($fh, " . &quote($file) .
	  qq{) || die "Can't open $fh: \$!\\n";\n};
	$initcpio++;
	$flushall = "\n&flushall;\n";
    }
    else {
	die "Unrecognized switch: -$_\n";
    }
    if (@ARGV) {
	if ($ARGV[0] eq '-o') {
	    { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; }
	    $statdone = 0 if $indent == 1 && $delayedstat;
	    $saw_or++;
	    shift;
	}
	else {
	    $out .= " &&" unless $ARGV[0] eq ')';
	    $out .= "\n";
	    shift if $ARGV[0] eq '-a';
	}
    }
}

print <<"END";
$startperl
    eval 'exec $perlpath -S \$0 \${1+"\$@"}'
	if \$running_under_some_shell;

END

if ($initls) {
    print <<'END';
@rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
@moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);

END
}

if ($inituser || $initls) {
    print 'while (($name, $pw, $uid) = getpwent) {', "\n";
    print '    $uid{$name} = $uid{$uid} = $uid;', "\n" if $inituser;
    print '    $user{$uid} = $name unless $user{$uid};', "\n" if $initls;
    print "}\n\n";
}

if ($initgroup || $initls) {
    print 'while (($name, $pw, $gid) = getgrent) {', "\n";
    print '    $gid{$name} = $gid{$gid} = $gid;', "\n" if $initgroup;
    print '    $group{$gid} = $name unless $group{$gid};', "\n" if $initls;
    print "}\n\n";
}

print $initnewer, "\n" if $initnewer;

print $initfile, "\n" if $initfile;

$find = $depth ? "finddepth" : "find";
print <<"END";
require "$find.pl";

# Traverse desired filesystems

$decl
&$find($roots);
$flushall
exit;
sub wanted {
$out;
}

END

if ($initexec) {
    print <<'END';
sub exec {
    local($ok, @cmd) = @_;
    foreach $word (@cmd) {
	$word =~ s#{}#$name#g;
    }
    if ($ok) {
	local($old) = select(STDOUT);
	$| = 1;
	print "@cmd";
	select($old);
	return 0 unless <STDIN> =~ /^y/;
    }
    chdir $cwd;		# sigh
    system @cmd;
    chdir $dir;
    return !$?;
}

END
}

if ($initls) {
    print <<"INTERP", <<'END';
sub ls {
    (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$sizemm,
      \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\);
INTERP

    $pname = $name;

    if (defined $blocks) {
	$blocks = int(($blocks + 1) / 2);
    }
    else {
	$blocks = int(($size + 1023) / 1024);
    }

    if    (-f _) { $perms = '-'; }
    elsif (-d _) { $perms = 'd'; }
    elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
    elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
    elsif (-p _) { $perms = 'p'; }
    elsif (-S _) { $perms = 's'; }
    else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }

    $tmpmode = $mode;
    $tmp = $rwx[$tmpmode & 7];
    $tmpmode >>= 3;
    $tmp = $rwx[$tmpmode & 7] . $tmp;
    $tmpmode >>= 3;
    $tmp = $rwx[$tmpmode & 7] . $tmp;
    substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
    substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
    substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
    $perms .= $tmp;

    $user = $user{$uid} || $uid;
    $group = $group{$gid} || $gid;

    ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
    $moname = $moname[$mon];
    if (-M _ > 365.25 / 2) {
	$timeyear = $year + 1900;
    }
    else {
	$timeyear = sprintf("%02d:%02d", $hour, $min);
    }

    printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
	    $ino,
		 $blocks,
		      $perms,
			    $nlink,
				$user,
				     $group,
					  $sizemm,
					      $moname,
						 $mday,
						     $timeyear,
							 $pname;
    1;
}

sub sizemm {
    sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255);
}

END
}

if ($initcpio) {
print <<'START', <<"INTERP", <<'END';
sub cpio {
    local($nc,$fh) = @_;
    local($text);

    if ($name eq 'TRAILER!!!') {
	$text = '';
	$size = 0;
    }
    else {
START
	(\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$size,
	  \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\);
INTERP
	if (-f _) {
	    open(IN, "./$_\0") || do {
		warn "Couldn't open $name: $!\n";
		return;
	    };
	}
	else {
	    $text = readlink($_);
	    $size = 0 unless defined $text;
	}
    }

    ($nm = $name) =~ s#^\./##;
    $nc{$fh} = $nc;
    if ($nc eq 'n') {
	$cpout{$fh} .=
	  sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
	    070707,
	    $dev & 0777777,
	    $ino & 0777777,
	    $mode & 0777777,
	    $uid & 0777777,
	    $gid & 0777777,
	    $nlink & 0777777,
	    $rdev & 0177777,
	    $mtime,
	    length($nm)+1,
	    $size,
	    $nm);
    }
    else {
	$cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
	$cpout{$fh} .= pack("SSSSSSSSLSLa*",
	    070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
	    length($nm)+1, $size, $nm . (length($nm) & 1 ? "\0" : "\0\0"));
    }
    if ($text ne '') {
	$cpout{$fh} .= $text;
    }
    elsif ($size) {
	&flush($fh) while ($l = length($cpout{$fh})) >= 5120;
	while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
	    &flush($fh);
	    $l = length($cpout{$fh});
	}
    }
    close IN;
}

sub flush {
    local($fh) = @_;

    while (length($cpout{$fh}) >= 5120) {
	syswrite($fh,$cpout{$fh},5120);
	++$blocks{$fh};
	substr($cpout{$fh}, 0, 5120) = '';
    }
}

sub flushall {
    $name = 'TRAILER!!!';
    foreach $fh (keys %cpout) {
	&cpio($nc{$fh},$fh);
	$cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
	&flush($fh);
	print $blocks{$fh} * 10, " blocks\n";
    }
}

END
}

if ($inittar) {
print <<'START', <<"INTERP", <<'END';
sub tar {
    local($fh) = @_;
    local($linkname,$header,$l,$slop);
    local($linkflag) = "\0";

START
    (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$size,
      \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\);
INTERP
    $nm = $name;
    if ($nlink > 1) {
	if ($linkname = $linkseen{$fh,$dev,$ino}) {
	    $linkflag = 1;
	}
	else {
	    $linkseen{$fh,$dev,$ino} = $nm;
	}
    }
    if (-f _) {
	open(IN, "./$_\0") || do {
	    warn "Couldn't open $name: $!\n";
	    return;
	};
	$size = 0 if $linkflag ne "\0";
    }
    else {
	$linkname = readlink($_);
	$linkflag = 2 if defined $linkname;
	$nm .= '/' if -d _;
	$size = 0;
    }

    $header = pack("a100a8a8a8a12a12a8a1a100",
	$nm,
	sprintf("%6o ", $mode & 0777),
	sprintf("%6o ", $uid & 0777777),
	sprintf("%6o ", $gid & 0777777),
	sprintf("%11o ", $size),
	sprintf("%11o ", $mtime),
	"        ",
	$linkflag,
	$linkname);
    $l = length($header) % 512;
    substr($header, 148, 6) = sprintf("%6o", unpack("%16C*", $header));
    substr($header, 154, 1) = "\0";  # blech
    $tarout{$fh} .= $header;
    $tarout{$fh} .= "\0" x (512 - $l) if $l;
    if ($size) {
	&tflush($fh) while ($l = length($tarout{$fh})) >= 10240;
	while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
	    $slop = length($tarout{$fh}) % 512;
	    $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
	    &tflush($fh);
	    $l = length($tarout{$fh});
	}
    }
    close IN;
}

sub tflush {
    local($fh) = @_;

    while (length($tarout{$fh}) >= 10240) {
	syswrite($fh,$tarout{$fh},10240);
	++$blocks{$fh};
	substr($tarout{$fh}, 0, 10240) = '';
    }
}

sub tflushall {
    local($len);

    foreach $fh (keys %tarout) {
	$len = 10240 - length($tarout{$fh});
	$len += 10240 if $len < 1024;
	$tarout{$fh} .= "\0" x $len;
	&tflush($fh);
    }
}

END
}

exit;

############################################################################

sub tab {
    local($tabstring);

    $tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4);
    if (!$statdone) {
	if ($_ =~ /^(name|print|prune|exec|ok|\(|\))/) {
	    $delayedstat++;
	}
	else {
	    if ($saw_or) {
		$tabstring .= <<"ENDOFSTAT" . $tabstring;
(\$nlink || ((\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid) = $stat\(\$_\))) &&
ENDOFSTAT
	    }
	    else {
		$tabstring .= <<"ENDOFSTAT" . $tabstring;
((\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid) = $stat\(\$_\)) &&
ENDOFSTAT
	    }
	    $statdone = 1;
	}
    }
    $tabstring =~ s/^\s+/ / if $out =~ /!$/;
    $tabstring;
}

sub fileglob_to_re {
    local($tmp) = @_;

    $tmp =~ s#([./^\$()])#\\$1#g;
    $tmp =~ s/([?*])/.$1/g;
    "^$tmp\$";
}

sub n {
    local($n) = @_;

    $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
    $n =~ s/ 0*(\d)/ $1/;
    $n . ')';
}

sub quote {
    local($string) = @_;
    $string =~ s/'/\\'/;
    "'$string'";
}
!NO!SUBS!

close OUT or die "Can't close $file: $!";
chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
chdir $origdir;
Commit	Line	Data
4633a7c4 LW	1	#!/usr/local/bin/perl
	2
	3	use Config;
	4	use File::Basename qw(&basename &dirname);
8a5546a1	5	use Cwd;
4633a7c4 LW	6
	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
	11	# $startperl
	12	# to ensure Configure will look for $Config{startperl}.
	13
	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.
8a5546a1	16	$origdir = cwd;
44a8e56a	17	chdir dirname($0);
44a8e56a	18	$file = basename($0, '.PL');
774d564b	19	$file .= '.com' if $^O eq 'VMS';
4633a7c4 LW	20
	21	open OUT,">$file" or die "Can't create $file: $!";
	22
	23	print "Extracting $file (with variable substitutions)\n";
	24
	25	# In this section, perl variables will be expanded during extraction.
	26	# You can use $Config{...} to use Configure variables.
	27
	28	print OUT <<"!GROK!THIS!";
5f05dabc	29	$Config{startperl}
5f05dabc	30	eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
7b8d334a	31	if \$running_under_some_shell;
f70b6ff5	32	\$startperl = "$Config{startperl}";
5f05dabc	33	\$perlpath = "$Config{perlpath}";
4633a7c4 LW	34	!GROK!THIS!
	35
	36	# In the following, perl variables are not expanded during extraction.
	37
	38	print OUT <<'!NO!SUBS!';
7b8d334a	39
93a17b20 LW	40	#
	41	# Modified September 26, 1993 to provide proper handling of years after 1999
	42	# Tom Link <tml+@pitt.edu>
	43	# University of Pittsburgh
7b8d334a GS	44	#
	45	# Modified April 7, 1998 with nasty hacks to implement the troublesome -follow
	46	# Billy Constantine <wdconsta@cs.adelaide.edu.au> <billy@smug.adelaide.edu.au>
	47	# University of Adelaide, Adelaide, South Australia
	48	#
fe14fcc3	49
fe14fcc3 LW	50	while ($ARGV[0] =~ /^[^-!(]/) {
	51	push(@roots, shift);
	52	}
	53	@roots = ('.') unless @roots;
	54	for (@roots) { $_ = &quote($_); }
	55	$roots = join(',', @roots);
	56
	57	$indent = 1;
7b8d334a GS	58	$stat = 'lstat';
7b8d334a GS	59	$decl = '';
fe14fcc3 LW	60
	61	while (@ARGV) {
	62	$_ = shift;
	63	s/^-// \|\| /^[()!]/ \|\| die "Unrecognized switch: $_\n";
	64	if ($_ eq '(') {
	65	$out .= &tab . "(\n";
	66	$indent++;
	67	next;
	68	}
	69	elsif ($_ eq ')') {
	70	$indent--;
	71	$out .= &tab . ")";
	72	}
7b8d334a GS	73	elsif ($_ eq 'follow') {
	74	$stat = 'stat';
	75	$decl = '%already_seen = ();';
	76	$out .= &tab . '(not $already_seen{"$dev,$ino"}) &&';
	77	$out .= "\n" . &tab . '(($already_seen{"$dev,$ino"} = !(-d _)) \|\| 1)';
	78	}
fe14fcc3 LW	79	elsif ($_ eq '!') {
	80	$out .= &tab . "!";
	81	next;
	82	}
	83	elsif ($_ eq 'name') {
	84	$out .= &tab;
	85	$pat = &fileglob_to_re(shift);
	86	$out .= '/' . $pat . "/";
	87	}
	88	elsif ($_ eq 'perm') {
	89	$onum = shift;
	90	die "Malformed -perm argument: $onum\n" unless $onum =~ /^-?[0-7]+$/;
	91	if ($onum =~ s/^-//) {
	92	$onum = '0' . sprintf("%o", oct($onum) & 017777); # s/b 07777 ?
e334a159	93	$out .= &tab . "((\$mode & $onum) == $onum)";
fe14fcc3 LW	94	}
	95	else {
	96	$onum = '0' . $onum unless $onum =~ /^0/;
e334a159	97	$out .= &tab . "((\$mode & 0777) == $onum)";
fe14fcc3 LW	98	}
	99	}
	100	elsif ($_ eq 'type') {
	101	($filetest = shift) =~ tr/s/S/;
	102	$out .= &tab . "-$filetest _";
	103	}
	104	elsif ($_ eq 'print') {
	105	$out .= &tab . 'print("$name\n")';
	106	}
	107	elsif ($_ eq 'print0') {
	108	$out .= &tab . 'print("$name\0")';
	109	}
	110	elsif ($_ eq 'fstype') {
	111	$out .= &tab;
	112	$type = shift;
	113	if ($type eq 'nfs')
79072805	114	{ $out .= '($dev < 0)'; }
fe14fcc3	115	else
79072805	116	{ $out .= '($dev >= 0)'; }
fe14fcc3 LW	117	}
	118	elsif ($_ eq 'user') {
	119	$uname = shift;
79072805	120	$out .= &tab . "(\$uid == \$uid{'$uname'})";
fe14fcc3 LW	121	$inituser++;
	122	}
	123	elsif ($_ eq 'group') {
	124	$gname = shift;
79072805	125	$out .= &tab . "(\$gid == \$gid{'$gname'})";
fe14fcc3 LW	126	$initgroup++;
	127	}
	128	elsif ($_ eq 'nouser') {
	129	$out .= &tab . '!defined $uid{$uid}';
	130	$inituser++;
	131	}
	132	elsif ($_ eq 'nogroup') {
	133	$out .= &tab . '!defined $gid{$gid}';
	134	$initgroup++;
	135	}
	136	elsif ($_ eq 'links') {
79072805	137	$out .= &tab . '($nlink ' . &n(shift);
fe14fcc3 LW	138	}
fe14fcc3 LW	139	elsif ($_ eq 'inum') {
79072805	140	$out .= &tab . '($ino ' . &n(shift);
fe14fcc3 LW	141	}
fe14fcc3 LW	142	elsif ($_ eq 'size') {
463ee0b2	143	$out .= &tab . '(int(((-s _) + 511) / 512) ' . &n(shift);
fe14fcc3 LW	144	}
fe14fcc3 LW	145	elsif ($_ eq 'atime') {
79072805	146	$out .= &tab . '(int(-A _) ' . &n(shift);
fe14fcc3 LW	147	}
fe14fcc3 LW	148	elsif ($_ eq 'mtime') {
79072805	149	$out .= &tab . '(int(-M _) ' . &n(shift);
fe14fcc3 LW	150	}
fe14fcc3 LW	151	elsif ($_ eq 'ctime') {
79072805	152	$out .= &tab . '(int(-C _) ' . &n(shift);
fe14fcc3 LW	153	}
	154	elsif ($_ eq 'exec') {
	155	for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
	156	shift;
6e21c824 LW	157	$_ = "@cmd";
	158	if (m#^(/bin/)?rm -f {}$#) {
	159	if (!@ARGV) {
	160	$out .= &tab . 'unlink($_)';
	161	}
	162	else {
	163	$out .= &tab . '(unlink($_) \|\| 1)';
	164	}
	165	}
	166	elsif (m#^(/bin/)?rm {}$#) {
	167	$out .= &tab . '(unlink($_) \|\| warn "$name: $!\n")';
	168	}
	169	else {
	170	for (@cmd) { s/'/\\'/g; }
	171	$" = "','";
	172	$out .= &tab . "&exec(0, '@cmd')";
	173	$" = ' ';
	174	$initexec++;
	175	}
fe14fcc3 LW	176	}
	177	elsif ($_ eq 'ok') {
	178	for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
	179	shift;
	180	for (@cmd) { s/'/\\'/g; }
	181	$" = "','";
	182	$out .= &tab . "&exec(1, '@cmd')";
	183	$" = ' ';
	184	$initexec++;
	185	}
	186	elsif ($_ eq 'prune') {
	187	$out .= &tab . '($prune = 1)';
	188	}
	189	elsif ($_ eq 'xdev') {
a0d0e21e	190	$out .= &tab . '!($prune \|= ($dev != $topdev))';
fe14fcc3 LW	191	}
	192	elsif ($_ eq 'newer') {
	193	$out .= &tab;
	194	$file = shift;
	195	$newername = 'AGE_OF' . $file;
	196	$newername =~ s/[^\w]/_/g;
7b8d334a	197	$newername = "\$$newername";
79072805	198	$out .= "(-M _ < $newername)";
fe14fcc3 LW	199	$initnewer .= "$newername = -M " . &quote($file) . ";\n";
	200	}
	201	elsif ($_ eq 'eval') {
	202	$prog = &quote(shift);
	203	$out .= &tab . "eval $prog";
	204	}
	205	elsif ($_ eq 'depth') {
	206	$depth++;
	207	next;
	208	}
	209	elsif ($_ eq 'ls') {
	210	$out .= &tab . "&ls";
	211	$initls++;
	212	}
	213	elsif ($_ eq 'tar') {
	214	$out .= &tab;
	215	die "-tar must have a filename argument\n" unless @ARGV;
	216	$file = shift;
	217	$fh = 'FH' . $file;
	218	$fh =~ s/[^\w]/_/g;
	219	$out .= "&tar($fh)";
	220	$file = '>' . $file;
	221	$initfile .= "open($fh, " . &quote($file) .
	222	qq{) \|\| die "Can't open $fh: \$!\\n";\n};
	223	$inittar++;
	224	$flushall = "\n&tflushall;\n";
	225	}
	226	elsif (/^n?cpio$/) {
	227	$depth++;
	228	$out .= &tab;
	229	die "-$_ must have a filename argument\n" unless @ARGV;
	230	$file = shift;
	231	$fh = 'FH' . $file;
	232	$fh =~ s/[^\w]/_/g;
	233	$out .= "&cpio('" . substr($_,0,1) . "', $fh)";
	234	$file = '>' . $file;
	235	$initfile .= "open($fh, " . &quote($file) .
	236	qq{) \|\| die "Can't open $fh: \$!\\n";\n};
	237	$initcpio++;
	238	$flushall = "\n&flushall;\n";
	239	}
	240	else {
	241	die "Unrecognized switch: -$_\n";
	242	}
	243	if (@ARGV) {
	244	if ($ARGV[0] eq '-o') {
6e21c824	245	{ local($statdone) = 1; $out .= "\n" . &tab . "\|\|\n"; }
1c3d792e LW	246	$statdone = 0 if $indent == 1 && $delayedstat;
1c3d792e LW	247	$saw_or++;
fe14fcc3 LW	248	shift;
	249	}
	250	else {
	251	$out .= " &&" unless $ARGV[0] eq ')';
	252	$out .= "\n";
	253	shift if $ARGV[0] eq '-a';
	254	}
	255	}
	256	}
	257
	258	print <<"END";
4633a7c4	259	$startperl
5f05dabc	260	eval 'exec $perlpath -S \$0 \${1+"\$@"}'
8adcabd8 LW	261	if \$running_under_some_shell;
8adcabd8 LW	262
fe14fcc3 LW	263	END
	264
	265	if ($initls) {
	266	print <<'END';
	267	@rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
	268	@moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
	269
	270	END
	271	}
	272
	273	if ($inituser \|\| $initls) {
	274	print 'while (($name, $pw, $uid) = getpwent) {', "\n";
	275	print ' $uid{$name} = $uid{$uid} = $uid;', "\n" if $inituser;
	276	print ' $user{$uid} = $name unless $user{$uid};', "\n" if $initls;
	277	print "}\n\n";
	278	}
	279
	280	if ($initgroup \|\| $initls) {
	281	print 'while (($name, $pw, $gid) = getgrent) {', "\n";
	282	print ' $gid{$name} = $gid{$gid} = $gid;', "\n" if $initgroup;
	283	print ' $group{$gid} = $name unless $group{$gid};', "\n" if $initls;
	284	print "}\n\n";
	285	}
	286
	287	print $initnewer, "\n" if $initnewer;
	288
	289	print $initfile, "\n" if $initfile;
	290
6e21c824	291	$find = $depth ? "finddepth" : "find";
fe14fcc3	292	print <<"END";
6e21c824 LW	293	require "$find.pl";
6e21c824 LW	294
fe14fcc3 LW	295	# Traverse desired filesystems
fe14fcc3 LW	296
7b8d334a	297	$decl
6e21c824	298	&$find($roots);
fe14fcc3 LW	299	$flushall
fe14fcc3 LW	300	exit;
fe14fcc3 LW	301	sub wanted {
	302	$out;
	303	}
	304
	305	END
	306
fe14fcc3 LW	307	if ($initexec) {
	308	print <<'END';
	309	sub exec {
	310	local($ok, @cmd) = @_;
	311	foreach $word (@cmd) {
	312	$word =~ s#{}#$name#g;
	313	}
	314	if ($ok) {
	315	local($old) = select(STDOUT);
	316	$\| = 1;
	317	print "@cmd";
	318	select($old);
	319	return 0 unless <STDIN> =~ /^y/;
	320	}
	321	chdir $cwd; # sigh
	322	system @cmd;
	323	chdir $dir;
	324	return !$?;
	325	}
	326
	327	END
	328	}
	329
	330	if ($initls) {
7b8d334a	331	print <<"INTERP", <<'END';
fe14fcc3	332	sub ls {
7b8d334a GS	333	(\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$sizemm,
	334	\$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\);
	335	INTERP
fe14fcc3 LW	336
	337	$pname = $name;
	338
	339	if (defined $blocks) {
	340	$blocks = int(($blocks + 1) / 2);
	341	}
	342	else {
	343	$blocks = int(($size + 1023) / 1024);
	344	}
	345
	346	if (-f _) { $perms = '-'; }
	347	elsif (-d _) { $perms = 'd'; }
	348	elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
	349	elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
	350	elsif (-p _) { $perms = 'p'; }
	351	elsif (-S _) { $perms = 's'; }
	352	else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
	353
	354	$tmpmode = $mode;
	355	$tmp = $rwx[$tmpmode & 7];
	356	$tmpmode >>= 3;
	357	$tmp = $rwx[$tmpmode & 7] . $tmp;
	358	$tmpmode >>= 3;
	359	$tmp = $rwx[$tmpmode & 7] . $tmp;
	360	substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
	361	substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
	362	substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
	363	$perms .= $tmp;
	364
	365	$user = $user{$uid} \|\| $uid;
	366	$group = $group{$gid} \|\| $gid;
	367
	368	($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
	369	$moname = $moname[$mon];
	370	if (-M _ > 365.25 / 2) {
93a17b20	371	$timeyear = $year + 1900;
fe14fcc3 LW	372	}
	373	else {
	374	$timeyear = sprintf("%02d:%02d", $hour, $min);
	375	}
	376
	377	printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
	378	$ino,
	379	$blocks,
	380	$perms,
	381	$nlink,
	382	$user,
	383	$group,
	384	$sizemm,
	385	$moname,
	386	$mday,
	387	$timeyear,
	388	$pname;
	389	1;
	390	}
	391
	392	sub sizemm {
	393	sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255);
	394	}
	395
	396	END
	397	}
	398
	399	if ($initcpio) {
7b8d334a	400	print <<'START', <<"INTERP", <<'END';
fe14fcc3 LW	401	sub cpio {
	402	local($nc,$fh) = @_;
	403	local($text);
	404
	405	if ($name eq 'TRAILER!!!') {
	406	$text = '';
	407	$size = 0;
	408	}
	409	else {
7b8d334a GS	410	START
	411	(\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$size,
	412	\$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\);
	413	INTERP
fe14fcc3	414	if (-f _) {
99b89507	415	open(IN, "./$_\0") \|\| do {
fe14fcc3 LW	416	warn "Couldn't open $name: $!\n";
	417	return;
	418	};
	419	}
	420	else {
	421	$text = readlink($_);
	422	$size = 0 unless defined $text;
	423	}
	424	}
	425
	426	($nm = $name) =~ s#^\./##;
	427	$nc{$fh} = $nc;
	428	if ($nc eq 'n') {
	429	$cpout{$fh} .=
	430	sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
	431	070707,
	432	$dev & 0777777,
	433	$ino & 0777777,
	434	$mode & 0777777,
	435	$uid & 0777777,
	436	$gid & 0777777,
	437	$nlink & 0777777,
	438	$rdev & 0177777,
	439	$mtime,
	440	length($nm)+1,
	441	$size,
	442	$nm);
	443	}
	444	else {
	445	$cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
	446	$cpout{$fh} .= pack("SSSSSSSSLSLa*",
	447	070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
	448	length($nm)+1, $size, $nm . (length($nm) & 1 ? "\0" : "\0\0"));
	449	}
	450	if ($text ne '') {
	451	$cpout{$fh} .= $text;
	452	}
	453	elsif ($size) {
	454	&flush($fh) while ($l = length($cpout{$fh})) >= 5120;
	455	while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
	456	&flush($fh);
	457	$l = length($cpout{$fh});
	458	}
	459	}
	460	close IN;
	461	}
	462
	463	sub flush {
	464	local($fh) = @_;
	465
	466	while (length($cpout{$fh}) >= 5120) {
	467	syswrite($fh,$cpout{$fh},5120);
	468	++$blocks{$fh};
	469	substr($cpout{$fh}, 0, 5120) = '';
	470	}
	471	}
	472
	473	sub flushall {
	474	$name = 'TRAILER!!!';
	475	foreach $fh (keys %cpout) {
	476	&cpio($nc{$fh},$fh);
	477	$cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
	478	&flush($fh);
	479	print $blocks{$fh} * 10, " blocks\n";
480	}
481	}
482
483	END
484	}
485
486	if ($inittar) {
7b8d334a	487	print <<'START', <<"INTERP", <<'END';
fe14fcc3 LW	488	sub tar {
	489	local($fh) = @_;
	490	local($linkname,$header,$l,$slop);
	491	local($linkflag) = "\0";
	492
7b8d334a GS	493	START
	494	(\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$size,
	495	\$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\);
	496	INTERP
fe14fcc3 LW	497	$nm = $name;
	498	if ($nlink > 1) {
	499	if ($linkname = $linkseen{$fh,$dev,$ino}) {
	500	$linkflag = 1;
	501	}
	502	else {
	503	$linkseen{$fh,$dev,$ino} = $nm;
	504	}
	505	}
	506	if (-f _) {
99b89507	507	open(IN, "./$_\0") \|\| do {
fe14fcc3 LW	508	warn "Couldn't open $name: $!\n";
	509	return;
	510	};
	511	$size = 0 if $linkflag ne "\0";
	512	}
	513	else {
	514	$linkname = readlink($_);
	515	$linkflag = 2 if defined $linkname;
	516	$nm .= '/' if -d _;
	517	$size = 0;
	518	}
	519
	520	$header = pack("a100a8a8a8a12a12a8a1a100",
	521	$nm,
	522	sprintf("%6o ", $mode & 0777),
	523	sprintf("%6o ", $uid & 0777777),
	524	sprintf("%6o ", $gid & 0777777),
	525	sprintf("%11o ", $size),
	526	sprintf("%11o ", $mtime),
	527	" ",
	528	$linkflag,
	529	$linkname);
	530	$l = length($header) % 512;
	531	substr($header, 148, 6) = sprintf("%6o", unpack("%16C*", $header));
	532	substr($header, 154, 1) = "\0"; # blech
	533	$tarout{$fh} .= $header;
	534	$tarout{$fh} .= "\0" x (512 - $l) if $l;
	535	if ($size) {
	536	&tflush($fh) while ($l = length($tarout{$fh})) >= 10240;
	537	while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
	538	$slop = length($tarout{$fh}) % 512;
	539	$tarout{$fh} .= "\0" x (512 - $slop) if $slop;
	540	&tflush($fh);
	541	$l = length($tarout{$fh});
	542	}
	543	}
	544	close IN;
	545	}
	546
	547	sub tflush {
	548	local($fh) = @_;
	549
	550	while (length($tarout{$fh}) >= 10240) {
	551	syswrite($fh,$tarout{$fh},10240);
	552	++$blocks{$fh};
	553	substr($tarout{$fh}, 0, 10240) = '';
	554	}
	555	}
	556
	557	sub tflushall {
	558	local($len);
	559
	560	foreach $fh (keys %tarout) {
	561	$len = 10240 - length($tarout{$fh});
	562	$len += 10240 if $len < 1024;
	563	$tarout{$fh} .= "\0" x $len;
	564	&tflush($fh);
	565	}
	566	}
	567
	568	END
	569	}
	570
	571	exit;
572
573	############################################################################
574
575	sub tab {
576	local($tabstring);
577
578	$tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4);
1c3d792e	579	if (!$statdone) {
8adcabd8	580	if ($_ =~ /^(name\|print\|prune\|exec\|ok\|\(\|\))/) {
1c3d792e LW	581	$delayedstat++;
	582	}
	583	else {
	584	if ($saw_or) {
7b8d334a GS	585	$tabstring .= <<"ENDOFSTAT" . $tabstring;
7b8d334a GS	586	(\$nlink \|\| ((\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid) = $stat\(\$_\))) &&
1c3d792e LW	587	ENDOFSTAT
	588	}
	589	else {
7b8d334a GS	590	$tabstring .= <<"ENDOFSTAT" . $tabstring;
7b8d334a GS	591	((\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid) = $stat\(\$_\)) &&
fe14fcc3	592	ENDOFSTAT
1c3d792e	593	}
fe14fcc3 LW	594	$statdone = 1;
	595	}
	596	}
	597	$tabstring =~ s/^\s+/ / if $out =~ /!$/;
	598	$tabstring;
	599	}
	600
	601	sub fileglob_to_re {
	602	local($tmp) = @_;
	603
79072805	604	$tmp =~ s#([./^\$()])#\\$1#g;
fe14fcc3	605	$tmp =~ s/([?*])/.$1/g;
8990e307	606	"^$tmp\$";
fe14fcc3 LW	607	}
	608
	609	sub n {
	610	local($n) = @_;
	611
1c3d792e LW	612	$n =~ s/^-/< / \|\| $n =~ s/^\+/> / \|\| $n =~ s/^/== /;
1c3d792e LW	613	$n =~ s/ 0*(\d)/ $1/;
79072805	614	$n . ')';
fe14fcc3 LW	615	}
	616
	617	sub quote {
	618	local($string) = @_;
	619	$string =~ s/'/\\'/;
	620	"'$string'";
	621	}
	622	!NO!SUBS!
4633a7c4 LW	623
	624	close OUT or die "Can't close $file: $!";
	625	chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
	626	exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
8a5546a1	627	chdir $origdir;