1 files changed, 400 insertions, 0 deletions
diff --git a/appl/lib/fslib.b b/appl/lib/fslib.b
new file mode 100644
index 00000000..20dd6990
--- /dev/null
+++ b/appl/lib/fslib.b
@@ -0,0 +1,400 @@
+implement Fslib;
+
+#
+# Copyright © 2003 Vita Nuova Holdings Limited
+#
+
+include "sys.m";
+	sys: Sys;
+include "draw.m";
+include "sh.m";
+include "fslib.m";
+
+# Fsdata stream conventions:
+# 
+# Fsdata: adt {
+#	dir: ref Sys->Dir;
+#	data: array of byte;
+# };
+# Fschan: type chan of (Fsdata, chan of int);
+# c: Fschan;
+# 
+# a stream of values sent on c represent the contents of a directory
+# hierarchy. after each value has been received, the associated reply
+# channel must be used to prompt the sender how next to proceed.
+# 
+# the first item sent on an fsdata channel represents the root directory
+# (it must be a directory), and its name holds the full path of the
+# hierarchy that's being transferred.  the items that follow represent
+# the contents of the root directory.
+# 
+# the set of valid sequences of values can be described by a yacc-style
+# grammar, where the terminal tokens describe data values (Fsdata adts)
+# passed down the channel.  this grammar describes the case where the
+# entire fs tree is traversed in its entirety:
+# 
+# dir:	DIR dircontents NIL
+# 	|	DIR NIL
+# dircontents: entry
+# 	|	dircontents entry
+# entry: FILE filecontents NIL
+# 	| FILE NIL
+# 	| dir
+# filecontents: DATA
+# 	| filecontents DATA
+# 
+# the tests for the various terminal token types, given a token (of type
+# Fsdata) t:
+# 
+# 	FILE		t.dir != nil && (t.dir.mode & Sys->DMDIR) == 0
+# 	DIR		t.dir != nil && (t.dir.mode & Sys->DMDIR)
+# 	DATA	t.data != nil
+# 	NIL		t.data == nil && t.dir == nil
+# 
+# when a token is received, there are four possible replies:
+# 	Quit
+# 		terminate the stream immediately.  no more tokens will
+# 		be on the channel.
+# 
+# 	Down
+# 		descend one level in the hierarchy, if possible.  the next tokens
+# 		will represent the contents of the current entry.
+# 
+# 	Next
+# 		get the next entry in a directory, or the next data
+# 		block in a file, or travel one up the hierarchy if
+#		it's the last entry or data block in that directory or file.
+# 
+# 	Skip
+# 		skip to the end of a directory or file's contents.
+#		if we're already at the end, this is a no-op (same as Next)
+# 
+# grammar including replies is different.  a token is the tuple (t, reply),
+# where reply is the value that was sent over the reply channel.  Quit
+# always causes the grammar to terminate, so it is omitted for clarity.
+# thus there are 12 possible tokens (DIR_DOWN, DIR_NEXT, DIR_SKIP, FILE_DOWN, etc...)
+#
+# dir: DIR_DOWN dircontents NIL_NEXT
+# 	| DIR_DOWN dircontents NIL_SKIP
+# 	| DIR_DOWN dircontents NIL_DOWN
+# 	| DIR_NEXT
+# dircontents:
+# 	| FILE_SKIP
+# 	| DIR_SKIP
+# 	| file dircontents
+# 	| dir dircontents
+# file: FILE_DOWN filecontents NIL_NEXT
+# 	| FILE_DOWN filecontents NIL_SKIP
+# 	| FILE_DOWN filecontents NIL_DOWN
+# 	| FILE_NEXT
+# filecontents:
+# 	| data
+# 	| data DATA_SKIP
+# data: DATA_NEXT
+# 	| data DATA_NEXT
+# 
+# both the producer and consumer of fs data on the channel must between
+# them conform to the second grammar. if a stream of fs data
+# is sent with no reply channel, the stream must conform to the first grammar.
+
+valuec := array[] of {
+	tagof(Value.V) => 'v',
+	tagof(Value.X) => 'x',
+	tagof(Value.P) => 'p',
+	tagof(Value.S) => 's',
+	tagof(Value.C) => 'c',
+	tagof(Value.T) => 't',
+	tagof(Value.M) => 'm',
+};
+
+init()
+{
+	sys = load Sys Sys->PATH;
+}
+
+# copy the contents (not the entry itself) of a directory from src to dst.
+copy(src, dst: Fschan): int
+{
+	indent := 1;
+	myreply := chan of int;
+	for(;;){
+		(d, reply) := <-src;
+		dst <-= (d, myreply);
+		r := <-myreply;
+		case reply <-= r {
+		Quit =>
+			return Quit;
+		Next =>
+			if(d.dir == nil && d.data == nil)
+				if(--indent == 0)
+					return Next;
+		Skip =>
+			if(--indent == 0)
+				return Next;
+		Down =>
+			if(d.dir != nil || d.data != nil)
+				indent++;
+		}
+	}
+}
+
+Report.new(): ref Report
+{
+	r := ref Report(chan of string, chan of (string, chan of string), chan of int);
+	spawn reportproc(r.startc, r.enablec, r.reportc);
+	return r;
+}
+
+Report.start(r: self ref Report, name: string): chan of string
+{
+	if(r == nil)
+		return nil;
+	errorc := chan of string;
+	r.startc <-= (name, errorc);
+	return errorc;
+}
+
+Report.enable(r: self ref Report)
+{
+	r.enablec <-= 0;
+}
+
+reportproc(startc: chan of (string, chan of string), startreports: chan of int, errorc: chan of string)
+{
+	realc := array[2] of chan of string;
+	p := array[len realc] of string;
+	a := array[0] of chan of string;;
+
+	n := 0;
+	for(;;) alt{
+	(prefix, c) := <-startc =>
+		if(n == len realc){
+			realc = (array[n * 2] of chan of string)[0:] = realc;
+			p = (array[n * 2] of string)[0:] = p;
+		}
+		realc[n] = c;
+		p[n] = prefix;
+		n++;
+	<-startreports =>
+		if(n == 0){
+			errorc <-= nil;
+			exit;
+		}
+		a = realc;
+	(x, report) := <-a =>
+		if(report == nil){
+#			errorc <-= "exit " + p[x];
+			--n;
+			if(n != x){
+				a[x] = a[n];
+				a[n] = nil;
+				p[x] = p[n];
+				p[n] = nil;
+			}
+			if(n == 0){
+				errorc <-= nil;
+				exit;
+			}
+		}else if(a == realc)
+			errorc <-= p[x] + ": " + report;
+	}
+}
+
+type2s(c: int): string
+{
+	case c{
+	'a' =>
+		return "any";
+	'x' =>
+		return "fs";
+	's' =>
+		return "string";
+	'v' =>
+		return "void";
+	'p' =>
+		return "gate";
+	'c' =>
+		return "command";
+	't' =>
+		return "entries";
+	'm' =>
+		return "selector";
+	* =>
+		return sys->sprint("unknowntype('%c')", c);
+	}
+}
+
+typeerror(tc: int, v: ref Value): string
+{
+	sys->fprint(sys->fildes(2), "fs: bad type conversion, expected %s, was actually %s\n", type2s(tc), type2s(valuec[tagof v]));
+	return "type conversion error";
+}
+
+Value.t(v: self ref Value): ref Value.T
+{
+	pick xv :=v {T => return xv;}
+	raise typeerror('t', v);
+}
+Value.c(v: self ref Value): ref Value.C
+{
+	pick xv :=v {C => return xv;}
+	raise typeerror('c', v);
+}
+Value.s(v: self ref Value): ref Value.S
+{
+	pick xv :=v {S => return xv;}
+	raise typeerror('s', v);
+}
+Value.p(v: self ref Value): ref Value.P
+{
+	pick xv :=v {P => return xv;}
+	raise typeerror('p', v);
+}
+Value.x(v: self ref Value): ref Value.X
+{
+	pick xv :=v {X => return xv;}
+	raise typeerror('x', v);
+}
+Value.v(v: self ref Value): ref Value.V
+{
+	pick xv :=v {V => return xv;}
+	raise typeerror('v', v);
+}
+Value.m(v: self ref Value): ref Value.M
+{
+	pick xv :=v {M => return xv;}
+	raise typeerror('m', v);
+}
+
+Value.typec(v: self ref Value): int
+{
+	return valuec[tagof v];
+}
+
+Value.discard(v: self ref Value)
+{
+	if(v == nil)
+		return;
+	pick xv := v {
+	X =>
+		(<-xv.i).t1 <-= Quit;
+	P =>
+		xv.i <-= (Nilentry, nil);
+	M =>
+		xv.i <-= (nil, nil, nil);
+	V =>
+		xv.i <-= 0;
+	T =>
+		xv.i.sync <-= 0;
+	}
+}
+
+sendnulldir(c: Fschan): int
+{
+	reply := chan of int;
+	c <-= ((ref Sys->nulldir, nil), reply);
+	if((r := <-reply) == Down){
+		c <-= ((nil, nil), reply);
+		if(<-reply != Quit)
+			return Quit;
+		return Next;
+	}
+	return r;
+}
+
+quit(errorc: chan of string)
+{
+	if(errorc != nil)
+		errorc <-= nil;
+	exit;
+}
+
+report(errorc: chan of string, err: string)
+{
+	if(errorc != nil)
+		errorc <-= err;
+}
+
+# true if a module with type sig t1 is compatible with a caller that expects t0
+typecompat(t0, t1: string): int
+{
+	(rt0, at0, ot0) := splittype(t0);
+	(rt1, at1, ot1) := splittype(t1);
+	if((rt0 != rt1 && rt0 != 'a') || at0 != at1)		# XXX could do better for repeated args.
+		return 0;
+	for(i := 1; i < len ot0; i++){
+		for(j := i; j < len ot0; j++)
+			if(ot0[j] == '-')
+				break;
+		(ok, t) := opttypes(ot0[i], ot1);
+		if(ok == -1 || ot0[i:j] != t)
+			return 0;
+		i = j + 1;
+	}
+	return 1;
+}
+
+splittype(t: string): (int, string, string)
+{
+	if(t == nil)
+		return (-1, nil, nil);
+	for(i := 1; i < len t; i++)
+		if(t[i] == '-')
+			break;
+	return (t[0], t[1:i], t[i:]);
+}
+
+opttypes(opt: int, opts: string): (int, string)
+{
+	for(i := 1; i < len opts; i++){
+		if(opts[i] == opt && opts[i-1] == '-'){
+			for(j := i+1; j < len opts; j++)
+				if(opts[j] == '-')
+					break;
+			return (0, opts[i+1:j]);
+		}
+	}
+	return (-1, nil);
+}
+
+cmdusage(s, t: string): string
+{
+	if(s == nil)
+		return nil;
+	for(oi := 0; oi < len t; oi++)
+		if(t[oi] == '-')
+			break;
+	if(oi < len t){
+		single, multi: string;
+		for(i := oi; i < len t - 1;){
+			for(j := i + 1; j < len t; j++)
+				if(t[j] == '-')
+					break;
+
+			optargs := t[i+2:j];
+			if(optargs == nil)
+				single[len single] = t[i+1];
+			else{
+				multi += sys->sprint(" [-%c", t[i+1]);
+				for (k := 0; k < len optargs; k++)
+					multi += " " + type2s(optargs[k]);
+				multi += "]";
+			}
+			i = j;
+		}
+		if(single != nil)
+			s += " [-" + single + "]";
+		s += multi;
+	}
+	multi := 0;
+	if(oi > 2 && t[oi - 1] == '*'){
+		multi = 1;
+		oi -= 2;
+	}
+	for(k := 1; k < oi; k++)
+		s += " " + type2s(t[k]);
+	if(multi)
+		s += " [" + type2s(t[k]) + "...]";
+	s += " -> " + type2s(t[0]);
+	return s;
+}