#! /local/bin/perl 

######################################################################
# $Header: /loc/adm/slink-1.0/src/slink-5.0/Slink/RCS/Tester.pm,v 5.0 1996/05/13 17:14:27 couch Exp $
#  Slink::Tester.pm: Test constructor for slink and its associated commands. 
#  Revision 5.0
#  by
#  Alva L. Couch,                       
#  Associate Prof. of EE/CS          
#  Department of EE/CS             
#  Tufts University,            
#  Medford, Massachusetts, 02155.
#  couch@cs.tufts.edu
#
#  Copyright (C) 1996 by Alva L. Couch 
#
#  This file is part of SLINK
#
#  SLINK is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2, or (at your option)
#  any later version.
#
#  SLINK is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with GNU CC; see the file COPYING.  If not, write to
#  the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
######################################################################

package Slink::Tester;
require 5.001;
require Exporter;
require "newgetopt.pl";
use Slink::TrueName(qw(truename concat)); 
use strict;

BEGIN {
    @Slink::Tester::ISA = qw(Exporter);
    @Slink::Tester::EXPORT = qw(onetest getopts getname);
    @Slink::Tester::EXPORT_OK = (qw(build check));

    $Tester::size = 1; 
}

# get a string of safe options to forward to slink

sub getopts {
    if (!&NGetOpt(
	'-',        # options start with -
	'debug',    # debugging output
	'verbose',  # verbose output
	'echo',     # echo logs
	'nolock',   # don't use lockfile to lock out multiple instances.
	'nomap',    # don't use mapfile for read or write.
	'quiet',    # don't echo errors to the controlling terminal.
	'remap',    # don't read the mapfile before starting.
	'show',     # for tester; show actions as done. 
	'test=s',   # read test to do.

    )) {
	print STDERR "invalid options specified!\n"; 
	print STDERR "valid options are -echo, -verbose, -debug\n"; 
	print STDERR " -nolock, -nomap, -quiet, -remap, -test=id\n"; 
	exit 1; 
    }


    return  ($Slink::Tester::opt_debug   ? "-debug "   : "")
          . ($Slink::Tester::opt_verbose ? "-verbose " : "")
          . ($Slink::Tester::opt_echo    ? "-echo "    : "")
          . ($Slink::Tester::opt_nolock  ? "-nolock "  : "")
          . ($Slink::Tester::opt_nomap   ? "-nomap "   : "")
          . ($Slink::Tester::opt_quiet   ? "-quiet "   : "")
          . ($Slink::Tester::opt_remap   ? "-remap "   : "");
}

# get a name to use as an index 

sub getname {
    my (@tests) = @_; 
    my $i;
    for ($i=0; $i<@tests; $i++) {
	last if $tests[$i] eq $Slink::Tester::opt_test; 
    }
    if (@tests>0 && $i>=@tests) {
	print STDERR "invalid test '$Slink::Tester::opt_test'; "; 
        print STDERR "valid tests are "; 
	print STDERR join(' ',@tests); print STDERR "\n"; 
	exit 1; 
    }
    return $Slink::Tester::opt_test; 
}

# make one test from an associative ref

