<<>> <> <> <> <> <<>> 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 { 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] = { <> 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 { 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> 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] = { <> 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: "|"]> 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> 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.