Constant Story "MemStreamTest";
Constant Headline "^Not a game.^";
Release 3;

! Unit test for the glk_stream_open_memory() and glk_stream_open_memory_uni()
! calls.

Include "Parser";
Include "VerbLib";

[ Initialise;
	location = Kitchen;
	selfobj.description = "You're some kind of person.";
];

Object Kitchen "Stream Room"
  with
    description [;
		print "A voice booooms out: Try ~stream OBJECT~ to send its
			description to a byte array (glk_stream_open_memory).
			Try ~streamuni OBJECT~ to send its description to
			a Unicode character array (glk_stream_open_memory_uni).
			~nullstream OBJECT~ and ~uninullstream OBJECT~ send to
			a null stream, which gets the description's length.
			~pos~ and ~unipos~ test positioning in byte/Unicode
			streams. ~read~ and ~uniread~ test reading from byte/Unicode
			streams.^";
	],
  has light;

Object -> grape "grape"
  with
	name 'grape',
	description "It's a grape.";

Object -> umlauts "umlauts"
  with
	name 'some' 'umlaut' 'umlauts',
	article "some",
	description "Capital AEIOU with umlauts: @:A@:E@:I@:O@:U",
  has pluralname;

Object -> pie "Greek pie"
  with
	name 'greek' 'pi' 'pie',
	description "It's a Greek @{3C0}, made with feta and ink.";
  
Object -> restaurant "Russian restaurant"
  with
	name 'russian' 'restaurant' 'pectopah',
	description "It's a Russian @{440}@{435}@{441}@{442}@{43E}@{440}@{430}@{43D}. The food smells good.";
  
Object -> quotes "quotes"
  with
	name 'some' 'quote' 'quotes',
	article "some",
	description "Some text with curly quotes:
		@{2018}single curly quotes@{2019} @{201C}double curly quotes@{201D}",
  has pluralname;

Object -> longthing "long string"
  with
	name 'long' 'piece' 'of' 'string',
	description "It's a very long piece of string. So long, in fact, that
		its description will certainly overflow the 128-character output
		array. It should be truncated cleanly.";

Include "Grammar";

Verb 'stream'
	* noun -> Stream;

Verb 'streamuni' 'uni' 'unistream'
	* noun -> StreamUni;

Verb 'pos'
	* -> PosTest;

Verb 'posuni' 'unipos'
	* -> PosUniTest;

Extend 'read' replace
	* -> ReadTest;

Verb 'readuni' 'uniread'
	* -> ReadTestUni;
	
Verb 'nullstream' 'null' 'streamnull'
	* noun -> Null;

Verb 'nullunistream' 'nulluni' 'uninull' 'uninullstream'
	* noun -> NullUni;

[ StreamSub;
	DescToStream(noun);
];

[ StreamUniSub  res;
	res = glk($0004, 15, 0); ! gestalt
	if (res == 0)
		"This interpreter does not support Unicode Glk calls!";
	DescToStreamUni(noun);
];

[ NullSub;
	DescToNullStream(noun);
];

[ NullUniSub  res;
	res = glk($0004, 15, 0); ! gestalt
	if (res == 0)
		"This interpreter does not support Unicode Glk calls!";
	DescToNullStreamUni(noun);
];

[ PosTestSub;
	DescToStream(perform_pos_test);
];

[ PosUniTestSub;
	DescToStreamUni(perform_pos_test);
];

Array closeresult --> 2;

Constant BUFLEN 128;

Array chararray -> (BUFLEN+1);
Array uniarray --> (BUFLEN+1);

Array chararray2 -> (BUFLEN+1);
Array uniarray2 --> (BUFLEN+1);

Global errorcount;

[ check_pos pos target oldstr;
	if (pos == target)
		return;
		
	errorcount++;
	oldstr = glk($0048); ! stream_get_current
	glk($002F, gg_mainwin); ! set_window
	print "ERROR: position was ", pos, ", should be ", target, ".^";
	glk($0047, oldstr); ! stream_set_current
];

[ DescToStream obj  str oldstr ix ch;
	errorcount = 0;
	
	for (ix=0 : ix<BUFLEN : ix++)
		chararray->ix = 0;
	chararray->BUFLEN = 127; ! guard character

	oldstr = glk($0048); ! stream_get_current
	str = glk($0043, chararray, BUFLEN, 1, 0); ! stream_open_memory
	if (str == 0) {
		"Unable to open memory stream.";
	}

	glk($0047, str); ! stream_set_current
	if (obj ofclass Object)
		obj.description();
	else if (obj ofclass Routine)
		obj(str);
	else
		print "???";
	glk($0047, oldstr); ! stream_set_current
	glk($0044, str, closeresult); ! stream_close

	if (closeresult-->0 ~= 0)
		print "ERROR: Stream records ", closeresult-->0, " chars read --
			should be zero.^";
	print "(Sent to char stream: ", closeresult-->1, " chars)^";

	ix = closeresult-->1;
	if (ix > BUFLEN) ix = BUFLEN;
	glk($0084, chararray, ix); ! put_buffer
	
	print "^Character by character: ";
	for (ix=0 : ix<BUFLEN : ix++) {
		ch = chararray->ix;
		if (ch == 0)
			break;
		print " ";
		if (ch == 10)
			print "(newline)";
		else if (ch < 32 || ch >= 127)
			print "(",ch,")";
		else
			print (char) ch;
	}

	for ( : ix<BUFLEN : ix++) {
		ch = chararray->ix;
		if (ch ~= 0) {
			print " (rest is not zeroes -- ERROR)";
			break;
		}
	}

	new_line;
	if (chararray->BUFLEN ~= 127)
		print "ERROR: Guard character was overwritten!^";

	if (errorcount)
		print "ERROR: Positions were wrong during printing!^";
];