sub onetest {
    my ($ref) = @_; 

    my ($files) = $ref->{'files'}; 
    # $files = $files->{$name} if ref $files eq 'HASH'; 
    if (defined $files) {
	if (-e $files) {
	    (!(system("rm -rf $files/*")/256))
		|| die  "can't empty $files"; 
	}
    } else {
	print STDERR "no file directory specified\n"; 
	return 0; 
    }
    print STDERR "file tree root is $files\n\n" 
	if $Slink::Tester::opt_show; 

    my ($confs) = $ref->{'confs'}; 
    # $confs = $confs->{$name} if ref $confs eq 'HASH'; 
    if (defined $confs) {
	if (-e $confs) {
	    (!(system("rm -rf $confs/*")/256))
		|| die  "can't empty $confs"; 
	}
    } else {
	print STDERR "no conf directory specified\n"; 
	return 0; 
    }
    print STDERR "config tree root is $confs\n\n" 
	if $Slink::Tester::opt_show; 

    my ($mod) = $ref->{'mod'}; 
    # $mod = $mod->{$name} if ref $mod eq 'HASH'; 
    if (defined $mod) {
	open (FILE,">$confs/slink.mod") || die "can't write slink.mod"; 
	print FILE $mod; 
	close FILE; 
	chown owner($Slink::TestParams::muser), 
	      group($Slink::TestParams::mgroup),
	      "$confs/slink.mod"
	    || die "can't chown $confs/slink.mod"; 
	print STDERR "Contents of $confs/slink.mod:\n$mod\n"
	    if $Slink::Tester::opt_show; 
    }

    my ($conf) = $ref->{'conf'}; 
    # $conf = $conf->{$name} if ref $conf eq 'HASH'; 
    if (defined $conf) {
	open (FILE,">$confs/slink.conf") || die "can't write slink.conf"; 
	print FILE $conf; 
	close FILE; 
	chown owner($Slink::TestParams::muser), 
	      group($Slink::TestParams::mgroup),
	      "$confs/slink.conf"
	    || die "can't chown $confs/slink.conf"; 
	print STDERR "Contents of $confs/slink.conf:\n$conf\n"
	    if $Slink::Tester::opt_show; 
    }

    my ($map) = $ref->{'map'}; 
    # $map = $map->{$name} if ref $map eq 'HASH'; 
    if (defined $map) {
	open (FILE,">$confs/slink.map") || die "can't write slink.map"; 
	print FILE $map; 
	close FILE; 
	chown owner($Slink::TestParams::muser), 
	      group($Slink::TestParams::mgroup),
	      "$confs/slink.map"
	    || die "can't chown $confs/slink.map"; 
	print STDERR "Contents of $confs/slink.map:\n$map\n"
	    if $Slink::Tester::opt_show; 
    }

    my ($start) = $ref->{'start'}; 
    # $start = $start->{$name} if ref $start eq 'HASH'; 
    if (defined $start) {
	if (!build($files,split("\n",$start))) {
	    print STDERR "build failed\n"; 
	    return 0; 
	}
	if ($Slink::Tester::opt_show) { 
	    print STDERR "Expected contents of $files:\n$start\n"; 
	    print STDERR "Actual contents of $files:\n"; 
	    lsprint($files); 
	    print STDERR "\n"; 
	}
    } else {
	print STDERR "no start specified\n"; 
	return 0; 
    }

    my ($command) = $ref->{'command'}; 
    # $command = $command->{$name} if ref $command eq 'HASH'; 
    if (defined $command) {
	print STDERR "executing $command\n\n"
	    if $Slink::Tester::opt_show; 
	system ($command); 
    } else {
	print STDERR "no command specified\n"; 
    }

    my $ret; 
    my ($end) = $ref->{'end'}; 
    # $end = $end->{$name} if ref $end eq 'HASH'; 
    if (defined $end) {
	if ($Slink::Tester::opt_show) {
	    print STDERR "Expected contents of $files:\n$end\n"; 
	    print STDERR "Actual contents of $files:\n"; 
	    lsprint($files); 
	    print STDERR "\n"; 
	}
	
	$ret = check($files,split("\n",$end)); 
    } else {
	print STDERR "no end specified\n"; 
	return 0; 
    }
    return  $ret;
}

#################################################################
#  build a file tree for coherence with starting state
#################################################################

sub build {
    my ($base, @script) = @_; 
    make_path_to("$base/.") if ! -e $base; 

    my $cwd; 
    my $truebase = truename($base, $cwd); 
    die "$base doesn't exist" if ! defined $truebase; 
    $base = $truebase; 

    my $line; 
    my $errors; 
    foreach $line (@script) {
	chomp $line; 
        next if $line =~ /^[ \t]*$/ || $line =~ /^[ \t]*#/;
        my @fields = split(/[ \t]+/, $line); 
	shift @fields while $fields[0] eq ''; 

	my $mode = mode($fields[0]); my $mask = known($fields[0]); 
	if (! defined $mode) { 
	    print STDERR "build: invalid mode $fields[0]\n";
	    $errors++; 
	}

	my $owner = owner($fields[1]); 
	if (! defined $owner) {
	    print STDERR "build: invalid owner $fields[1]\n"; 
	    $errors++; 
        }

	my $group = group($fields[2]); 
	if (! defined $group) {
	    print STDERR "build: invalid group $fields[2]\n";
	    $errors++; 
	}

	if (! defined $mode || ! defined $owner || ! defined $group) { 
	    print STDERR "line: $line\n"; next; 
	}
	
	if (@fields == 4) {
	    my $target = $fields[3]; 
	    $target = concat($base,$target); 
	    if (isdir($fields[0])) {
		build_dir($mode, $owner, $group, $target); 
	    } else {
		build_file($mode, $owner, $group, $target); 
	    }
	} elsif (@fields == 6) {

	    my $target = $fields[3]; 
	    $target = concat($base,$target); 

	    if ($fields[4] eq '=') {

		my $source = $fields[5]; 
		$source = concat($base,$source); 
		build_copy($mode, $owner, $group, $source, $target); 

	    } elsif ($fields[4] eq '->') {

		my $source = $fields[5]; 
		$source = concat($base,$source)
		    if $source =~ /^\//; 
		build_link($source,$target); 

	    } else {
		print STDERR "invalid equivalence $fields[4]\n"; 
		print STDERR "line: $line\n"; 
		$errors++; 
		next; 
	    }

	} else {
	    print STDERR "build: wrong number of fields in input\n"; 
	    print STDERR "line: $line\n"; 
	    $errors++; 
	    next; 
	}
    }
    return !$errors; 
}

