#!/usr/local/bin/perl
#
# waffle.pl - The WAFFLE package for perl
#
# put this in your PERLLIB directory and
# require 'waffle.pl';
# in your Waffle scripts.

package Wafpw;		# Waffle password schtuff

$debug=0;

print "Waffle package initializing...\n" if $debug;

$xAdmin="/waffle/admin" unless $xAdmin=$ENV{"WAFADMIN"};	# should read static file for this

$INDEX="$xAdmin/index";
$PASSWORD="$xAdmin/password";

open(PASSWORD) || die "Couldn't open $PASSWORD: $!";		# We use this too often to keep opening & closing it
# I don't like this very much.  But we can't keep opening it and closing
# it for every record, especially in a walkpw()... do we make it the calling
# routine's responsibility to call wafopenpw() and wafclosepw()?


## this is from /waffle/source/pass.h
$pwreclen=1024;
#
#
# In Waffle version 1.65b7 and under, the short "quota" was eliminated
# from the password struct due to a missing comment delimiter.
# In addition, privs.h and admin.c differed in their idea of what
# order the privs at the end of the file were in, thus the
# commented out "correct" code.
#
#$pwfmt="a12 a12 a24 a24 a22 a40 a10 a10 a66 a8 a10 a10 a10 a10 a12 c2 c8 S13 l2 L5 l8";
$pwfmt="a12 a12 a24 a24 a22 a40 a10 a10 a66 a8 a10 a10 a10 a10 a12 c2 c8 S12 l2 L5 l8";

@names=("name","pass","identity","realname","phone","shell","editor",
	"console","comment","level","terminal","language","suite",
	"account","group",

	"access","priv",

	"age","color","encryption","help","page","columns","proto",
	"calltoday",

	"calls","posts","mail","daily","upload","download","_up",
	"_down"
# see above
#,"quota"
	,"voted","timeallow","mailsent","index",

	"connect","messages",

	"firston","laston","newscan","filescan","changed",

# see above
#	"_File","_Com","_Media","_Secure","_User","_Unuse1",
	"_Secure","_Media","_File","_Com","_User","_Unuse1",
	"_Unuse2","_Unuse3");
@strings=("name","pass","identity","realname","phone","shell","console",
	"comment","level","terminal","language","suite","account","group");
# This is for endian-kludging.
# Yes, I did my development on a sun, with a binary copy of my PC
# password file.  So sue me.
#@shorts=("calls","posts","mail","daily","upload","download","_up","_down",
#	"quota","voted","timeallow","mailsent","index"
#	);
#@longs=("connect","messages",
#	"_File","_Com","_Media","_Secure","_User","_Unuse1",
#	"_Unuse2","_Unuse3","firston","laston","newscan","filescan","changed"
#	);
## end from /waffle/source/pass.h

$main'maxpw=(stat($PASSWORD))[7]/$pwreclen;

## This is from /waffle/source/tree.h
$MAXLEAF=9;		# I think this is 2t-1
$MIDLEAF=5;		# and this is t...?
# "t", above, refers to the usage of t on pages 387-397 of
# _Introduction to Algorithms_, by Cormen, Leiserson, and Rivest.
#
# B-Trees are scary but fun.  Kind of like roller coasters.
#
$KEYLEN=12;		# Length o' key.

# Create format and figure out record length
$idxfmt=sprintf("S S%d a%d S%d",$MAXLEAF+1,($MAXLEAF+1)*$KEYLEN,$MAXLEAF+1);
$idxreclen=length(pack($idxfmt,0));

## end from /waffle/source/tree.h

#
# wafgetpwnam finds a user by username and returns an associative array
# with their user info, or undef if the user doesn't exist.
#
sub main'wafgetpwnam {
	package Wafpw;

	&wafgetpwuid(&idxfind($_[0],1));
}

