epic5 1.1.11-1build1 / usr / share / epic5 / script / data_struct

if (word(2 $loadinfo()) != [pf]) { load -pf $word(1 $loadinfo()); return; };

#
# Struct/Assign manipulation functions.
#
# The distinction between the two is that the assign functions operate on
# the entire alias space whereas the struct functions operate only on sub
# structures.  The assign functions are typically slower per call, but since
# they do all the work in one call, they can be faster than the recursive
# struct functions.
#
# For each assign.* alias, a corresponding alias.*, but some of them have
# implicit bugs from the fact that arg lists can't yet be retrieved for stored
# aliases.
#

#
# Assign functions.
#
# Make two aliases for every alias.  One for assign handling, one for alias
# handling, then make two more for forward and reverse modes.
#
stack push alias alias.ttt;
stack push alias alias.tt;
alias alias.ttt (args) {
	alias $args;
	@ sar(gr/assign/alias/args);
	alias $args;
};
alias alias.tt (args) {
	alias.ttt $args;
	@ sar(gr/assign./assign.r/args);
	@ sar(gr/pmatch/rpmatch/args);
	@ sar(gr/;@ :list = revw($list);/;/args);
	alias.ttt $args;
};

#
# Check the consistency of the internal structures.  The only
# reason to use these is if an epic bug is suspected.
#
alias.ttt assign.check {
	@ :oxd = xdebug(dword);
	xdebug dword;
	@ :omr = aliasctl(maxret 0);
	@ :last = [];
	@ :list = aliasctl(assign pmatch "\\[$*\\]");
	fe ($list) foo {
		if (uniq($last $foo)!=sort($last $foo)) {
			echo assign consistancy failure: $last >= $foo;
			@ last = foo;
		};
	};
	@ aliasctl(maxret $omr);
	echo Checked $#list assigns matching $*;
	xdebug $oxd;
};
#
# Faster version.  Tells you whether there's an error, not where it is.
#
alias.ttt assign.qcheck {
	@ :oxd = xdebug(dword);
	xdebug dword;
	@ :omr = aliasctl(maxret 0);
	@ :list = aliasctl(assign pmatch "\\[$*\\]");
	@ :status = uniq($list) == sort($list) ? [passed] : [failed];
	@ aliasctl(maxret $omr);
	echo Checked $#list assigns matching $*: $status;
	xdebug $oxd;
};

#
# Dump all assigns with name matching the given masks.
#
alias.tt assign.dump {
	@ :oxd = xdebug(dword);
	xdebug dword;
	@ :list = aliasctl(assign pmatch "\\[$*\\]");
	fe ($list) e {
		echo [$aliasctl(assign getpackage $e)] $e$chr(9)$aliasctl(assign get $e);
	};
	@ list = #list;
	xdebug $oxd;
	if (functioncall()) {
		return $list;
	} else {
		echo Dumped $list matching $*;
	};
};

#
# Dump all assigns with name matching the first arg and
# contents matching the rest.
#
alias.tt assign.grep (args) {
	@ :oxd = xdebug(dword);
	xdebug dword;
	@ :list = aliasctl(assign pmatch "\\[$shift(args)\\]");
	fe ($list) e {
		if (aliasctl(assign get $e) =~ args) {
			echo [$aliasctl(assign getpackage $e)] $e$chr(9)$aliasctl(assign get $e);
		};
	};
	@ list = #list;
	xdebug $oxd;
	if (functioncall()) {
		return $list;
	} else {
		echo Dumped $list matching $*;
	};
};

#
# Delete and reassign all matching vars.  Theoretically, this is a no-op,
# however, alias.pack will destroy the arg lists of the alias.
#
alias.tt assign.pack {
	@ :oxd = xdebug(dword);
	xdebug dword;
	do {
		@ :list = aliasctl(assign $start pmatch "\\[$*\\]");
		fe ($list) foo {
			@ :baz = aliasctl(assign getpackage $foo);
			@ aliasctl(assign set $foo $aliasctl(assign get $foo));
			@ aliasctl(assign setpackage $foo $baz);
		};
		@ list = #list;
		if (functioncall()) {
			return $list;
		} elsif (isdisplaying()) {
			echo Packed $list matching $*;
		};
	} while (list && (:start += aliasctl(maxret)));
	xdebug $oxd;
};

#
# Delete all matching vars.
#
alias.tt assign.purge {
	if (functioncall()) {
		@ :list = aliasctl(assign pmatch "\\[$*\\]");
		@ :list = revw($list);
		fe ($list) bar {^assign -$bar};
		return $#list;
	} else {
		@ :oxd = xdebug(dword);
		xdebug dword;
		do {
			@ :list = assign.purge($*);
			if (isdisplaying()) {
				echo Purged $list matching $*;
			};
		} while (list && list == aliasctl(maxret));
		xdebug $oxd;
	};
};