sub build_file {
    my ($mode, $owner, $group, $path) = @_; 
    make_path_to ($path); 
    my $size = $Tester::size++; 
    make_file ($mode,$owner,$group,$path,$size); 
}

sub build_dir {
    my ($mode, $owner, $group, $path) = @_; 
    make_path_to ($path); 
    mkdir $path, 0755; 
    chmod $mode, $path || die "can't chmod $path"; 
    chown $owner, $group, $path || die "can't chown $path"; 
}

sub build_copy {
    my ($omode, $owner, $group, $source, $target) = @_; 
    make_path_to($target); 
    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
        $atime,$mtime,$ctime,$blksize,$blocks) = stat($source);
    make_file($omode, $owner, $group, $target, $size); 
}

sub build_link {
    my ($source,$target) = @_;
    make_path_to ($target);
    symlink ($source,$target) || die "can't link $target -> $source"; 
}

sub make_file {
    my ($mode, $owner, $group, $target, $size) = @_; 
    open (TEST,">$target") || die ("can't write $target"); 
    my $i; 
    for ($i=0; $i<$size; $i++) {
        if ($i % 60==0 || $i==$size-1) { print TEST "\n"; }
 	else {print TEST ' '; }
    }
    close (TEST); 
    chmod $mode, $target || die "can't chmod $target"; 
    chown $owner, $group, $target || die "can't chown $target"; 
}

sub make_path_to {
    my ($path) = @_; 
    my @path = split('/',$path); 
    my $i; 
    for ($i=1; $i<$#path; $i++) {
	my $prefix = join('/',@path[0..$i]); 
	if (! -e $prefix) {
	    mkdir $prefix,0755 || die "can't make directory $prefix"; 
	}
    }
}

#################################################################
#  compare a file tree for coherence with a defined state
#################################################################

sub check {
    my ($base, @script) = @_; 

    my $cwd; 
    my $truebase = truename($base, $cwd); 
    die "$base doesn't exist" if ! defined $truebase; 
    $base = $truebase; 
    
    my @allfiles = ls($base); 
    my %allfiles ;
    my $file; 
    foreach $file (@allfiles) {
	$allfiles{$file} = 1; 
    }

    my $line; 
    my $errors = 0; 
    foreach $line (@script) {
	chomp $line; 
        next if $line =~ /^[ \t]*$/ || $line =~ /^[ \t]*#/;
        my @fields = split(/[ \t]+/, $line); 
	shift @fields while $fields[0] eq ''; 

	my $mode = mode($fields[0]); my $mask = known($fields[0]); 
	if (! defined $mode) { 
	    print STDERR "check: invalid mode $fields[0]\n";
	    $errors++; 
	}

	my $owner; 
        if ($fields[1] ne '-') {
	    $owner = owner($fields[1]); 
	    if (! defined $owner) {
		print STDERR "check: invalid owner $fields[1]\n"; 
		$errors++; 
	    }
	} else { $owner = undef; }

        my $group; 
        if ($fields[2] ne '-') {
	    $group = group($fields[2]); 
	    if (! defined $group) {
		print STDERR "check: invalid group $fields[2]\n";
		$errors++; 
	    }
        } else { $group = undef; }

	if (@fields == 4) {

	    my $target = $fields[3]; 
	    $target = concat($base,$target); 
	    if (-e $target || -l $target) { delete $allfiles{$target}; }

	    if (isdir($fields[0])) {
		if (! -d $target || -l $target) {
		    print STDERR "$target should be a directory and isn't!"; 
		    $errors++; 
		}
		$errors += check_stats($mode, $mask, $owner, $group, $target); 
	    } else {
		if (! -f $target || -l $target) {
		    print STDERR "$target should be a file and isn't!"; 
		    $errors++; 
		}
		$errors += check_stats($mode, $mask, $owner, $group, $target); 
	    }
	} elsif (@fields == 6) {

	    my $target = $fields[3]; 
	    $target = concat($base,$target); 
	    if (-e $target || -l $target) { delete $allfiles{$target}; }

	    if ($fields[4] eq '=') {

		my $source = $fields[5]; 
		$source = concat($base,$source); 
		$errors += check_stats($mode, $mask, $owner, $group, $target); 
		$errors += check_copy($source, $target); 

	    } elsif ($fields[4] eq '->') {

		my $source = $fields[5]; 
		$source = concat($base,$source)
		    if $source =~ /^\//; 
		$errors += check_link($source,$target); 

	    } else {
		print STDERR "check: invalid equivalence $fields[4]\n"; 
		print STDERR "line: $line\n"; 
		$errors++; 
		next; 
	    }

	} else {
	    print STDERR "check: wrong number of fields in input\n"; 
	    print STDERR "line: $line\n"; 
	    $errors++; 
	    next; 
	}
    }

    my @goofs = keys %allfiles; 
    if (@goofs) {
	print STDERR "These files and links should not exist:\n"; 
	my $goof; 
        foreach $goof (@goofs) {
	    if (-l $goof) {
		my $link = readlink($goof); 
		print STDERR " $goof -> $link\n"; 
	    } else {
		print STDERR " $goof\n"; 
	    }
	    $errors++; 
	}
    }
    return ! $errors; 
}