#
# readidx is called with a record number in the index file, and reads
# that record and puts the data into $parent, @son, @key, @data.
# Returns 1 if succeeded, undef if failed.
#
# readidx is for internal consumption only.  It doesn't make sense for
# someone to call Wafpw'readidx from another package.
sub readidx {
	package Wafpw;
	local($recno)=@_;
	local(@currec);

	if (seek(INDEX,$idxreclen*$recno,0)==0) {
		print STDERR "Tried to seek to nonexistent index record $recno\n";
		return undef;
	}
	if (($i=read(INDEX,$rec,$idxreclen))!=$idxreclen) {
		print STDERR "Error reading index record $recno, read $i/$idxreclen bytes: $!\n";
		return undef;
	}
	@currec=unpack($idxfmt,$rec);
	$parent=$currec[0];
	@son=@currec[1..$MAXLEAF+1];
	@key=unpack("a$KEYLEN " x ($MAXLEAF+1),$currec[$MAXLEAF+2]);
	grep(s/\0.*//,@key);	# Strip stuff after nulls
	@data=@currec[$MAXLEAF+3..$MAXLEAF*2+3];

	1;
}

#
# walkpw is called with a starting key (not implemeneted yet) and a subroutine
# to call for each key.  It walks the password index, starting at the start key
# and calls the subroutine with the parameters ($recno,$username) for each
# user.  You can then use &wafgetpwuid($recno), or just do something with
# the $username if you're not interested in any of the user's other
# information.  The traversal terminates if the user subroutine returns
# undef or 0.
#
# I.E.
# &walkpw("",*disp);
#
# sub disp {
#	local($recno,$username)=@_;
#	local(%user);
#
#	%user=&wafgetpwuid($recno);
#	printf("$-12.12s  $24s\n",$username,%user{"identity"});
#
#	1;
# }
#
sub main'walkpw {
	package Wafpw;
	local($start,*sub)=@_;
	local($recno);

	open(INDEX) || return undef;
	binmode(INDEX);

	$recno=0;
	$child=0;
	if (!&readidx(0)) {
		print STDERR "Couldn't read record 0!?...\n";
		close(INDEX);
		return;
	}
	while (1) {
		if ($key[$child] ne "") {
			if (!&sub($data[$child],$key[$child])) {
				last;
			}
		}
		if ($son[$child]!=0) {
			print "Putting $recno/$child on visit, going to $son[$child]/0\n" if ($debug);
			push(@visit,"$recno $child");
			$recno=$son[$child];
			$child=0;
			if (!&readidx($recno)) {
				last;
			}
			next;
		}
		$child++;
		if ($key[$child] eq "") {
			last if @visit == 0;
			($recno,$child)=split(/ /,pop(@visit));
			if (!&readidx($recno)) {
				last;
			}
			$child++;
			print "Popped $recno/$child from visit\n" if ($debug);
		}
	}
	close(INDEX);
}
	
#
# idxfind traverses the B-Tree, looking for the requested user.
# There's a way to find the closest match, but I haven't figured it out
# yet, so idxfind returns a record number if it finds the user, or
# undef if it doesn't.
#	
sub idxfind {
	package Wafpw;
	local($user,$closest)=@_;
	local($i,$j);
	local($recno);

	return undef if $user eq "";

	open(INDEX) || return undef;
	binmode(INDEX);

	$recno=0;
	while (1) {
		if (!&readidx($recno)) {
			close(INDEX);
			return undef;
		}

		print "Looking for $user in recno $recno...\n" if ($debug);
		$i=0;
		for ($j=1;$j<$MAXLEAF+1;$j++) {
			print "$son[$j] $key[$j] $data[$j]\n" if ($debug);
			if (($son[$j]==0) && ($key[$j] eq "")) {
				last;
			} elsif (($user ge $key[$j])) {
				$i=$j;
			}
		}
		print "Decided that $i ($key[$i]) is the closest...\n" if ($debug);
		if ($user eq $key[$i]) {
			close(INDEX);
			return $data[$i];
		}
		if ($son[$i]==0) { # leaf...
			close(INDEX);
#			return $closest ? $data[$i] : undef;
			return undef;
		}
		$recno=$son[$i];
	}
}

#
# swaps, swapl, and lefix are gibberish that will be removed once I'm
# sure I don't want to run this on the Sun any more.
#
# I hate endian-ness!
# this is for shorts
sub swaps {
	package Wafpw;
	local($n)=@_;
	local($i,$j);
	local($r);

	($i,$j)=unpack("CC",pack("S",$n));
	$r=unpack("S",pack("CC",$j,$i));
#	printf("swapped short from 0x%04.4x to 0x%04.4x\n",$n,$r);
	$r;
}

