X11TclImpl.mesa
Copyright Ó 1992, 1993 by Xerox Corporation. All rights reserved.
Created by Christian Jacobi, January 17, 1992 8:20:45 pm PST
Christian Jacobi, April 19, 1993 10:37 am PDT
DIRECTORY CardTab, Convert, ForkOps, Process, RefText, Rope, SymTab, Xl, XlPredefinedAtoms, X11Tcl;
X11TclImpl:
CEDAR
MONITOR
IMPORTS CardTab, Convert, ForkOps, Process, RefText, Rope, SymTab, Xl
EXPORTS X11Tcl ~
BEGIN OPEN X11Tcl;
=== Scanning ========
ScanRef: TYPE = REF ScanRec;
ScanRec:
TYPE =
RECORD [
length: INT,
next: INT,
text: Rope.ROPE,
error: BOOL
];
freeScannable: ScanRef ¬ NIL;
NewScanable:
ENTRY
PROC [r: Rope.
ROPE]
RETURNS [s: ScanRef] = {
s ¬ freeScannable;
freeScannable ¬ NIL;
IF s=NIL THEN s ¬ NEW[ScanRec];
s.length ¬ Rope.Length[r];
s.text ¬ r;
s.next ¬ 0;
s.error ¬ FALSE
};
TrustedDisposeScanable:
PROC [s: ScanRef] = {
freeScannable ¬ s;
};
NextExcept:
PROC [s: ScanRef, stopAt:
CHAR ¬ 0C]
RETURNS [ch:
CHAR] = {
IF s.next>=s.length THEN {s.error ¬ TRUE; RETURN [0C]};
ch ¬ Rope.Fetch[s.text, s.next];
IF ch#stopAt THEN s.next ¬ s.next+1 ELSE s.error ¬ TRUE;
};
Next:
PROC [s: ScanRef]
RETURNS [ch:
CHAR] = {
IF s.next>=s.length THEN {s.error ¬ TRUE; RETURN [0C]};
ch ¬ Rope.Fetch[s.text, s.next];
s.next ¬ s.next+1
};
Back:
PROC [s: ScanRef] = {
IF s.next<1 THEN s.error ¬ TRUE ELSE s.next ¬ s.next-1
};
ExpectSpaces:
PROC [s: ScanRef, min:
INT ¬ 1, stopAt:
CHAR ¬ 0C] = {
FOR i:
INT
IN [0..min)
DO
IF (NextExcept[s, stopAt]#' ) THEN {s.error ¬ TRUE; RETURN};
ENDLOOP;
WHILE NextExcept[s, stopAt]=' DO ENDLOOP;
Back[s];
};
ExpectHex:
PROC [s: ScanRef, stopAt:
CHAR ¬ 0C]
RETURNS [n:
CARD32 ¬ 0] = {
HexVal:
PROC [s: ScanRef, ch:
CHAR]
RETURNS [val: [0..16)¬0] = {
SELECT ch
FROM
IN ['0..'9] => RETURN [ORD[ch]-ORD['0]];
IN ['A..'F] => RETURN [ORD[ch]-ORD['A]+10];
IN ['a..'f] => RETURN [ORD[ch]-ORD['a]+10];
ENDCASE => s.error ¬ TRUE;
};
char: CHAR;
--char ← NextExcept[s, stopAt];
--IF char#'0 THEN {s.error ← TRUE; RETURN [0]};
--char ← NextExcept[s, stopAt];
--IF char#'x AND char#'X THEN {s.error ← TRUE; RETURN [0]};
char ¬ NextExcept[s, stopAt];
n ¬ HexVal[s, char];
FOR i:
INT
IN [0..7)
DO
char ¬ NextExcept[s, stopAt];
IF (char=' ) THEN {Back[s]; RETURN [n]};
n ¬ n*16+HexVal[s, char];
ENDLOOP;
char ¬ NextExcept[s, stopAt];
IF (char=' ) THEN {Back[s]; RETURN [n]};
s.error ¬ TRUE;
};
max10: CARD32 ~ LAST[CARD32]/10;
ExpectDec:
PROC [s: ScanRef, stopAt:
CHAR ¬ 0C]
RETURNS [n:
CARD32] = {
DecVal:
PROC [s: ScanRef, ch:
CHAR]
RETURNS [val: [0..10)¬0] = {
SELECT ch
FROM
IN ['0..'9] => RETURN [ORD[ch]-ORD['0]];
ENDCASE => s.error ¬ TRUE;
};
char: CHAR;
dig: CARD;
n ¬ DecVal[s, NextExcept[s, stopAt]];
DO
char ¬ NextExcept[s, stopAt];
IF (char=' ) THEN {Back[s]; RETURN [n]};
IF n>max10 THEN {s.error ¬ TRUE; RETURN [0]};
n ¬ n*10;
dig ¬ DecVal[s, char];
IF LAST[CARD32]-n<dig THEN {s.error ¬ TRUE; RETURN [0]};
n ¬ n+dig;
ENDLOOP;
};
ExpectInterpName:
PROC [s: ScanRef, stopAt:
CHAR ¬ 0C]
RETURNS [interpName: Rope.
ROPE] = {
startPos: INT ¬ s.next;
DO
char: CHAR ¬ NextExcept[s, stopAt];
IF char='| THEN RETURN [Rope.Substr[s.text, startPos, s.next-startPos-1]]
ENDLOOP
};
Rest:
PROC [s: ScanRef, stopAt:
CHAR ¬ 0C]
RETURNS [interpName: Rope.
ROPE] = {
startPos: INT ¬ s.next;
DO
char: CHAR ¬ Next[s];
IF char=0C THEN RETURN [Rope.Substr[s.text, startPos, s.next-startPos-1]]
ENDLOOP
};
=== end Scanning ========
myKey: REF INT ~ NEW[INT];
ConnectionData:
TYPE ~
RECORD [
connection: Xl.Connection,
nextSerial: CARD ¬ 0, --monitored
sharedTQ: Xl.TQ,
listenerWindow: Xl.Window,
commAtom: Xl.XAtom,
interpRegistryAtom: Xl.XAtom,
interpRegistryContents: Rope.ROPE, --monitored with sharedTQ
openReplies: CardTab.Ref,
remoteInterpreters: SymTab.Ref,
-- monitored with sharedTQ;
-- name ==> (REF CARD32 ¬ WindowId)
ownInterpreters: SymTab.Ref,
-- interpreterName ==> REF Interpreter
registryCacheOk: BOOL ¬ FALSE, --monitored with sharedTQ
maxLength: INT --of requests; adjusted to include boiler plate
];
Interpreter:
TYPE ~
RECORD [
cd: REF ConnectionData ¬ NIL,
listener: ListenerProc ¬ NIL,
unregisterNotify: UnregisterNotifyProc ¬ NIL,
replyOnPing: BOOL,
clientData: REF,
interpreterName: Rope.ROPE,
thread: Xl.TQ ¬ NIL,
refCounting: BOOL ¬ FALSE
];
CommandRec:
TYPE ~
RECORD [
i: REF Interpreter,
windowId: CARD32,
serial: CARD32,
command: Rope.ROPE
];
detailsForSynchronous: Xl.Details ~ NEW[Xl.DetailsRec ¬ [synchronous: TRUE, localErrors: inline]];
detailsForIgnoreErrors:
PUBLIC Xl.Details ¬
NEW[Xl.DetailsRec ¬ [errorMatch:
NEW[Xl.MatchRep ¬ [proc: IgnoreErrors, handles:
NIL, tq: Xl.CreateTQ[]]]]];
IgnoreErrors: Xl.EventProcType = {};
cdCache: REF ConnectionData ¬ NEW[ConnectionData];
GetConnectionData:
PROC [c: Xl.Connection]
RETURNS [
REF ConnectionData] = {
cd: REF ConnectionData ¬ cdCache;
IF cd.connection=c
THEN RETURN [cd]
ELSE {
val: REF ~ Xl.GetConnectionPropAndInit[c, myKey, Init];
cdCache ¬ cd ¬ NARROW[val];
RETURN [cd];
};
};
Init: Xl.InitializeProcType = {
listenerEvents: Xl.EventFilter ~ Xl.CreateEventFilter[propertyNotify, destroyNotify];
rootEvents: Xl.EventFilter ~ Xl.CreateEventFilter[propertyNotify];
tq: Xl.TQ ~ Xl.CreateTQ[];
cd: REF ConnectionData ~ NEW[ConnectionData];
listenerMatch: Xl.Match ~
NEW[Xl.MatchRep ¬ [
proc: ListenerEvent, handles: listenerEvents, tq: tq, data: cd
]];
rootMatch: Xl.Match ~
NEW[Xl.MatchRep ¬ [
proc: RootEvent, handles: rootEvents, tq: tq, data: cd
]];
cd.sharedTQ ¬ tq;
cd.connection ¬ c;
cd.commAtom ¬ Xl.MakeAtom[c: c, name: "Comm"];
cd.interpRegistryAtom ¬ Xl.MakeAtom[c: c, name: "InterpRegistry"];
cd.openReplies ¬ CardTab.Create[];
cd.ownInterpreters ¬ SymTab.Create[];
cd.maxLength ¬ Xl.Info[cd.connection].maxRequestLengthBytes - 100;
Xl.AddDispatch[c: c, window: Xl.FirstRoot[c], match: rootMatch, generate: [propertyChange: TRUE], details: detailsForIgnoreErrors];
cd.listenerWindow ¬ Xl.CreateWindow[c: c,
matchList: LIST[listenerMatch],
class: inputOnly,
attributes: [eventMask: [structureNotify: TRUE, propertyChange: TRUE]],
details: detailsForIgnoreErrors
];
RETURN [cd];
};
NewSerial:
ENTRY
PROC [cd:
REF ConnectionData]
RETURNS [s:
CARD32] = {
s ¬ cd.nextSerial;
cd.nextSerial ¬ cd.nextSerial+1;
};
RootEvent: Xl.EventProcType = {
--Registration changed
cd: REF ConnectionData ~ NARROW[clientData];
WITH event
SELECT
FROM
propertyNotify: Xl.PropertyNotifyEvent =>
IF propertyNotify.state=newValue
AND propertyNotify.atom=cd.interpRegistryAtom
THEN {
cd.registryCacheOk ¬ FALSE;
ReadRegistrations[cd];
};
ENDCASE => {};
};
ListenerEvent: Xl.EventProcType = {
--Got a request or reply
ENABLE Xl.XError => GOTO oops;
cd: REF ConnectionData ~ NARROW[clientData];
WITH event
SELECT
FROM
propertyNotify: Xl.PropertyNotifyEvent => {
IF propertyNotify.state=newValue
AND propertyNotify.atom=cd.commAtom
THEN {
prr: Xl.PropertyReturnRec ~ Xl.GetProperty[c: event.connection, w: cd.listenerWindow, property: cd.commAtom, delete: TRUE];
WITH prr.value
SELECT
FROM
commands: Rope.ROPE => ScanEvent[cd, commands, event];
ENDCASE => {};
};
};
destroyNotify: Xl.DestroyNotifyEvent => {
???
};
ENDCASE => {};
EXITS oops => {};
};
ScanEvent:
PROC [cd:
REF ConnectionData, commands: Rope.
ROPE, event: Xl.Event ¬
NIL] = {
s: ScanRef ~ NewScanable[commands];
windowId: CARD32;
serial: CARD32;
code: CARD32;
interpName: Rope.ROPE;
WHILE s.next<s.length
DO
s.error ¬ FALSE;
SELECT NextExcept[s]
FROM
'C => {
c: REF CommandRec ¬ NEW[CommandRec];
command: Rope.ROPE;
ExpectSpaces[s, 1];
windowId ¬ ExpectHex[s];
ExpectSpaces[s, 1];
serial ¬ ExpectHex[s];
ExpectSpaces[s, 1];
interpName ¬ ExpectInterpName[s];
command ¬ Rest[s];
IF ~s.error THEN ReceiveCommand[cd, windowId, serial, interpName, command, event];
};
'R => {
response: Rope.ROPE;
ExpectSpaces[s, 1];
serial ¬ ExpectHex[s];
ExpectSpaces[s, 1];
code ¬ ExpectDec[s];
ExpectSpaces[s, 1];
response ¬ Rest[s];
IF ~s.error THEN ReceiveResponse[cd, serial, LOOPHOLE[code], response];
};
ENDCASE => s.error ¬ TRUE;
IF s.error
THEN {
s.next ¬ Rope.SkipTo[s.text, s.next, "\000"];
};
ENDLOOP;
TrustedDisposeScanable[s];
};
ForkOrEnqueue:
PROC [tq: Xl.
TQ, proc: Xl.EventProcType, data:
REF ¬
NIL, event: Xl.Event ¬
NIL] = {
It would be nice to limit the maximal possible parallelism
IF tq=
NIL
THEN TRUSTED {Process.Detach[FORK proc[event, data, NIL]]}
ELSE Xl.Enqueue[tq, proc, data, event];
};
NotifyDeadness: Xl.EventProcType = {
refCounting: BOOL ¬ FALSE;
notify: UnregisterNotifyProc ¬ NIL;
i: REF Interpreter ~ NARROW[clientData];
Protected:
ENTRY
PROC [] =
INLINE {
notify ¬ i.unregisterNotify; i.unregisterNotify ¬ NIL;
refCounting ¬ i.refCounting; i.refCounting ¬ FALSE;
};
IF i#
NIL
THEN {
cd: REF ConnectionData ~ i.cd;
Protected[];
IF notify#
NIL
THEN
[] ¬ notify[c: cd.connection, interpreterName: i.interpreterName, clientData: i.clientData];
IF refCounting THEN Xl.DecRefCount[cd.connection, i];
};
};
QueuedReceiveCommand: Xl.EventProcType = {
comp: REF TEXT; --composed response to report to caller
response: Rope.ROPE ¬ NIL; --direct response gotten from execution of command
c: REF CommandRec ~ NARROW[clientData];
i: REF Interpreter ~ c.i;
cd: REF ConnectionData ~ i.cd;
code: TclCode;
IF i.replyOnPing
AND Rope.SkipOver[s: c.command, skip: " "]>=Rope.Length[c.command]
THEN {
code ¬ ok; response ¬ "";
}
ELSE {
[code, response] ¬ c.i.listener[c: cd.connection, interpreterName: i.interpreterName, command: c.command, clientData: i.clientData];
BEGIN
--Check response
position: INT;
IF Rope.Length[response] >= cd.maxLength
THEN {
code ¬ error; response ¬ "response too long";
};
position ¬ Rope.SkipTo[response, 0, "\000"];
IF position<Rope.Length[response]
THEN {
response ¬ Rope.Substr[response, 0, position];
};
END;
};
comp ¬ RefText.ObtainScratch[RefText.page];
comp ¬ RefText.AppendRope[comp, "R 0"];
comp ¬ Convert.AppendCard[to: comp, from: c.serial, base: 16, showRadix: FALSE];
comp ¬ RefText.AppendRope[comp, " 0"];
comp ¬ Convert.AppendCard[to: comp, from: LOOPHOLE[code], base: 16, showRadix: FALSE];
comp ¬ RefText.AppendChar[comp, ' ];
comp ¬ RefText.AppendRope[comp, response];
comp ¬ RefText.AppendChar[comp, 0C];
Xl.ChangeProperty[c: cd.connection, w: LOOPHOLE[c.windowId], property: cd.commAtom, type: XlPredefinedAtoms.string, mode: append, data: comp, details: detailsForIgnoreErrors];
RefText.ReleaseScratch[comp];
};
ReceiveCommand:
PROC [cd:
REF ConnectionData, windowId:
CARD32, serial:
CARD32, interpName: Rope.
ROPE, command: Rope.
ROPE, event: Xl.Event ¬
NIL] = {
WITH SymTab.Fetch[cd.ownInterpreters, interpName].val
SELECT
FROM
i:
REF Interpreter => {
c:
REF CommandRec ¬
NEW[CommandRec ¬ [
i: i,
windowId: windowId,
serial: serial,
command: command
]];
ForkOrEnqueue[i.thread, QueuedReceiveCommand, c, event];
};
ENDCASE => {};
};
ReceiveResponse:
PROC [cd:
REF ConnectionData, serial:
CARD32, code: TclCode, response: Rope.
ROPE] = {
WITH CardTab.Fetch[cd.openReplies, serial].val
SELECT
FROM
promise:
REF PromiseRec => {
--Somebody was awaiting this reply
SetReply:
ENTRY
PROC [promise:
REF PromiseRec, code: TclCode, response: Rope.
ROPE] = {
IF ~promise.timeout
THEN {
promise.code ¬ code;
promise.response ¬ response;
promise.ok ¬ TRUE;
NOTIFY promise.condition
};
};
SetReply[promise, code, response];
};
ENDCASE => {
--Nobody waits for this one
};
};
ReadRegistrationsProperty:
PROC [cd:
REF ConnectionData]
RETURNS [val: Rope.
ROPE ¬
NIL] = {
prr: Xl.PropertyReturnRec;
prr ¬ Xl.GetProperty[c: cd.connection, w: Xl.FirstRoot[cd.connection], property: cd.interpRegistryAtom ! Xl.XError => {prr.value ¬ NIL; CONTINUE}];
WITH prr.value
SELECT
FROM
r: Rope.ROPE => val ¬ r;
ENDCASE => {}
};
ReadRegistrations:
PROC [cd:
REF ConnectionData] = {
--protected: get the reading and flag setting atomic
--(We don't really care whether an application gets the previous or later contents; we DO care that each notification of contents change causes re-reading the property value)
ReadGlobals:
PROC [cd:
REF ConnectionData] = {
--read in the remoteInterpreters from the property
regs: Rope.ROPE ¬ ReadRegistrationsProperty[cd];
interpreters: SymTab.Ref ~ SymTab.Create[];
windowId: CARD32;
interp: Rope.ROPE;
s: ScanRef ¬ NewScanable[regs];
cd.interpRegistryContents ¬ regs;
WHILE s.next<s.length
DO
s.error ¬ FALSE;
windowId ¬ ExpectHex[s];
ExpectSpaces[s, 1];
interp ¬ Rest[s];
IF ~s.error
THEN {
[] ¬ SymTab.Insert[interpreters, interp, NEW[CARD32 ¬ windowId]];
};
ENDLOOP;
cd.remoteInterpreters ¬ interpreters;
TrustedDisposeScanable[s];
};
CheckLocals:
PROC [cd:
REF ConnectionData] = {
--check whether some local interpreters have been superceeded by foreign interpreters
Action: SymTab.EachPairAction = {
name: Rope.ROPE ~ key;
WITH SymTab.Fetch[cd.ownInterpreters, name].val
SELECT
FROM
i:
REF Interpreter => {
gId: REF CARD32 ~ NARROW[val];
IF gId#
NIL
AND gId#0
AND gId#illegalId
AND gId#Xl.WindowId[cd.listenerWindow]
THEN
ReplaceLocal[cd, name, NIL]
};
ENDCASE => {}; -- no local interpreter
};
[] ¬ SymTab.Pairs[cd.remoteInterpreters, Action];
};
ProtectedCheckInterpreters:
PROC [] = {
IF ~ cd.registryCacheOk
THEN {
ReadGlobals[cd];
CheckLocals[cd];
cd.registryCacheOk ¬ TRUE;
};
};
IF ~cd.registryCacheOk
THEN {
Xl.CallWithLock[cd.sharedTQ, ProtectedCheckInterpreters];
};
};
WriteInterpreters:
PROC [cd:
REF ConnectionData, remoteInterpreters: SymTab.Ref] = {
--OOPS: No locking of the root window property: But there is not much good in locking as Tcl doesn't lock it either
IF remoteInterpreters#
NIL
THEN {
r: Rope.ROPE;
p: REF TEXT ¬ RefText.ObtainScratch[RefText.page];
Each: SymTab.EachPairAction = {
rw: REF CARD32 ~ NARROW[val];
IF rw#0
AND rw#illegalId
THEN {
p ¬ RefText.AppendRope[p, "0"];
p ¬ Convert.AppendCard[to: p, from: rw, base: 16, showRadix: FALSE];
p ¬ RefText.AppendChar[p, ' ];
p ¬ RefText.AppendRope[p, key];
p ¬ RefText.AppendChar[p, 0C];
};
};
[] ¬ SymTab.Pairs[remoteInterpreters, Each];
Xl.ChangeProperty[c: cd.connection, w: Xl.FirstRoot[cd.connection], property: cd.interpRegistryAtom, type: XlPredefinedAtoms.string, mode: replace, data: p, details: detailsForIgnoreErrors];
RefText.ReleaseScratch[p];
};
};
PromiseRec:
TYPE =
RECORD [
ok: BOOL ¬ FALSE,
timeout: BOOL ¬ FALSE,
condition: CONDITION,
code: TclCode ¬ timeout,
response: Rope.ROPE ¬ NIL
];
TryTimingOut:
ENTRY
PROC [x:
REF] = {
pr: REF PromiseRec ~ NARROW[x];
IF ~pr.ok
THEN {
pr.timeout ¬ TRUE;
pr.code ¬ timeout;
pr.response ¬ "Timed out"
};
NOTIFY pr.condition
};
WaitForAction:
ENTRY
PROC [promise:
REF PromiseRec] = {
WHILE ~promise.timeout AND ~promise.ok DO WAIT promise.condition ENDLOOP
};
BuildCommand:
PROC [cd:
REF ConnectionData, interpName: Rope.
ROPE, command: Rope.
ROPE]
RETURNS [encoded:
REF
TEXT, serial:
CARD32] = {
Trusts caller to free up encoded afterwards
serial ¬ NewSerial[cd];
encoded ¬ RefText.ObtainScratch[RefText.line];
encoded ¬ RefText.AppendRope[encoded, "C 0"];
encoded ¬ Convert.AppendCard[to: encoded, from: Xl.WindowId[cd.listenerWindow], base: 16, showRadix: FALSE];
encoded ¬ RefText.AppendRope[encoded, " 0"];
encoded ¬ Convert.AppendCard[to: encoded, from: serial, base: 16, showRadix: FALSE];
encoded ¬ RefText.AppendChar[encoded, ' ];
encoded ¬ RefText.AppendRope[encoded, interpName];
encoded ¬ RefText.AppendChar[encoded, '|];
encoded ¬ RefText.AppendRope[encoded, command];
encoded ¬ RefText.AppendChar[encoded, 0C];
};
illegalId: CARD32 ~ LAST[CARD32];
GetRemoteListenerId:
PROC [cd:
REF ConnectionData, interpreterName: Rope.
ROPE]
RETURNS [id:
CARD32 ¬ illegalId] = {
ref: SymTab.Ref ¬ cd.remoteInterpreters;
IF ref#
NIL
THEN
WITH SymTab.Fetch[ref, interpreterName].val
SELECT
FROM
rc: REF CARD32 => id ¬ rc;
ENDCASE => {};
};
ReplaceLocal:
PROC [cd:
REF ConnectionData, name: Rope.
ROPE, interp:
REF Interpreter] = {
old: REF Interpreter ¬ NIL;
Action: SymTab.UpdateAction = {
IF interp=
NIL
THEN op ¬ delete
ELSE {op ¬ store; new ¬ interp};
IF found THEN old ¬ NARROW[val];
};
[] ¬ SymTab.Update[cd.ownInterpreters, name, Action];
IF old#NIL THEN ForkOrEnqueue[old.thread, NotifyDeadness, old, NIL];
IF interp#NIL AND interp.refCounting THEN Xl.IncRefCount[cd.connection, interp];
};
RegisterInterpreter:
PUBLIC
PROC [c: Xl.Connection, interpreterName: Rope.
ROPE, listener: ListenerProc
, unregisterNotify: UnregisterNotifyProc ¬
NIL, clientData:
REF ¬
NIL, thread: Xl.
TQ ¬
NIL, overwrite:
BOOL ¬
FALSE, replyOnPing:
BOOL, refCounting:
BOOL]
RETURNS [ok:
BOOL ¬
FALSE] = {
old: REF Interpreter;
windowId: CARD32;
cd: REF ConnectionData ~ GetConnectionData[c];
rips: SymTab.Ref;
IF Rope.SkipTo[s: interpreterName, skip: "|"]<Rope.Length[interpreterName] THEN RETURN [FALSE]; --no "|" character please
IF ~cd.registryCacheOk THEN ReadRegistrations[cd];
rips ¬ cd.remoteInterpreters;
windowId ¬ GetRemoteListenerId[cd, interpreterName];
IF listener=
NIL
THEN {
--remove interpreter
ReplaceLocal[cd, interpreterName, NIL];
IF windowId=illegalId THEN RETURN [TRUE];
IF windowId=LOOPHOLE[cd.listenerWindow] THEN overwrite ¬ TRUE;
IF ~overwrite THEN RETURN [FALSE];
[] ¬ SymTab.Delete[rips, interpreterName];
}
ELSE {
replyCode: TclCode;
interp:
REF Interpreter ~
NEW[Interpreter ¬ [
interpreterName: interpreterName,
clientData: clientData,
cd: cd,
listener: listener,
unregisterNotify: unregisterNotify,
thread: thread,
replyOnPing: replyOnPing,
refCounting: refCounting
]];
IF windowId=Xl.WindowId[cd.listenerWindow]
THEN {
ReplaceLocal[cd, interpreterName, interp];
RETURN [TRUE]
};
IF windowId#illegalId
THEN {
replyCode ¬ SendCommand[cd, windowId, interpreterName, "", 2000].code;
IF replyCode<noInterpreter AND ~overwrite THEN RETURN [FALSE];
--a timeout happened; that is sufficently long so we better refresh our global cache. This aint atomic but only for short time periods.
IF ~cd.registryCacheOk
THEN {
ReadRegistrations[cd];
rips ¬ cd.remoteInterpreters;
};
};
ReplaceLocal[cd, interpreterName, interp];
[] ¬ SymTab.Store[rips, interpreterName, NEW[CARD32 ¬ Xl.WindowId[cd.listenerWindow]]];
};
WriteInterpreters[cd, rips]; --global locking missing also in Tcl
ok ¬ TRUE;
};
SendCommand:
PROC [cd:
REF ConnectionData, windowId:
CARD32, interpreterName: Rope.
ROPE, command: Rope.
ROPE, timeout:
INT ¬ 2000]
RETURNS [code: TclCode, reply: Rope.
ROPE] = {
promise: REF PromiseRec ~ NEW[PromiseRec];
encoded: REF TEXT; serial: CARD32;
[encoded, serial] ¬ BuildCommand[cd, interpreterName, command];
IF timeout>0 THEN [] ¬ CardTab.Store[cd.openReplies, serial, promise];
Xl.ChangeProperty[c: cd.connection, w:
LOOPHOLE[windowId], property: cd.commAtom, type: XlPredefinedAtoms.string, mode: append, data: encoded, details: detailsForSynchronous
! Xl.XError => {
IF timeout>0 THEN [] ¬ CardTab.Delete[cd.openReplies, serial];
code ¬ noInterpreter;
reply ¬ "interpreter window non existing";
RefText.ReleaseScratch[encoded];
GOTO Oops
}
];
IF timeout>0
THEN {
ForkOps.ForkDelayed[ms: timeout, proc: TryTimingOut, data: promise];
WaitForAction[promise];
[] ¬ CardTab.Delete[cd.openReplies, serial];
};
code ¬ promise.code;
reply ¬ promise.response;
RefText.ReleaseScratch[encoded];
EXITS Oops => {};
};
Send:
PUBLIC
PROC [c: Xl.Connection, interpreterName: Rope.
ROPE, command: Rope.
ROPE ¬
NIL, timeout:
INT]
RETURNS [replyCode: TclCode, reply: Rope.
ROPE] = {
windowId: CARD32;
cd: REF ConnectionData ~ GetConnectionData[c];
IF ~cd.registryCacheOk THEN ReadRegistrations[cd];
windowId ¬ GetRemoteListenerId[cd, interpreterName];
IF windowId#illegalId
THEN [replyCode, reply] ¬ SendCommand[cd, windowId, interpreterName, command, timeout]
ELSE {replyCode ¬ noInterpreter; reply ¬ "unknown interpreter"};
};
END.