[ DescToStreamUni obj  str oldstr ix ch;
	errorcount = 0;
	
	for (ix=0 : ix<BUFLEN : ix++)
		uniarray-->ix = 0;
	uniarray-->BUFLEN = 127; ! guard character

	oldstr = glk($0048); ! stream_get_current
	str = glk($0139, uniarray, BUFLEN, 1, 0); ! stream_open_memory_uni
	if (str == 0) {
		"Unable to open memory stream.";
	}

	glk($0047, str); ! stream_set_current
	if (obj ofclass Object)
		obj.description();
	else if (obj ofclass Routine)
		obj(str);
	else
		print "???";
	glk($0047, oldstr); ! stream_set_current
	glk($0044, str, closeresult); ! stream_close

	if (closeresult-->0 ~= 0)
		print "ERROR: Stream records ", closeresult-->0, " chars read --
			should be zero.^";
	print "(Sent to unicode char stream: ", closeresult-->1, " chars)^";

	ix = closeresult-->1;
	if (ix > BUFLEN) ix = BUFLEN;
	glk($012A, uniarray, ix); ! put_buffer_uni
	
	print "^Character by character: ";
	for (ix=0 : ix<BUFLEN : ix++) {
		ch = uniarray-->ix;
		if (ch == 0)
			break;
		print " ";
		if (ch == 10)
			print "(newline)";
		else if (ch < 32 || ch >= 127)
			print "(",ch,")";
		else
			print (char) ch;
	}

	for ( : ix<BUFLEN : ix++) {
		ch = uniarray-->ix;
		if (ch ~= 0) {
			print " (rest is not zeroes -- ERROR)";
			break;
		}
	}

	new_line;
	if (uniarray-->BUFLEN ~= 127)
		print "ERROR: Guard character was overwritten!^";

	if (errorcount)
		print "ERROR: Positions were wrong during printing!^";
];

[ DescToNullStream obj  str oldstr;
	errorcount = 0;
	
	oldstr = glk($0048); ! stream_get_current
	str = glk($0043, 0, BUFLEN, 1, 0); ! stream_open_memory
	if (str == 0) {
		"Unable to open memory stream.";
	}

	glk($0047, str); ! stream_set_current
	if (obj ofclass Object)
		obj.description();
	else if (obj ofclass Routine)
		obj(str);
	else
		print "???";
	glk($0047, oldstr); ! stream_set_current
	glk($0044, str, closeresult); ! stream_close

	if (closeresult-->0 ~= 0)
		print "ERROR: Stream records ", closeresult-->0, " chars read --
			should be zero.^";
	print "(Sent to char stream: ", closeresult-->1, " chars)^";
];

[ DescToNullStreamUni obj  str oldstr;
	errorcount = 0;
	
	oldstr = glk($0048); ! stream_get_current
	str = glk($0139, 0, 0, 1, 0); ! stream_open_memory_uni
	if (str == 0) {
		"Unable to open memory stream.";
	}

	glk($0047, str); ! stream_set_current
	if (obj ofclass Object)
		obj.description();
	else if (obj ofclass Routine)
		obj(str);
	else
		print "???";
	glk($0047, oldstr); ! stream_set_current
	glk($0044, str, closeresult); ! stream_close

	if (closeresult-->0 ~= 0)
		print "ERROR: Stream records ", closeresult-->0, " chars read --
			should be zero.^";
	print "(Sent to unicode char stream: ", closeresult-->1, " chars)^";
];


[ perform_pos_test str   pos;
	print "                        piecx";

	pos = glk($0046, str); ! stream_get_position
	check_pos(pos, 29);
	
	glk($0045, str, 0, 0); ! stream_set_position
	
	pos = glk($0046, str); ! stream_get_position
	check_pos(pos, 0);
	
	print "This!";

	pos = glk($0046, str); ! stream_get_position
	check_pos(pos, 5);
	
	glk($0045, str, -1, 1); ! stream_set_position

	pos = glk($0046, str); ! stream_get_position
	check_pos(pos, 4);

	print " line was assembled ";

	pos = glk($0046, str); ! stream_get_position
	check_pos(pos, 24);
	
	glk($0045, str, -1, 2); ! stream_set_position

	pos = glk($0046, str); ! stream_get_position
	check_pos(pos, 28);

	print "ewise";

	pos = glk($0046, str); ! stream_get_position
	check_pos(pos, 33);
		
	glk($0045, str, 33, 0); ! stream_set_position

	print ".^";
	
	! "This line was assembled piecewise.^"
];

