{****************************************************************************
 ***                                                                      ***
 ***                   Short CODES - USE & SELECTION                   ***
 ***                                                                      ***
 *** M Hill                                                      Oct 1991 ***
 ****************************************************************************}
{$I compdirs}  {for singleuser flag}
unit Scodes;

INTERFACE

uses  global, {for sr bits and pieces}
{$IFDEF WINDOWS}
	wui,	{windows}
{$ELSE}
	tui,views,	tuilist, tuiedit, {text}
{$ENDIF}
			kamsetup, {for locking & terminals}
			devices,{printing}
			inplist, {ancestor of inputscode}
			files, objects, {for data stream}
			dattime,
			forms, lstrings,
			drivers;

{const
{	CMenuView = #15#16#17#18#19#20;
{	SCodeDescLength = 30;   {Length to be allocated to SCode description}


type
	TSCode = string[3];

	{********************************************
	 ***      SHORT-CODE LIST ITEM            ***
	 ********************************************}
	PSCodeItem = ^TSCodeItem;
	TSCodeItem = object(TObject)

	 Tag : boolean; {not stored}
	 {-- Data --}
	 Code : string[3];
	 Description : Pstring;

	 {-- Methods --}
	 constructor Init(const NCode, NDesc : string);
	 destructor Done;                                 virtual;
	 constructor Load(var S : TDataStream);
	 procedure Store(var S : TDataStream);
	 function DisplayLine(Maxlen : integer) : string; virtual;
	 function Edit(Caller : PView) : Word;       		 virtual;
	 function Print(Device : PDeviceStream; prType : word) : word; virtual;
		function Valid : boolean; virtual;
	 procedure AddEditFields(P : PObjectEditBox);           virtual;
	end;

	TSCodeCreator = function(const NCode, NDesc : string) : PSCodeItem;

function StdSCodeCreator(const NCode, NDesc : string) : PSCodeItem;

type
	{===for forms - code to be replaced with Scode}
	PScodeFormCode = ^TScodeFormCode;
	TScodeFormCode = object(TFormCode)
		Scode : TScode;
		scType : word;
		constructor Init(NCOde : string; NScode : TScode; NscType : word);
		function Replace(const SubCode, Param : TFCodeStr; const FormCodes : PFormCodeCollection;
																													var LString : TLongString) : boolean; virtual;
	end;


	{***************************************
	 ***     COLLECTION/ADMINISTRATOR    ***
	 ***************************************}

{stored as lock (1 byte), spare byte, then scodes
 old v4 scodecollection had first two bytes as srtype=109}

type
	PSCodeCollection = ^TSCodeCollection;
	TSCodeCollection = object(TSortedCollection)

		{administration bits - not loaded/stored}
		FileName : PString;
		Loaded : boolean; {marker for if loaded}
		SCodeCreator : TSCodeCreator;
		LoggedOn : word; {count of num "users"}

		VerLastLoad : byte; {ver of file when last loaded}

		Lock : byte;
		Name : Pstring;                    {General name of collection for user}

		constructor Init(NFileName, NUserName : string; NSCodeCreator : TSCodeCreator);
		destructor Done; virtual;                    {stores & disposes of scode collection}

		{collection}
		function Compare(Key1, Key2 : pointer) : integer; virtual;
		function FindItem(Code : string) : PScodeItem;
		function Desc(Code : string) : string;
		function ExpandLine(Codes : string; var Valid : boolean) : string;
		function CheckDupCode(Item : PSCodeItem) : PScodeITem;

		procedure Error(Code, Info : Integer); virtual;

		procedure Print;

{		constructor Load(var S : TDataStream);
		procedure Store(Var S : TDataStream);{}

		procedure LoadLock;
		procedure StoreLock;

		{short code type admin}
		procedure LogOn;                         {Sets up scode collection if not already there}
		procedure LogOff;
		procedure UnLoad;														{Disposes of collection}

		procedure LoadCodes(LockStatus : byte);   virtual; {Update list from disk}
		procedure StoreCodes(LockStatus : byte);   virtual; {Store list on disk}
		procedure ExecuteList(Acceptor : PInputELine); {do list}
	end;

	{********************************
	 ***       VIEWS              ***
	 ********************************}

type
	{--- LIST ---}
	PSCodeListView   = ^TSCodeListView;
	TSCodeListView   = object(TCollectionViewer)

		constructor Init(Bounds: TRect; NCollection : PSCodeCollection; NAcceptorLink : PView);
		destructor Done; virtual;

		procedure SetCollection(const NCollection : PSCodeCollection);

		procedure TagItem(const ItemNo : longint); virtual;
		procedure TagAll(TagType : byte); {0 - tag, 1 - untag, 3 - invert tag} virtual;

		function GetText(const Item: longint) : string; virtual;
		procedure HandleEvent(var Event : TEvent); virtual;
		procedure RedrawNext; virtual;
		function EditItem(Item  : PObject) : word; virtual;
		function CreateNewItem : PObject; virtual;
		procedure Del(ItemNo : longint); virtual;
	end;

{	PSCodeList   = ^TSCodeList;
	TSCodeList   = object(TListWindow)
		constructor Init(Bounds: TRect; Collection : PSCodeCollection; NAcceptorLink : PView);
		procedure InitMenuBar; virtual;
	end;{}

type
	PInputSCLIne = ^TInputSCLIne;
	TInputSCLIne = object(TInputList)
		scType : byte;
		constructor Init(var Bounds : TRect; NFieldLen : integer; NscType : byte);
		destructor Done; virtual;
		procedure HandleEvent(var Event : TEvent); virtual;
		procedure ExecuteList;
		procedure Draw; virtual;
		function Valid (Command : Word) : boolean; virtual;
	end;

	PInputScode = ^TInputSCode;
	TInputSCode = object(TInputSCLine)
		constructor Init(var Bounds : TRect; NscType : byte);
		procedure SetData(var Rec); virtual;
		procedure HandleEvent(var Event : TEvent); virtual;
		function Valid (Command : Word) : boolean; virtual;
	end;


var
	{see global for maxnumscodetypes}
	SCodeCollection : array [1..MaxNumSCodeTypes] of PSCodeCollection;
	{An array of all the codes used by the program. Use constants in global
	to set, eg scMachType, etc which will correspond to a particular entry
	in the table}

{Shortcut}
function ExpandSCode(scType : word; Code : string) : string;
function GetSCode(scType : word; Code : string) : PSCodeItem; {DO NOT DISPOSE OF AFTER USE!!!}

{for registering collections}
procedure RegisterSCodeType(scType : byte; FileName, UserName : string; SCodeCreator : TSCodeCreator);

procedure UnloadUnusedSCodes;
procedure ShutDownSCodes; {used at end to check all closed & disposed}

{various short-code access/administration}
procedure WriteSCode(var S : TDataStream; SCode : PString);
procedure ReadSCode( var S : TDataStream; SCode : PString);
procedure WriteSCLine(var S : TDataSTream; SCLine : PString; SCLen : byte);
procedure ReadSCLine( var S : TDataStream; SCLine : PString; SCLen : byte);


IMPLEMENTATION

uses  tuiApp,
			{$IFNDEF SingleUser} muser, {$ENDIF} {locks, etc}
			printers,
			tasks,
			tuimsgs,
			help, minilib, dialogs, app, menus, memory;

{*************************************************************
 ***          STREAM READ/WRITES                           ***
 *************************************************************}
procedure WriteScode;
begin
	S.WriteFixedStr(SCode, 3);
end;

procedure ReadSCode;
begin
	Scode^ := S.ReadFixedStr(3);
end;

procedure WriteSCLine;
begin
	{Really want to store in groups of 3 - each 3 corresponding to one code}
	{Would have to allow for lots of single codes though, eg W W B C A etc}
	{For now, just use fixed length string read/write}
	S.WriteFixedStr(SCLine, SCLen);
end;{}

procedure ReadSCLine;
begin
	SCLine^ := DelSpaceR(S.ReadFixedStr(SCLen));
end;

{Shorthand functions - saves having to write out longwinded SCodeCollection methods}
function ExpandSCode;
var scErr : boolean;
begin
	if SCodeCollection[scType]<>nil then begin
		SCodeCollection[scType]^.LogOn;
		ExpandSCode := SCodeCollection[scType]^.ExpandLine(Code, scErr);
		SCodeCollection[scType]^.LogOff;
	end else
		ExpandSCode := '?*NO COLLECTION*';
end;

{Gets scodeitem corresponding to given code.  Provides a pointer to existing
 scodeitem so DO NOT DISPOSE OF AFTERWARDS!!!}
function GetSCode;
begin
	if (SCodeCollection[scType]<>nil) then begin
		SCodeCollection[scType]^.LogOn;
		GetSCode := SCodeCollection[scType]^.FindItem(Code);
		SCodeCollection[scType]^.LogOff;
	end else
		GetSCode := nil;
end;


{*********************************
 ***       FORM CODE           ***
 *********************************}
constructor TScodeFormCode.Init;
begin
	inherited Init(NCode);
	Scode := NScode;
	scType := NscType;
end;

function TScodeFOrmCode.Replace;
begin
	Replace := True;

	if (SubCode = 'S') or (pos('/S',Param)>0) then begin
		{just show shortcode, not description}
		String2LS(SCode, LString);
	end else
		String2LS(ExpandSCode(scType, SCode), LString);

end;




{****************************************************************************
 ***                  Short CODE  OBJECT                               ***
 ****************************************************************************}

{=== CREATE ==================================}
constructor TSCodeItem.Init;
begin
	inherited Init;
	Code := NCode;
	Description := NewStr(NDesc);
	Tag := False;
end;

{=== DESTROY =================================}
destructor TSCodeItem.Done;
begin
	DisposeStr(Description);
	inherited Done;
end;

{=== DISPLAY LINE ============================}
function TSCodeItem.DisplayLine(maxlen : integer) : string;
var C : char;
begin
	if Tag then C := '*' else C := ' ';
	DisplayLine := PadSpaceR(Code,3) + C + Description^;
end;

{=== LOAD ===================================}
constructor TSCodeItem.Load;
var Rubbish : real;
		Ver : byte;
begin
	S.Read(Ver, 1);
	if Ver<4 then begin {old version - where ver is length of code}
		S.Seek(S.GetPos-1);  {read back from version}
		S.Read(Code, sizeof(Code));
		S.Read(Rubbish, 6);  {Used to be var}
		Description := NewStr(S.ReadStr);
	end else begin
		S.Read(Code, sizeof(Code));
		Description := NewStr(S.ReadStr);
	end;
	Tag := False;
end;

{=== STORE ==================================}
procedure TSCodeItem.Store;
var Ver : byte;
begin
	Ver :=4; S.Write(Ver, 1);
	S.Write(Code, sizeof(Code));
	S.WriteStr(Description);
end;

{**************************************
 ***     EDIT Short CODE DATA    ***
 **************************************}

{Caller is the list - usually SCodeList - that required this edit}
function TSCodeItem.Edit(Caller : PView) : word; {Returns "control" below}
var
 Editor : TObjectEditBox;
 R : TRect;
 Point : TPoint;
 Control : Word;

begin
	R.Assign(0, 0, 33, 8);
	{--- Set up box interior ---}
	with Editor do begin  {provide offset for R}
		CentreOnView(R, Caller);		{Position box - centralise over caller}
		Init(R, 'Code Detail', Caller);

		AddEditFields(@Editor);  {For descendant scodeitems}

		{-- Buttons --}
		InsOKButton( 7, Size.Y-3, @Self);
		InsCancelButton(18, Size.Y-3);

		EndInit;
		SetData(Self);
	end;

	{---- Execute Dialog box ----}
	repeat
		Control := Desktop^.ExecView(@Editor);

		Code := delspace(Code);  {Just to make sure no spaces added}

	until (Control = cmCancel) or Valid; {Valid checks to see if data OK}
																			{Easier for descendants than adding a valid wossname to the editor box}

	Editor.Done;

	Edit := Control;
end;

function TSCodeItem.Valid;
begin Valid := True; end;


procedure TScodeItem.AddEditFields(P : PObjectEditBox);
var R : TRect;
begin
	with P^ do begin
		Insert(New(PSkipBytes, init(1))); {tag}

		InsTitledField( 9,2, 3, 1, 'Code', New(PInputELine, Init(R,3))); {Code - word}
		PInputELine(Current)^.UpperCase := True;
{$IFNDEF fixit}		if Code <> space(length(Code)) then
			Current^.SetState(sfDisabled, True); {$ENDIF} {disable if not new}

		InsTitledField( 9,3,21, 1, 'Desc', New(PInputPStr, Init(R,99))); {Description - string pointer}
		PInputELine(Current)^.MustInputToClose := True;
	end;
end;


function TScodeItem.Print;
begin
	Device^.writeln('    '+padspaceR(Code,3)+'  '+Description^);
end;



{***************************************************************************
 ***                                                                     ***
 ***                    COLLECTION OF SHORT CODES                        ***
 ***                                                                     ***
 ***************************************************************************}

constructor TSCodeCollection.Init;
begin
	inherited Init(10,10);

	FileName := NewStr(NFileName);
	Name := NewStr(NUserName);
	SCodeCreator := NSCodeCreator;

	Lock := 0;
	LoggedOn := 0;
	VerLastLoad := 255; {so it reads old scode collections, first word = 109}
	Loaded := False;
end;

destructor TScodeCollection.Done;
begin
	StoreCodes(lkOff);
	DisposeStr(Name);
	DisposeStr(FileName);
	inherited Done;
end;

{*******************************
 ***  COLLECTION ADMIN       ***
 *******************************}

{=== SORTING ROUTINES ============================================}
function TSCodeCollection.Compare;
var
	S1, S2 : string;

begin
{  S1 := PString(Key1)^; S2 := PString(Key2)^;{}
	S1 := ucase(PSCodeItem(Key1)^.Description^);
	S2 := ucase(PSCodeItem(Key2)^.Description^);

	if S1 = S2 then compare := 0
		else if S1 < S2 then compare := -1
			else if S1 > S2 then compare := 1;
end;


{=== LOCATE CODE ITEM MATCHING CODE ==================================}
function TSCodeCollection.FindItem(Code : string) : PSCodeItem;

	function CodeMatch(SCode : PSCodeItem) : boolean; far;
	begin
		CodeMatch := (Code = SCode^.Code);
	end;

begin
	Code := DelSpace(Code);
	if Code = '' then
		FindItem := nil
	else
		FindItem := FirstThat(@CodeMatch);
end;

{=========== LOCATE DESCRIPTION FROM CODE ==============}
function TSCodeCollection.Desc(Code : string) : string;
var Item : PScodeItem;
begin
	if Code = space(length(Code)) then	Desc := ''
		else begin
			Item := FindItem(Code);
			if Item = nil then Desc := '?' {Cannot be found}
				else if Item^.Description = nil then Desc := ''
					else Desc := DelTildes(Item^.Description^); {remove tildes as well}
		end;
end;

{=== Check for duplicate code =======================================}
function TSCodeCollection.CheckDupCode;

	function TestDup(TestItem : pointer) : boolean; far;
	begin
		if (PScodeItem(TestItem)^.Code = Item^.Code) or
			 (PSCodeItem(TestItem)^.Description^ = Item^.Description^) then TestDup := True
																								else TestDup := False;
	end;

begin
	CheckDupCode := FirstThat(@TestDup);
end;


{==== EXPAND A LINE OF CODES =================================}
{Returns self as string and found as whether all valid}
function TSCodeCollection.Expandline;
var Code : string;
		Display : string;
begin
	 Valid := True;
{	 Codes := ucase(DelSPace(Codes))+' ';{}
	 Display := '';
	 while length(Codes)>0 do begin
			Codes := DelSpace(Codes)+' ';   {Delete extra spaces at beginning}
			Code := Copy(Codes,1,Pos(' ',Codes)-1);  {Extract single code}
			Display := Display + Desc(Code)+ ', ';
			if Desc(Code)='?' then Valid := False; {Not a valid scode}
			Codes := Copy(Codes, Pos(' ',Codes)+1,length(Codes));
	 end;
	 if Display<>'' then Display := Copy(Display,1, length(Display)-2); {Chop off comma & space}
	 ExpandLine := Display;
end;



{=== ERROR =====================================================}
procedure TScodeCollection.Error;
const
	Mess : array[-2..-1] of string = ('Overflow', 'Out of Range');
begin
	ProgramError('COLLECTION '+Mess[Code]+' '+N2Str(Info),hcInternalErrorMsg);
end;

{=== PRINT ======================================================}
procedure TScodeCollection.Print;
var I : longint;
begin
	ThinkingOn('Printing');
	Printer^.FormCodes^.SetStr('RTITLE',Name^+' List');
	Printer^.StartPrint('REPORT','');
	for I := 0 to Count - 1 do PScodeITem(At(I))^.Print(Printer, prFullPage);
	Printer^.EndPrint;{}
	ThinkingOff;
end;


{**********************************
 ***    LOGGING ON/OFF/LOADING  ***
 **********************************}
procedure TSCodeCollection.LogOn;
begin
{	if (Count=0) and (Collection<>nil) then ProgramError('Nobody using '+UserName^+' but Collection<>nil','');{}
	if (LoggedOn<>0) and not Loaded then ProgramError('Someone supposed to be using '+Name^+' but not Loaded',
																											hcInternalErrorMsg);

	inc(LoggedOn);
	if not Loaded then LoadCodes(lkIgnore);
end;

procedure TScodeCollection.LogOff;
begin
{	if (Count=0) and (Collection<>nil) then ProgramError('Nobody using '+UserName^+' but Collection<>nil','');{}
	if (LoggedOn<>0) and not Loaded then ProgramError('Someone supposed to be using '+Name^+' but not Loaded',
																											hcInternalErrorMsg);

	if LoggedOn=0 then
		ProgramWarning('Logged Off Scode Collection too many times'#13#10+Name^+', LoggedOn='+N2Str(LoggedOn),
																											hcINternalErrorMsg)
	else
		dec(LoggedOn);
end;


procedure TSCodeCollection.UnLoad;
begin
	StoreCodes(lkOff);
	FreeAll;
	Loaded := False;
end;

procedure TScodeCollection.LoadLock;
var	SCodeFile : PDataStream;
begin
	Lock := 0;
{$IFNDEF SingleUser}
	New(SCodeFile, Init(FileName^,1, 15));  {only going to read one byte}
	if ScodeFile^.NoRecs>0 then	begin
		ScodeFile^.Seek(0);
		ScodeFile^.Read(Lock, 1);
	end;
	dispose(ScodeFile, done);
{$ENDIF}
end;

procedure TScodeCollection.StoreLock;
var	SCodeFile : PDataStream;
begin
{$IFNDEF SingleUser}
	New(SCodeFile, Init(FileName^,1, 15));
	ScodeFile^.Seek(0);
	ScodeFile^.Write(Lock, 1);
	dispose(ScodeFile, done);
{$ENDIF}
end;


{============ LOAD ================}
procedure TSCodeCollection.LoadCodes(LockStatus : byte);
var	SCodeFile : PDataStream;
		FileVer : byte;

begin
{$IFDEF SingleUser}
	if Loaded then exit; {no need to load again if singleuser and already loaded}
{$ENDIF}

	{---- Load ---}
	New(SCodeFile, Init(FileName^,1, StreamBufSize));
	if ScodeFile^.NoRecs>2 then begin {if not empty}
		ScodeFile^.Read(Lock, 1);

		{$IFNDEF SingleUser}
		if (Lock<>0) and ((LockStatus and lkIgnore)=0) then begin
			LockMessage('Short Codes',Lock,mfContinueButton);
		end;
		{$ENDIF}

		SCodeFile^.Read(FileVer, 1);

		if not Loaded or (FileVer<>VerLastLoad) then begin {if filever hasn't changed, then don't bother loading}

			ThinkingOn('Loading '+Name^);
			if Loaded then Unload; {clear existing}
			inherited LoadCodes(ScodeFile^); {do ordinary load}
			Pack; {deletes any nil pointers that have failed to load}
			VerLastLoad := FileVer;
			ThinkingOff;

		end;

		if ScodeFile^.Status<>stOk then ScodeFile^.ErrorMsg('Loaded SCodes '+FileName^);
	end;
	dispose(ScodeFile, done); {dispose before it may store below when locking}

{$IFNDEF SingleUser}
	if (Lock = 0) and (LockStatus = lkOn) then begin
		Lock := TerminalNo;
		StoreLock;
	end;
{$ENDIF}

	Loaded := True;
end;


{=============== STORE =================}
procedure TSCodeCollection.StoreCodes(LockStatus : byte);
var	SCodeFile : TDataStream;

begin
	if Loaded then begin
		case LockStatus of
			lkOn : Lock := TerminalNo;
			lkOff : Lock := 0;
		end;

		SCodeFile.Init(FileName^,1, StreamBufSize);
		ScodeFile.Write(Lock, 1);
		inc(VerLastLoad);
		SCodeFile.Write(VerLastLoad, 1);

		Store(ScodeFile);
		if ScodeFile.Status<>stOk then ScodeFile.ErrorMsg('Stored SCodes '+FileName^);
		SCodeFile.Done;
	end;
end;


{runs list, attempted positioned at global co-ords X,Y, if not 0}
procedure TSCodeCollection.ExecuteList(ACceptor : PINputELine);
var SCodeList : PListWindow;
		R : TRect;
		P : TPoint;

begin
	{Positioning & size}
	R.Assign(0,0,38,18);  {Set std size}

	{Create & set list}
	New(SCodeList, Init(R, Name^, New(PSCodeListView, Init(R, @Self, Acceptor))));

	if SCodeList<>nil then begin

		{Locate position on screen, based on input line}
		if Acceptor<>nil then begin
			P.X := 0; P.Y := 0;
			Acceptor^.MakeGlobal(P, P); {Find where TL of input line is and set Top Left to there}
			R.Move(P.X-1, P.Y-5);
			{Make sure it'll fit - o/w move}
			if R.B.Y>Desktop^.Size.Y then R.B.Y := Desktop^.Size.Y-1; {clip bottom}
			if R.B.X>Desktop^.Size.X then R.Move(Desktop^.Size.X - R.B.X,0); {move onto screen}

			SCodeList^.Locate(R); {Move list}

			{If code selected, focus there, o/w Look for nearest match of code}
			if delspaceR(Acceptor^.Data^)<>'' then
{				if ExpandLine(Acceptor^.Data^, scErr)<>'?' then
					PSCodeListView(SCodeList^.List)^.FocusText(ExpandLine(Acceptor^.Data^, scErr)) {Chop off : and search}
{				else{}
					PSCodeListView(SCodeList^.List)^.FocusText(Acceptor^.Data^); {Focus on nearest to code entered}
		end else
			SCodeList^.Options := SCodeList^.Options or ofCentered;

		Desktop^.ExecView(SCodeList);  {Owner = Dialog, Owner Owner = list}

		Dispose(SCodeList, Done);
	end;

end;

{***************************************************************************
 ***                   Short CODE LIST VIEWER                         ***
 ***************************************************************************}
{=========== LIST INTERIOR ===================================}
{doesn't handle locking at the moment...}

{--- Initialise -----------------------------------------}
constructor TSCodeListView.Init;
begin
	if not inherited Init(Bounds, lsScodes) then fail; {do inherited init, pass on fail if that has}
	GrowMode := gfGrowHiX + gfGrowHiY;

	AcceptorLink := NAcceptorLink; {acceptor line}

	SearchCol := 4;   {Search column for description}
	{For locking list use ViewOnly field from MultiLineList}
	Collection := nil;
	SetCollection(NCollection);

	FocusItem(0);
end;


destructor TSCodeListView.Done;
begin
	SetCollection(nil); {set to nil to do storing, also to prevent disposal of collection in inherited}
	inherited Done;
end;

{OK, not very sensible, but it might be that, eg options module, a scode
list view depends on some other view, so we want to change the collection
used in the view}
procedure TScodeListView.SetCollection;
var	Control : word;
begin
	{store & dispose of last collection}
	if Collection<>nil then with PSCodeCollection(Collection)^ do begin
		if (Lock=TerminalNo) or (Lock=0) then
			{it was locked by self or non multiuser}
			if Changed then
				StoreCodes(lkOff)
			else begin
				Lock := 0;
				StoreLock;
			end;

		LogOff;
	end;

	Collection := NCollection;             {Pointer to existing collection}

	{-- load & lock new collection --}
	if Collection<>nil then with PSCodeCollection(Collection)^ do begin

		{make sure we get the latest codes (& the lock and version marker)}
		if not Loaded then LoadCodes(lkIgnore); {only loads if ver changed}
		LogOn; {notify collection it is in use}
		Changed := False;
		ViewOnly := False;

		{$IFNDEF SingleUser}{$IFNDEF fixit}
			{Check lock - already loaded above}
			Control := cmOVerride;

			if Lock<>0 then
				Control := LockMessage(Name^+#13#10+'Access only Allowed',Lock,mfOKOverRetry);

			case Control of
				cmRetry : begin
					{locked - try again}
					Collection := nil;
					SetCollection(NCollection);
					LogOff; exit;
				end;  {Retry}
				cmOK : ViewOnly := True; {cmOK - accept that locked - set to View only}
			else
				{Normal operation - lock}
				Lock := TerminalNo;
				StoreLock;
			end;
		{$ENDIF}{$ENDIF}
	end;

	SetRange;
	if not inRange(Focused) then SetFocused(LastItem);
	Redraw;
end;


{--- Get Text -------------------------------------------}
function TSCodeListView.GetText(const Item : longint) : string;
var
	P : PSCodeItem;
begin
	P := Collection^.At(Item);
	if P = nil then GetText := ''	else GetText :=P^.DisplayLine(Size.X);
end;

{procedure TSCodeListView.FocusText;
var I : integer;
		SS : string;
begin
	I := 0;
	while (I<Collection^.Count) and
				(UCase(Copy(GetCopy(PSCodeItem(Collection^.At(I))^.Description^,1,length(S)))<>UCase(S)) do begin
		Inc(I);
	end;
	if I<SCodeColl^.Count then FocusItem(I);
end;

{tagging}
procedure TSCodeListView.TagItem(const ItemNo : longint);
begin
	if inrange(ItemNo) then begin
		PScodeItem(Collection^.At(ItemNo))^.Tag := not PScodeItem(Collection^.At(ItemNo))^.Tag;
		RedrawItem(ItemNo);
	end;
end;

procedure TSCodeListView.TagAll(TagType : byte); {0 - tag, 1 - untag, 3 - invert tag}
begin end;

{---- Handle Event -------------------------------------}
procedure TSCodeListView.HandleEvent(var Event : TEvent);
var	Scode : PSCodeItem;

begin
	if (Event.What = evCommand) then begin

		{--- Accept back to input line ---}
		if (Event.Command=cmAccept) and DrawnFocused then begin
			{---- Send Short Code to input line -----}
			Scode := Collection^.At(Focused);
			SendAcceptMessage(Event, cmAcceptSCode, @Scode^.Code);
		end;

		{--- print list ----}
		if (Event.Command=cmPrintList) and (Collection<>nil) then	begin
			PSCodeCollection(Collection)^.Print;
			ClearEvent(Event);
		end;

	end;

	inherited HandleEvent(Event);
end;

procedure TScodeListView.ReDrawNext;
begin
	inherited RedrawNext;
	{$IFNDEF fixit} {DisableCommands([cmDel]){} {$ENDIF}; {no delete allowed in Short codes}
{	if ViewOnly then DisableCommands([cmNew, cmEdit]); {don't allow even look edit - keeps things simple.  Can always retry}
end;

{***********************************************
 ***        EDIT LIST ITEM                   ***
 ***********************************************}
function TSCodeListView.EditItem(Item : PObject) : word;
var
	Control : word;
	WorkSCode : PSCodeItem;     {Working Short Code}

begin
	repeat
		Control := PSCodeItem(Item)^.Edit(@Self);

		{Check for duplicates}
		if (Control <> cmCancel) and (Collection^.Count>0) then begin
			WorkSCode := PSCodeCollection(Collection)^.CheckDupCode(PSCodeItem(Item));
			if (WorkSCode<>nil) and (PSCodeItem(Item)<>WorkScode) then begin {If there is a duplicate and it's not the one selected}
				{Code or description already exists}
				InputWarning('Code or Description already exists:'+#13#10+
									WorkScode^.Code+': '+WorkScode^.Description^,
									hcDupSCodeMsg);
				Control := cmInValid;
			end;
		end;
	until Control<>cmInvalid;

	EditItem := Control;
end;


{***********************************************
 ***        CREATE NEW LIST ITEM             ***
 ***********************************************}
function TSCodeListView.CreateNewItem;
begin
	if Collection<>nil then
		CreateNewItem := PSCodeCollection(Collection)^.SCodeCreator('',' ')
	else
  	CreateNewItem := nil;
end;


{***********************************************
 ***         DELETE LIST ITEM                ***
 ***********************************************}
procedure TSCodeListView.Del(ItemNo : longint);
begin
	{only allow if in tekky mode}
	{$IFDEF fixit} inherited Del(ItemNo);  {$ENDIF}
end;



{********************************************
 ***           SCODE LIST WINDOW          ***
 ********************************************}
{constructor TSCodeList.Init;
begin
	if not inherited Init(Bounds, Collection^.Name^, nil,
												New(PSCodeListView, init(Bounds, Collection, NAcceptorLink))) then fail;
end;

procedure TScodeList.InitMenuBar;
begin
	inherited InitMenuBar;

	AddItemSubMenu(MenuBar^.Menu, '~P~rint',
		NewItem('~L~ist',    'F9',  kbF9,     cmPrintList,    hcNoContext,
	nil));
end;




{******************************************************
 ***          INPUT A LINE OF Short CODES        ***
 ******************************************************}


	constructor TInputSCLIne.Init;
	begin
		inherited Init(Bounds,NFieldLen,0);
		scType := NscType;
		HelpCtx := hcInputSCode;
		SCodeCollection[scType]^.LogOn;
		EventMask := EventMask or evBroadCast; {accept "accept"  message from list}
		UpperCase := True;
	end;

	destructor TInputSCLine.Done;
	begin
		SCodeCollection[scType]^.LogOff;
		inherited Done;
	end;


procedure TInputSCLIne.HandleEvent(var Event : TEvent);
var	Code : string;

begin
	{--- Pick up message with Short code ---}
	if Event.Command = cmAcceptSCOde then begin
		Code := PString(Event.InfoPtr)^; {dereference Short code}
		Data^ := DelSpace(Data^);
		if pos(' '+Code+' ', ' '+Data^+' ')=0 then {don't accept in if already there}
			if (Data^<>'') then begin
				if (length(Data^)+length(Code))<Maxlen then	Data^ := Data^ + ' ' + Code;
			end else
				Data^ := Code; {avoid getting space into first}

		ClearEvent(Event); {set to handled}
		Draw;
		SetChanged; CheckLink;   {Check any dependant boxes, and force update}
	end;

	{used by inptelnum to find which country tel is for}
	if (Event.What = evBroadCast) and (Event.Command = cmGetCountryView) then
		ClearEvent(Event);


	inherited HandleEvent(Event);

	if GetState(sfFocused) then begin

		{--- Run the Short code list ----}
		if (Event.What = evCommand) and (Event.Command=cmList) then begin
			ExecuteList;
			ClearEvent(Event);
		end;
	end;
end;



procedure TInputSCLine.ExecuteList;
begin
	{owner may be nil if we're using this as an acceptor line for a floating
	scode list}
	if Owner<>nil then Owner^.SetState(sfActive, false); {switch off frame, etc}
	SCodeCollection[scType]^.ExecuteList(@Self);
	if Owner<>nil then Owner^.SetState(sfActive, True);{}
end;


	{--- Draw, with expansion ----}
	procedure TInputSCLIne.Draw;
	var	Display : string;

	begin
		inherited Draw;
		if not GetState(sfDisabled) then writechar(0,0, #67, 4,1);   {Draws luminous green C}

		if (Size.X)>(Maxlen+3) then begin {don't do if only room for entry}
			Display := ExpandSCode(scType, Data^);
			if Display<>'' then Display := ': '+Display;
			Writestr(Length(Data^)+1, 0, Display, 1);
			if (length(Display)+length(Data^))>Size.X then WriteChar(Size.X-1, 0, #16, 4, 1);
		end;
	end;


	{--- Check at end of input to see if OK ----}
	function TInputSCLIne.Valid(Command: Word) : boolean;
	var S,Code : string;
			V : boolean;
			SCErr : boolean;
	begin
		V := inherited Valid(Command);
		if V and DoValidFor(Command) and not DoList then begin {dolist check stops stack overflow due to focus->valid}
			{run through and make sure only one space between codes}
			Code := SplitBy(Data^,' '); S := '';
			while Code<>'' do begin
				S := S + Code+' ';
				Code := SplitBy(Data^,' ');
			end;
			if S<>'' then Data^ := Copy(S,1,length(S)-1); {remove last space}

			if Command<>cmForceLink then begin
				SCodeCollection[scType]^.ExpandLine(Data^, SCErr);
				if SCErr = False then begin
					{problem with codes entered}
					WarningBleep;
					DoList := True; {do list on return to handleevent}
					V := False;
					Focus; {problem with stack overflow, so dolist check above...}
				end;
			end;

		end;
		Valid := V;
	end;

	{***********************************************************
	 ***             INPUT SINGLE SCODE                      ***
	 ***********************************************************}

	constructor TInputScode.Init;
	begin
		inherited Init(Bounds,3,NscType);  {Field length of 3}
	end;

	{Has to be var to fit previous definition of SetData}
	procedure TInputScode.SetData(var Rec);
	begin
		inherited SetData(Rec);

		{Pad out to fill - lines up better for <3 char codes}
		{but only do if not empty.  If empty there's
		no need and jane found an odd problem where if you go left/right, and the
		green "selected block" vanishes leaving you unable to see them and unable
		to type - as there's no room to insert new text...}
		if delspaceR(data^)='' then
			data^ := '' {get rid of all spaces}
		else
			data^ := PadSpaceR(data^, 3);

	end;

	procedure TInputSCode.HandleEvent(var Event : TEvent);
	var Code : string;

	begin
		{--- Pick up message with Short code ---}
		{different from the other one in that it *replaces* current code}
		if (Event.Command = cmAcceptSCOde) then begin
			Code := PString(Event.InfoPtr)^; {dereference Short code}
{			 DisposeStr(Event.InfoPtr);{Ought to do a newstr and then this...}
			Data^ := Code;
			ClearEvent(Event); Event.Command := cmNone; {set to handled}
			Draw;
			SetChanged; CheckLink;   {Check any dependant boxes, and force update}
		end;

{		if Event.What = evKeyBoard then begin
			Data^ := PadSpaceR(Data^, 3);
			BlockCursor; {Force insert off}
{		end;{}

		inherited HandleEvent(Event);

	end;

	function TInputSCode.Valid;
	var V : boolean;
	begin
		V := inherited Valid(Command);

		if V and (Command<>cmCancel) then begin

			if delspaceR(Data^)='' then
				Data^ := '' {see setdata for reason}
			else
				Data^ := padspaceR(Data^,3); {inputscline chops off surplus spaces, but for neatness,
																			in inputscode always pad out}

			{check for two single-letter codes}
			if (Data^[0]=#3) and (Data^[2]=' ') and (Data^[3]<>' ') then begin
				Focus;
				InputWarning('Short-Code Field'#13#10'One code only!',hcOneSCOnlyMsg);
				V := False;
			end;
		end;

		Valid := V;
	end;


{*****************************************************
 ***          CLEAN UP MEMORY                      ***
 *****************************************************}
procedure UnloadUnusedScodes;
var I : integer;
begin
	for I := 1 to MaxNumScodeTypes do
		if SCodeCollection[I] <> nil then
			if (SCodeCollection[I]^.LoggedOn <= 0) and (SCodeCollection[I]^.Loaded) then
				SCodeCollection[I]^.Unload;
end;


procedure ShutDownSCodes;
var I : integer;
begin
	ThinkingOn('Shutting Down Codes');
	for I := 1 to MaxNumSCodeTypes do
		if SCodeCollection[I] <> nil then
			if (SCodeCollection[I]^.LoggedOn<>0) then begin
				{$IFDEF Development}
				ProgramWarning(N2Str(SCodeCollection[I]^.LoggedOn)+' "users" of '+SCodeCollection[I]^.Name^+' on shutdown',
												hcINternalErrorMsg);
				{$ELSE}
				RecordError('PROGRAM WARNING:',
														'Still '+N2Str(SCodeCollection[I]^.Count)+' "users" of '+SCodeCollection[I]^.Name^
														+' on shutdown', ''){};
				{$ENDIF}
				SCodeCollection[I]^.Unload;
			end;
	ThinkingOff;
end;


procedure RegisterSCodeType(scType : byte; FileName, UserName : string; SCodeCreator : TSCodeCreator);
begin
	if scType>MaxNumSCodeTypes then
		ProgramError('Trying to register SCode Admin #'+N2Str(sctype)+#13+'Max Array='+N2Str(MaxNumSCodeTypes), hcInternalErrorMsg)
	else begin
		if SCodeCollection[scType]<>nil then
			{already exists - replace with this definition}
			dispose(SCodeCollection[scType], done);

		New(SCodeCollection[scType], Init(FileName, UserName, ScodeCreator))
	end;
end;


{***************************************
 ***          INITIALISATION         ***
 ***************************************}
function StdSCodeCreator(const NCode, NDesc : string) : PScodeItem;
begin
	StdSCodeCreator := New(PScodeItem, init(NCOde, NDesc));
end;



const
 {Make sure registered in this order, so that new number replaces old one in all new
 puts...}
 RSCodeItem : TStreamRec = (
	 ObjType : srSCodeItem;
	 VmtLink : Ofs(TypeOf(TSCodeItem)^);
	 Load : @TSCodeItem.Load;
	 Store : @TSCodeItem.Store
 );

{const
 RSCodeCollection : TStreamRec = (
	 ObjType : srSCodeCollection;
	 VmtLink : Ofs(TypeOf(TSCodeCollection)^);
	 Load : @TSCodeCollection.Load;
	 Store : @TSCodeCollection.Store
 );{}


var
	I : byte;

begin
{	RegisterType(RSCodeCollection);{}
	RegisterType(RSCodeItem);

	for I := 1 to MaxNumSCodeTypes do SCodeCollection[I] := nil;    {Clear scode admin array}

	RegisterTask(ShutDownTasks, 100, @shutdownScodes);
	RegisterTask(LowMemoryTasks, 0, @UnloadUnusedScodes);

	RegisterWithList(lsScodes, '~P~rint', NewItem('~L~ist',   ksPrintList, kbPrintList, cmPrintList, hcNoContext,nil),nil);
	{do editscodes in maintenance so it's not loaded here all the time}
end.