# compare file stats with those desired 

sub check_stats {
    my($omode, $omask, $owner, $group, $target) = @_; 
    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
        $atime,$mtime,$ctime,$blksize,$blocks) = stat($target);
    my $errors = 0; 
    if (! -e $target) {
	print STDERR "$target doesn't exist\n";
	return 1; 
    }
    if (($mode&$omask&07777) != ($omode&$omask)) {
	my $pmode = pmode($mode); 
	print STDERR "$target mode $pmode isn't correct\n"; 
	$errors++; 
    }
    if (defined $owner && $owner != $uid) {
	print STDERR "$target owner $uid isn't $owner\n"; 
	$errors++; 
    }
    if (defined $group && $group != $gid) {
	print STDERR "$target group $gid isn't $group\n"; 
	$errors++; 
    }
    return $errors; 
}

# check that a link is correct

sub check_link {
    my ($target,$link) = @_; 
    if (! -e $link && ! -l $link) {
	print STDERR "$link doesn't exist\n"; 
	return 1; 
    }
    if (! -l $link) {
	print STDERR "$link is not a symlink\n"; 
	return 1; 
    }
    my $val = readlink($link); 
    if ($val ne $target) {
	print STDERR "$link -> $val, not $target\n"; 
	return 1 
    }
    return 0; 
}

# check that a copy worked. 

sub check_copy {
    my ($source,$target) = @_; 
    my $errors; 

    my (@sstat) = stat($source); 
    if (!@sstat) {
	print STDERR "$source doesn't exist\n"; 
	$errors++; 
    }

    my (@tstat) = stat($target); 
    if (!@tstat) {
	print STDERR "$target doesn't exist\n"; 
	$errors++; 
    }

    return $errors if $errors; 

    my ($s_size) = $sstat[7];
    my ($t_size) = $tstat[7];
    if ($s_size != $t_size) {
	print STDERR "$source and $target have different sizes\n"; 
	return 1; 
    }
    return 0; 
}

#################################################################
#  utility functions
#################################################################

# generate a list of files in a given base directory

sub ls {
    my ($base) = @_; 
    my (@result) = (); 
    return ($base) if ! -d $base || -l $base; 
    opendir(DIR,$base) || die "can't read directory $base"; 
    my @files = readdir DIR; 
    my $file; 
    foreach $file (@files) {
	next if $file eq '.' || $file eq '..'; 
	if (-d "$base/$file") {
	    my @expand = ls("$base/$file"); 
	    @result = (@result,@expand); 
	} else {
	    push (@result,"$base/$file"); 
	}
    }
    return @result; 
}
    
# print the structure of an image on stderr 

sub lsprint { 
    my ($base) = @_; 
    my (@files) = ls($base); 
    my $node;     
    foreach $node (@files) {
	if (! -l $node) {
	    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
		$atime,$mtime,$ctime,$blksize,$blocks) = stat($node);
	    print STDERR pmode($mode);
	    printf STDERR "%9s ",powner($uid); 
	    printf STDERR "%9s ",pgroup($gid); 
	    print STDERR "$node\n"; 
	} else { #        drwxrwxrwx123456789 123456789 
	    print STDERR "----------        -         - "; 
	    my $link = readlink $node; 
	    print STDERR "$node -> $link\n"; 
	}
    }
}