[ ReadTestSub ix oldstr str val testlen;
	for (ix=0 : ix<BUFLEN : ix++)
		chararray->ix = 0;
	chararray->BUFLEN = 127; ! guard character

	oldstr = glk($0048); ! stream_get_current
	str = glk($0043, chararray, BUFLEN, 1, 0); ! stream_open_memory
	if (str == 0) {
		"Unable to open memory stream.";
	}

	glk($0047, str); ! stream_set_current
	print "!Line one.^Line two.^...Last line.^";
	glk($0047, oldstr); ! stream_set_current
	glk($0044, str, closeresult); ! stream_close
	testlen = closeresult-->1;

	str = glk($0043, chararray, testlen, 2, 0); ! stream_open_memory
	if (str == 0) {
		"Unable to open memory stream.";
	}

	val = glk($0090, str); ! get_char_stream
	print "Read char '", (char) val, "'^";
	if (val ~= '!')
		print "ERROR: should be '!'^";

	val = glk($0091, str, chararray2, BUFLEN); ! get_line_stream
	print "Read line of ", val, " chars: ";
	glk($0084, chararray2, val); ! put_buffer

	val = glk($0092, str, chararray2, 13); ! get_buffer_stream
	print "Read buffer of ", val, " chars: ";
	glk($0084, chararray2, val); ! put_buffer
	new_line;

	val = glk($0092, str, chararray2, 20); ! get_buffer_stream
	print "Read buffer of ", val, " chars: ";
	glk($0084, chararray2, val); ! put_buffer
	new_line;

	val = glk($0090, str); ! get_char_stream
	print "Read char ", val, "^";
	if (val ~= -1)
		print "ERROR: should be -1^";

	val = glk($0091, str, chararray2, BUFLEN); ! get_line_stream
	print "Read line of ", val, " chars^";
	if (val ~= 0)
		print "ERROR: should be 0^";

	glk($0044, str, closeresult); ! stream_close
	if (closeresult-->1 ~= 0)
		print "ERROR: Stream records ", closeresult-->0, " chars written --
			should be zero.^";
	print "(Read from char stream: ", closeresult-->0, " chars)^";
];

[ ReadTestUniSub ix oldstr str val testlen;
	for (ix=0 : ix<BUFLEN : ix++)
		uniarray-->ix = 0;
	uniarray-->BUFLEN = 127; ! guard character

	oldstr = glk($0048); ! stream_get_current
	str = glk($0139, uniarray, BUFLEN, 1, 0); ! stream_open_memory_uni
	if (str == 0) {
		"Unable to open memory stream.";
	}

	glk($0047, str); ! stream_set_current
	print "!Li@{3B7}e one.^Li@{3B7}e two.^...Last li@{3B7}e.^";
	glk($0047, oldstr); ! stream_set_current
	glk($0044, str, closeresult); ! stream_close
	testlen = closeresult-->1;

	str = glk($0139, uniarray, testlen, 2, 0); ! stream_open_memory_uni
	if (str == 0) {
		"Unable to open memory stream.";
	}

	val = glk($0130, str); ! get_char_stream_uni
	print "Read char '", (char) val, "'^";
	if (val ~= '!')
		print "ERROR: should be '!'^";

	val = glk($0132, str, uniarray2, BUFLEN); ! get_line_stream_uni
	print "Read line of ", val, " chars: ";
	glk($012A, uniarray2, val); ! put_buffer_uni

	val = glk($0131, str, uniarray2, 13); ! get_buffer_stream_uni
	print "Read buffer of ", val, " chars: ";
	glk($012A, uniarray2, val); ! put_buffer_uni
	new_line;

	val = glk($0131, str, uniarray2, 20); ! get_buffer_stream_uni
	print "Read buffer of ", val, " chars: ";
	glk($012A, uniarray2, val); ! put_buffer_uni
	new_line;

	val = glk($0130, str); ! get_char_stream_uni
	print "Read char ", val, "^";
	if (val ~= -1)
		print "ERROR: should be -1^";

	val = glk($0132, str, uniarray2, BUFLEN); ! get_line_stream_uni
	print "Read line of ", val, " chars^";
	if (val ~= 0)
		print "ERROR: should be 0^";

	glk($0044, str, closeresult); ! stream_close
	if (closeresult-->1 ~= 0)
		print "ERROR: Stream records ", closeresult-->0, " chars written --
			should be zero.^";
	print "(Read from unicode char stream: ", closeresult-->0, " chars)^";
];