#
# Write matching assigns to a file which can then be /load'ed.  Any arg lists
# in the original definition won't be saved by alias.save.
#
alias.tt assign.save {
	@ :pkg = rand(0);
	@ :fh = open($0 W);
	@ :start = [];
	@ :oxd = xdebug(dword);
	xdebug dword;
	do {
		@ :list = aliasctl(assign $start pmatch "\\[$1-\\]");
		fe list foo {
			if (pkg != aliasctl(assign getpackage $foo)) {
				@ write($fh PACKAGE ${pkg=aliasctl(assign getpackage $foo)});
			};
			@ write($fh assign $foo $sar(g/\{/\\\{/$sar(g/\}/\\\}/$aliasctl(assign get $foo))));
			@ foo = 0;
		};
		if (functioncall()) {
			break;
		} elsif (isdisplaying()) {
			echo Wrote $#list matching $1-;
		};
		@ :start += aliasctl(maxret);
	} while (#list && start);
	@ close($fh);
	xdebug $oxd;
	return $#list;
};
#
# As for .save, but write a $decode() encoded file which won't be
# damaged by certain variable contents.
#
alias.tt assign.esave {
	@ :pkg = rand(0);
	@ :fh = open($0 W);
	@ :start = [];
	@ :oxd = xdebug(dword);
	xdebug dword;
	do {
		@ :list = aliasctl(assign $start pmatch "\\[$1-\\]");
		fe list foo {
			if (pkg != aliasctl(assign getpackage $foo)) {
				@ write($fh PACKAGE ${pkg=aliasctl(assign getpackage $foo)});
			};
			@ write($fh @aliasctl\(assign set $foo \$decode\($encode($aliasctl(assign get $foo))\)\));
			@ foo = 0;
		};
		if (functioncall()) {
			break;
		} elsif (isdisplaying()) {
			echo Wrote $#list matching $1-;
		};
		@ :start += aliasctl(maxret);
	} while (#list && start);
	@ close($fh);
	xdebug $oxd;
	return $#list;
};

#
# Save the data, then delete it.  Repeat until no more data exists.
# The reason the procedure is repeated is because of the aforementioned
# potential bug that .check checks for.
#
alias.tt assign.flush {
	do {
		@ :bar = assign.save($*);
		@ :bar = assign.purge($1-);
		echo Flushed $bar matching $1-;
	} while (foo != (:foo = bar) || (foo && foo == aliasctl(maxret)));
};
#
# As above but use .esave.
#
alias.tt assign.eflush {
	do {
		@ :bar = assign.esave($*);
		@ :bar = assign.purge($1-);
		echo Flushed $bar matching $1-;
	} while (foo != (:foo = bar) || (foo && foo == aliasctl(maxret)));
};

#
# End of /assign.* functions.
#
stack pop alias alias.tt;
stack pop alias alias.ttt;

#
# struct functions.
#

#
# Recursively erase a structure.
#
alias struct.purge {
	fe ($*) foo {
		^assign -$foo;
	};
	return ${struct.purgesub($*)+#};
};
#
# Continued.
# The third sub-loop does what the first does and should never be entered.
# It's there for company.
#
alias struct.purgesub {
	fe ($*) foo {
		@ :bar = aliasctl(assign match ${foo}.);
		@ :bar = revw($bar);
		@ :hit += #bar;
		fe ($bar) baz {
			^assign -$baz;
		};
		foreach $foo bar {
			@ hit += struct.purgesub(${foo}.${bar});
		};
		foreach $foo bar {
			^assign -${foo}.${bar};
		};
	};
	return ${0+hit};
};

#
# Save a structure, like array.save.
#
alias struct.savefn {
	@ :fd = open($0 w);
	@ :hit = struct.savefd($fd $1-);
	@ close($fd);
	return $hit;
};
#
# Continued.  Save to an FD.
#
alias struct.savefd {
	@:fd=[$0];
	fe ($1-) foo {
		if (strlen($($foo))) {
			@ write($fd assign $foo $sar(g/\{/\\\{/$sar(g/\}/\\\}/$aliasctl(assign get $foo))));
			@ :hit = 1;
		} else {
			@ :hit = 0;
		};
		foreach $foo bar {
			@ hit += struct.savefd($fd ${foo}.${bar});
		};
	};
	return $hit;
};

#
# Some basic /assign handling functions.
#
# /assign.uniq won't work without the functions and data_array scripts.  You need to load those manually.
# 
alias assign.add (var,val) {assign $var $uniq($($var) $val);};
alias assign.addn (var,val) {assign $var $revw($uniq($revw($($var) $val)));};
alias assign.ifnul {if ([]==[$($0)]){assign $*};};
alias assign.filter {fe ($uniq($aliasctl(assign pmatch "\\[$split(, $0)\\]"))) foo {assign $foo $filter("\\[$1-\\]" $($foo))};};
alias assign.uniq (args) {
	bless;
	@ :num = isnumber(b10 $args) ? shift(args) : 1;
	@ delarray(assign.uniq);
	fe ($args) var {
		@ :vars = replace(\$varx x $jot(1 $num));
		fe ($($var)) $replace(varx x $jot(1 $num)) {
			eval setuniqitem assign.uniq $vars;
		};
		assign $var $getandmitems(assign.uniq *);
	};
};