# compute a numeric mode from a symbolic one

sub mode { 
    my($st) = @_; 
    my @chars = split(//,$st); 
    my $mode = 0; 
    $mode += 00400 if $chars[1] eq 'r'; 
    $mode += 00200 if $chars[2] eq 'w'; 
    $mode += 00100 if $chars[3] eq 'x'; 
    $mode += 04100 if $chars[3] eq 's'; 
    $mode += 04000 if $chars[3] eq 'S'; 
    $mode += 00040 if $chars[4] eq 'r'; 
    $mode += 00020 if $chars[5] eq 'w'; 
    $mode += 00010 if $chars[6] eq 'x'; 
    $mode += 02010 if $chars[6] eq 's'; 
    $mode += 02000 if $chars[6] eq 'S'; 
    $mode += 00004 if $chars[7] eq 'r'; 
    $mode += 00002 if $chars[8] eq 'w'; 
    $mode += 00001 if $chars[9] eq 'x'; 
    $mode += 01001 if $chars[9] eq 't'; 
    $mode += 01000 if $chars[9] eq 'T'; 
    return $mode; 
}

# determines a mask of known bits
# (given & known = mode & known)
# means that two things are identical. 

sub known { 
    my($st) = @_; 
    my @chars = split(//,$st); 
    my $mode = 0; 
    $mode += 00400 if $chars[1] ne '?'; 
    $mode += 00200 if $chars[2] ne '?'; 
    $mode += 04100 if $chars[3] ne '?'; 
    $mode += 00040 if $chars[4] ne '?'; 
    $mode += 00020 if $chars[5] ne '?'; 
    $mode += 02010 if $chars[6] ne '?'; 
    $mode += 00004 if $chars[7] ne '?'; 
    $mode += 00002 if $chars[8] ne '?'; 
    $mode += 01001 if $chars[9] ne '?'; 
    return $mode; 
}

# construct the print mode for a file or directory

sub pmode {
    my ($code) = @_; my $out = ''; 

    if (($code&0170000)==0040000) { $out .= 'd'; } else { $out .= '-'; }

    if ($code&00400) { $out .= 'r'; } else { $out .= '-'; }

    if ($code&00200) { $out .= 'w'; } else { $out .= '-'; }

    if    (($code&04100)==04100) { $out .= 's'; }
    elsif (($code&04000)==04000) { $out .= 'S'; }
    elsif (($code&00100)==00100) { $out .= 'x'; }
    else 			 { $out .= '-'; }

    if ($code&00040) { $out .= 'r'; } else { $out .= '-'; }

    if ($code&00020) { $out .= 'w'; } else { $out .= '-'; }

    if    (($code&02010)==02010) { $out .= 's'; }
    elsif (($code&02000)==02000) { $out .= 'S'; }
    elsif (($code&00010)==00010) { $out .= 'x'; }
    else 			 { $out .= '-'; }
    
    if ($code&00004) { $out .= 'r'; } else { $out .= '-'; }

    if ($code&00002) { $out .= 'w'; } else { $out .= '-'; }

    if    (($code&01001)==01001) { $out .= 't'; }
    elsif (($code&01000)==01000) { $out .= 'T'; }
    elsif (($code&00001)==00001) { $out .= 'x'; }
    else 			 { $out .= '-'; }
    
    return $out; 
}

# whether the thing is a directory or not. 

sub isdir {
    my ($st) = @_; 
    my @chars = split(//,$st); 
    my $mode = 0; 
    return 1 if $chars[0] eq 'd'; 
    return 0; 
}

# compute a numeric group from a symbolic one

sub group { 
    my ($group) = @_; 
    return $group if $group =~ /^([1-9][0-9]+|0)$/; 
    return 0 if $group eq '-'; 
    my ($name,$passwd,$gid,$members) = getgrnam($group)
	or die "group $group not defined"; 
    return $gid; 
}

# compute a numeric owner from a symbolic one

sub owner { 
    my ($owner) = @_; 
    return $owner if $owner =~ /^([1-9][0-9]+|0)$/; 
    return 0 if $owner eq '-'; 
    my ($login,$pass,$uid,$gid) = getpwnam($owner)
	or die "$owner not in passwd file"; 
    return $uid; 
}

sub powner {
    my ($uid) = @_; 
    my ($login,$pass,$uid,$gid) = getpwuid($uid); 
    return $login if defined $login; 
    return $uid; 
}

sub pgroup {
    my ($gid) = @_; 
    my ($name,$passwd,$gid,$members) = getgrgid($gid); 
    return $name if defined $name; 
    return $gid; 
}

1;