#and this is for longs
sub swapl {
	package Wafpw;
	local($n)=@_;
	local($i,$j,$k,$l);
	local($r);

	($i,$j,$k,$l)=unpack("CCCC",pack("L",$n));
	$r=unpack("L",pack("CCCC",$l,$k,$j,$i));
#	printf("swapped long from 0x%08.8x to 0x%08.8x\n",$n,$r);
	$r;
}

#and this is for aarrays of shorts (ie in index search)
sub lefix {
	package Wafpw;
	local(@nums)=@_;
	local(@res);
	local($i,$j,$n);

	foreach $n (@nums) {
		push(@res,&swaps($n));
	}

	@res;
}

#
# wafgetpwuid gets a record from the password file and returns an
# associative array if it succeeds, undef if it fails.
#
sub wafgetpwuid {
	package Wafpw;
	local($uid)=@_;
	local($pwrec);
	local(%retval);
	local(@foo);
	local($i,$j);

	return undef if $uid eq "";

	print "wafgetpwuid($uid)\n" if $debug;
#	open (PASSWORD) || return undef;
        binmode(PASSWORD);
	if (seek(PASSWORD,$pwreclen*$uid,0)==0) {
		print STDERR "Error trying to seek to password file record $uid: $!\n";
		close(PASSWORD);
		return undef;
	}
	if (read(PASSWORD,$pwrec,$pwreclen)!=$pwreclen) {
		print STDERR "Error reading password file record $uid: $!\n";
		close(PASSWORD);
		return undef;
	}
#	close(PASSWORD);

	@retval{@names}=unpack($pwfmt,$pwrec);
# Assigning to an associative array...

## This is for endian-ness
#	foreach $i (@shorts) {
#		$retval{$i}=&swaps($retval{$i});
#	}
#
#	foreach $i (@longs) {
#		$retval{$i}=&swapl($retval{$i});
#	}
## end for endian-ness

	$retval{"index"}=$uid;	# This is what Waffle does

# Fix up strings
	grep(s/\0.*//,@retval{@strings});

	%retval;
}

# I can't get "&main'wafgetpwuid" to work inside this package
# therefore, this silly hack.
#
# I think this was a bug way back in 3.something, but, it works,
# so I'm not going to fix it.
sub main'wafgetpwuid {
	package Wafpw;

	return &wafgetpwuid(@_);
}

#
# wafputpw takes an assoc. array by reference, and writes it back to where
# it came from.  YOU *MUST* call wafputpw with an assoc. array that you got
# from one of the read routines, and YOU *MUST* *NOT* play with $user{"index"}.
# 
# DISCLAIMER: This routine works for me, and other than one bug where you could
# pass it an empty array, it has not done anything wrong to my password file.
# HOWEVER, there is no guarantee that it will not do anything to your password
# file.  MAKE A BACKUP IF YOU ARE GOING TO USE THIS ROUTINE!
#
sub main'wafputpw {
	package Wafpw;
	local(*rec)=@_;
	local($uid,$pwrec);
	local($i);

	foreach $i (@names) {
		if (!defined($rec{$i})) {
			print STDERR "Requested to write incomplete record!\n";
			return undef;
		}
	}

	if(open(RWPASSWORD,"+<" . $PASSWORD)==0) {
		print STDERR "Error opening $PASSWORD for update: $!\n";
		return undef;
	}
	binmode(RWPASSWORD);
	$uid=$rec{"index"};
	print "Updating record number $uid\n" if $debug;

## This is for endian-ness
#	foreach $i (@shorts) {
#		$rec{$i}=&swaps($rec{$i});
#	}
#
#	foreach $i (@longs) {
#		$rec{$i}=&swapl($rec{$i});
#	}
## end for endian-ness

	if (seek(RWPASSWORD,$pwreclen*$uid,0)==0) {
		print STDERR "Error trying to seek to password file record $uid: $!\n";
		close(RWPASSWORD);
		return undef;
	}
	$pwrec=pack($pwfmt,@rec{@names});
#	print RWPASSWORD pack("a$pwreclen",$pwrec);
	print RWPASSWORD $pwrec;
	print "length=",length($pwrec),"\n" if $debug;
#	if (write(RWPASSWORD,$pwrec,length($pwrec))!=length($pwrec)) {
#		print STDERR "Error writing password file record $uid: $!\n";
#		close(RWPASSWORD);
#		return undef;
#	}
	close(RWPASSWORD);
	
	return 1;
}