XlImplSetup.mesa
Copyright Ó 1988, 1989, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights reserved.
Created by Christian Jacobi, April 7, 1988 12:24:42 pm PDT
Michael Plass, November 10, 1987
Christian Jacobi, October 27, 1993 3:00 pm PDT
Willie-s, November 8, 1991 4:00 pm PST
DIRECTORY
Atom, Basics32, Convert, ForkOps, IO, NetworkStream, Process, PropList, Rope, RuntimeError, Xl, XlAccess, XlAuthFriends, XlDetails, XlDispatch, XlEndianPrivate, XlFinalizePrivate, XlPrivate, XlPrivateErrorHandling, XlPrivateResources, XlPrivateSplit, XlPrivateTypes, XlUtils;
XlImplSetup:
CEDAR
MONITOR
LOCKS c USING c: Connection
IMPORTS Atom, Basics32, Convert, ForkOps, IO, NetworkStream, Process, PropList, Rope, RuntimeError, Xl, XlAccess, XlDispatch, XlEndianPrivate, XlFinalizePrivate, XlPrivate, XlPrivateErrorHandling, XlPrivateResources, XlPrivateSplit
EXPORTS Xl, XlAuthFriends, XlDetails, XlPrivate, XlUtils
SHARES IO, XlDispatch, XlPrivate, XlPrivateResources, XlPrivateTypes ~
BEGIN
OPEN Xl, XlEndianPrivate, XlPrivate;
<<Xl.>>ConnectionPrivate: PUBLIC TYPE = XlPrivateTypes.ConnectionPrivateImplRec;
--Types usefull for interpreter usage in LOOPHOLE
MutableScreen: TYPE = REF ScreenRec;
MutableConnectionResponse: TYPE = REF ConnectionResponseInfoRec;
xPortNumber: INT ~ 6000;
debugLastConnection: Connection ¬ NIL; --for debugging
weAreDebugging: BOOL ~ TRUE; --constant! enables eventual compile time code omissions
replyModulusKey: REF CARD32 ~ NEW[CARD32];
authentifier: PUBLIC <<XlAuthFriends>> XlAuthFriends.AuthentifierProc ¬ NIL;
ProduceConnectionNotCreated:
PROC [rejected:
REF ConnectionRejectInfo] = {
SIGNAL connectionNotCreated[rejected];
};
PutConnectionInitialization:
PROC [c: Connection, authorizationProtocolName, authorizationProtocolData:
ROPE ¬
NIL] ~ {
IF c.sequenceNumber#0 THEN ERROR;
SELECT XlEndianPrivate.communicationByteOrder
FROM
msbFirst => DPutBYTE[c, 042H];
lsbFirst => DPutBYTE[c, 06CH];
ENDCASE => ERROR;
DPutBYTE[c, 000H]; -- unused
DPutCARD16[c, 11]; -- protocol-major-version
DPutCARD16[c, 0]; -- protocol-minor-version
DPutCARD16[c, Rope.Size[authorizationProtocolName]]; -- length of ...
DPutCARD16[c, Rope.Size[authorizationProtocolData]]; -- length of ...
DPutCARD16[c, 0]; -- unused
DPutPaddedRope[c, authorizationProtocolName];
DPutPaddedRope[c, authorizationProtocolData];
c.bufSkipped ¬ 0;
IO.Flush[c.xmit];
};
GetBYTE:
PROC [c: Connection]
RETURNS [
BYTE] ~ {
RETURN [XlEndianPrivate.InlineGet8[c]]
};
GetCARD16:
PROC [c: Connection]
RETURNS [
CARD16] ~ {
RETURN [XlEndianPrivate.InlineGet16[c]]
};
GetCARD32:
PROC [c: Connection]
RETURNS [
CARD32] ~ {
RETURN [XlEndianPrivate.InlineGet32[c]]
};
GetFormat:
PROC [c: Connection]
RETURNS [f: Format] ~ {
f.depth ¬ GetBYTE[c];
f.bitsPerPixel ¬ GetBYTE[c];
f.scanlinePad ¬ GetBYTE[c];
[] ¬ GetBYTE[c];
[] ¬ GetCARD32[c];
};
GetFormats:
PROC [c: Connection, n:
INT]
RETURNS [list:
LIST
OF Format ¬
NIL] ~ {
IF n > 0
THEN {
last: LIST OF Format ¬ list ¬ LIST[GetFormat[c]];
FOR i:
INT
IN [1..n)
DO
last ¬ last.rest ¬ LIST[GetFormat[c]];
ENDLOOP;
};
};
ReadScreen:
PROC [c: Connection, i:
INT]
RETURNS [s:
REF ScreenRec] ~ {
s ¬ NEW[Xl.ScreenRec];
s.root ¬ ToWindow[c, GetCARD32[c]];
s.defaultColorMap ¬ [GetCARD32[c]];
s.whitePixel ¬ GetCARD32[c];
s.blackPixel ¬ GetCARD32[c];
s.currentInputMasks ¬ LOOPHOLE[GetCARD32[c]];
s.sizeInPixels ¬ Size[width: GetCARD16[c], height: GetCARD16[c]];
s.sizeInMillimeters ¬ Size[width: GetCARD16[c], height: GetCARD16[c]];
s.minInstalledMaps ¬ GetCARD16[c];
s.maxInstalledMaps ¬ GetCARD16[c];
s.rootVisual ¬ ToVisual[c, GetCARD32[c]];
BEGIN
b: BYTE ¬ GetBYTE[c];
IF b<=2 THEN s.backingStores ¬ VAL[b] ELSE s.backingStores ¬ never;
END;
s.saveUnders ¬ GetBYTE[c];
s.rootDepth ¬ GetBYTE[c];
s.nDepths ¬ GetBYTE[c];
s.connection ¬ c;
s.screenNumber ¬ i;
s.properties ¬ PropList.NewPropList[];
s.screenDepthL ¬ GetDepths[c, s];
};
ReadScreens:
PROC [c: Connection, n:
INT]
RETURNS [s:
REF ScreenSequence] ~ {
s ¬ NEW[ScreenSequence[n]];
FOR i:
INT
IN [0..n)
DO
s[i] ¬ ReadScreen[c, i];
ENDLOOP;
};
CreateScreenDepthS:
PROC [c: Connection]
RETURNS [t:
REF ScreenDepthTuples] = {
t ¬ NEW[ScreenDepthTuples[c.screenDepthTuplesCount]];
FOR sno:
NAT
IN [0..ScreenCount[c])
DO
s: Screen ¬ NthScreen[c, sno];
FOR dl:
LIST
OF
READONLY ScreenDepth ¬ s.screenDepthL, dl.rest
WHILE dl#
NIL
DO
t[dl.first.screenDepthIndex] ¬ dl.first;
ENDLOOP;
ENDLOOP;
};
GetDepth:
PROC [c: Connection, s:
REF ScreenRec]
RETURNS [d:
REF ScreenDepthRec] ~ {
d ¬ NEW[ScreenDepthRec];
d.screenDepthIndex ¬ c.screenDepthTuplesCount;
c.screenDepthTuplesCount ¬ c.screenDepthTuplesCount+1;
d.screen ¬ s;
d.depth ¬ GetBYTE[c];
[] ¬ GetBYTE[c]; --unused
d.nVisualTypes ¬ GetCARD16[c];
[] ¬ GetCARD32[c]; --unused
d.visuals ¬ GetVisualTypes[c, d.nVisualTypes];
d.properties ¬ PropList.NewPropList[];
};
GetDepths:
PROC [c: Connection, s:
REF ScreenRec]
RETURNS [list:
LIST
OF ScreenDepth ¬
NIL] ~ {
IF s.nDepths > 0
THEN {
last: LIST OF ScreenDepth ¬ list ¬ LIST[GetDepth[c, s]];
FOR i:
INT
IN [1..s.nDepths)
DO
last ¬ last.rest ¬ LIST[GetDepth[c, s]];
ENDLOOP;
};
};
GetVisualType:
PROC [c: Connection]
RETURNS [VisualType] ~ {
vt: REF VisualTypeRec ¬ NEW[VisualTypeRec];
vt.visual ¬ [GetCARD32[c]];
vt.class ¬ VAL[GetBYTE[c]];
vt.bitsPerRgbValue ¬ GetBYTE[c];
vt.colorMapEntries ¬ GetCARD16[c];
vt.redMask ¬ GetCARD32[c];
vt.greenMask ¬ GetCARD32[c];
vt.blueMask ¬ GetCARD32[c];
[] ¬ GetCARD32[c]; --unused
vt.properties ¬ PropList.NewPropList[];
RETURN [vt]
};
GetVisualTypes:
PROC [c: Connection, n:
INT]
RETURNS [
LIST
OF VisualType] ~ {
list: LIST OF VisualType ¬ NIL;
IF n > 0
THEN {
last: LIST OF VisualType ¬ list ¬ LIST[GetVisualType[c]];
FOR i:
INT
IN [1..n)
DO
last ¬ last.rest ¬ LIST[GetVisualType[c]];
ENDLOOP;
};
RETURN [list]
};
GetPAD:
PROC [c: Connection, n:
CARD] ~ {
WHILE n
MOD 4 # 0
DO
[] ¬ GetBYTE[c]; n ¬ n + 1;
ENDLOOP;
};
GetSTRING8:
PROC [c: Connection, length:
INT]
RETURNS [rope:
ROPE] ~ {
rope ¬ IO.GetRope[self: c.recv, len: length, demand: TRUE];
};
GetInitialConnectionResponse:
PROC [c: Connection]
RETURNS [success:
BOOL] = {
successByte: BYTE ~ GetBYTE[c];
IF successByte=1
THEN {
vendorLength, maxLength: CARD16; noOfScreens: BYTE;
r: REF ConnectionResponseInfoRec ¬ NEW[ConnectionResponseInfoRec];
[] ¬ GetBYTE[c];--unused
r.protocolMajorVersion ¬ GetCARD16[c];
r.protocolMinorVersion ¬ GetCARD16[c];
[] ¬ GetCARD16[c]; --additionalDataFWORDS
r.releaseNumber ¬ GetCARD32[c];
r.resourceIdBase ¬ GetCARD32[c];
r.resourceIdMask ¬ GetCARD32[c];
r.motionBufferSize ¬ GetCARD32[c];
vendorLength ¬ GetCARD16[c]; -- length of vendor
maxLength ¬ GetCARD16[c];
r.maxRequestLength ¬ maxLength-8;
r.maxRequestLengthBytes ¬ 4*r.maxRequestLength;
noOfScreens ¬ GetBYTE[c];
r.numberOfFORMATs ¬ GetBYTE[c];
r.imageByteOrder ¬ VAL[GetBYTE[c]];
r.bitmapFormatBitOrder ¬ VAL[GetBYTE[c]];
r.bitmapFormatScanlineUnit ¬ GetBYTE[c];
r.bitmapFormatScanlinePad ¬ GetBYTE[c];
r.minKeycode ¬ VAL[GetBYTE[c]];
r.maxKeycode ¬ VAL[GetBYTE[c]];
[] ¬ GetCARD32[c]; --unused
r.vendor ¬ GetSTRING8[c, vendorLength];
GetPAD[c, vendorLength];
r.formats ¬ GetFormats[c, r.numberOfFORMATs];
r.screens ¬ ReadScreens[c, noOfScreens];
c.info ¬ r;
RETURN [TRUE];
}
ELSE {
r: REF ConnectionRejectInfo ¬ NEW[ConnectionRejectInfo];
reasonBytes: BYTE ¬ GetBYTE[c];
additionalDataFWORDS: CARD16;
r.failedBeforeReachingXServer ¬ FALSE;
r.protocolMajorVersion ¬ GetCARD16[c];
r.protocolMinorVersion ¬ GetCARD16[c];
additionalDataFWORDS ¬ GetCARD16[c];
IF (INT[reasonBytes]+3)/4 # INT[additionalDataFWORDS] THEN ERROR;
r.reason ¬ GetSTRING8[c, reasonBytes];
GetPAD[c, reasonBytes];
c.alive ¬ FALSE;
r.reason ¬ Rope.Concat[r.reason, " (refused by X server)"];
ProduceConnectionNotCreated[r];
RETURN [FALSE];
};
};
replyTimeout: Process.Ticks ¬ Process.MsecToTicks[10000];
CloseStream:
PROC [s:
IO.
STREAM] = {
IF s#NIL THEN IO.Close[s, TRUE ! RuntimeError.UNCAUGHT => CONTINUE];
};
ScanedName:
TYPE =
RECORD [
protocolFamily: ATOM,
transportClass: ATOM,
remoteAddress: ROPE,
displayNumber: INT ¬ 0,
defaultScreenNumber: INT ¬ 0,
error: ROPE ¬ NIL
];
ScanName:
PROC [name:
ROPE]
RETURNS [sn: ScanedName] = {
length: INT ¬ Rope.Length[name];
colonPos: INT ¬ Rope.SkipTo[s: name, skip: ":"];
sn.protocolFamily ¬ $ARPA;
sn.transportClass ¬ $TCP;
sn.remoteAddress ¬ XlAccess.AddressFromName[Rope.Substr[name, 0, colonPos]
! XlAccess.AddressFromNameFailed => {sn.error ¬ msg; GOTO oops}
];
IF Rope.IsEmpty[sn.remoteAddress]
THEN
sn.remoteAddress ¬ "127.0.0.1"; --the local host by convention
IF (colonPos+1)<length
THEN {
--there is something after the colon
dotPos: INT ¬ Rope.SkipTo[s: name, pos: colonPos, skip: "."];
lastNumberPos: INT ¬ Rope.SkipOver[s: name, pos: colonPos+1, skip: "0123456789"];
IF lastNumberPos>colonPos+1
THEN {
sn.displayNumber ¬ Convert.IntFromRope[
Rope.Substr[base: name, start: colonPos+1, len: lastNumberPos-colonPos-1]
! Convert.Error => {sn.error ¬ "BadDisplayNumber"; CONTINUE}
];
IF (dotPos+1)<length
THEN {
--there is something after the dot
sn.defaultScreenNumber ¬ Convert.IntFromRope[
Rope.Substr[base: name, start: dotPos+1] ! Convert.Error => CONTINUE
];
};
}
};
EXITS oops => {};
};
ErrorFromStream:
PROC [self:
IO.
STREAM]
RETURNS [msg: Rope.
ROPE] = {
msg ¬ NetworkStream.GetIOErrorDetails[self].msg
};
ErrorDetails:
PROC [codes:
LIST
OF
ATOM]
RETURNS [r: Rope.
ROPE] = {
r ¬ " [details: ";
FOR l:
LIST
OF
ATOM ¬ codes, l.rest
WHILE l#
NIL
DO
r ¬ Rope.Concat[r, Atom.GetPName[l.first]];
IF l.rest#NIL THEN r ¬ Rope.Concat[r, ", "];
ENDLOOP;
r ¬ Rope.Concat[r, "] "];
};
DeadConnection:
PUBLIC
PROC [debugHelp:
REF ¬
NIL]
RETURNS [c: Xl.Connection] = {
c ¬
NEW[ConnectionRep ¬ [xmit:
IO.noWhereStream, recv:
IO.noInputStream, name: "dead",
sendSoon: NIL,
synchCount: 0,
bufProblem: $DeadConnection,
info:
NEW[ConnectionResponseInfoRec ← [
protocolMajorVersion: 0,
protocolMinorVersion: 0,
releaseNumber: 0,
resourceIdBase: 0,
resourceIdMask: 0,
motionBufferSize: 0,
maxRequestLength: 10000,
maxRequestLengthBytes: 10000,
numberOfFORMATs: 0,
imageByteOrder: msbFirst,
bitmapFormatBitOrder: leastSignificant,
bitmapFormatScanlineUnit: 32,
bitmapFormatScanlinePad: 32,
minKeycode: keycode0,
maxKeycode: keycode255,
vendor: NIL,
formats: NIL,
screens: NIL
]],
alive: FALSE,
bufNext: 0,
defaultScreenNumber: 0,
applicationKey: $DeadConnection
]];
c.cPriv ¬
NEW[ConnectionPrivate ¬ [
refRefSelf: NEW[Xl.Connection ¬ NIL]
]];
XlPrivate.RealAssertBuffer[c, 1000];
XlPrivateSplit.StartMainLoop[c];
};
CreateConnection:
PUBLIC
PROC [server:
ROPE ¬
NIL, synchronized:
BOOL ¬
FALSE, applicationKey:
ATOM ¬
NIL, errorMatch: Match ¬
NIL, finalMatch: Match ¬
NIL, debugHelp:
REF ¬
NIL]
RETURNS [Connection ¬
NIL] = {
c: Connection;
success: BOOL;
beforeReachingXServer: BOOL ¬ TRUE;
state: Rope.ROPE ¬ " (Before establishing connection to display)";
Failure:
PROC [r1, r2:
ROPE ¬
NIL] = {
serverPart: ROPE ¬ Rope.Cat[" [server: ", server, "]"];
rejected: REF ConnectionRejectInfo ¬ NEW[ConnectionRejectInfo];
rejected.failedBeforeReachingXServer ¬ beforeReachingXServer;
rejected.reason ¬ Rope.Cat[r1, r2, state, serverPart];
success ¬ FALSE;
ProduceConnectionNotCreated[rejected];
};
TryOnce:
PROC [in, out:
IO.
STREAM]
RETURNS [Xl.Connection ¬
NIL] = {
ENABLE {
IO.Error => {Failure[ErrorFromStream[stream]]; GOTO Oops};
IO.EndOfStream => {Failure["end of stream"]; GOTO Oops};
UNWIND => {
CloseStream[in];
CloseStream[out];
};
};
c: Xl.Connection;
state ¬ " (Stream to display machine created; Trying to send first bytes)";
c ¬
NEW[ConnectionRep ¬ [xmit: out, recv: in, name: server,
sendSoon: NIL,
debugHelp: debugHelp,
errorFromStreamProc: ErrorFromStream,
--for PCedar2.0 only: putChar: out.streamProcs.putChar,
--for PCedar2.0 only: getChar: in.streamProcs.getChar,
synchCount: (IF synchronized THEN 1000 ELSE 0),
alive: TRUE,
bufNext: 0,
defaultScreenNumber: 0, -- set later when we know valid range
applicationKey: applicationKey
]];
c.properties ¬ PropList.NewPropList[];
[] ¬ XlPrivate.AssertBuffer[c, 4000];
BEGIN
generator: XlAuthFriends.AuthentifierProc ¬ authentifier;
method, data: Rope.ROPE ¬ NIL;
IF generator#
NIL
THEN
[method: method, data: data] ¬ generator[family: 0<<internet>>, adress: sn.remoteAddress, display: Convert.RopeFromInt[sn.displayNumber], proposedMethod: NIL];
PutConnectionInitialization[c, method, data];
END;
state ¬ " (Stream to display machine created; Awaiting first response from X server)";
beforeReachingXServer ¬ FALSE;
success ¬ GetInitialConnectionResponse[c];
IF ~success
THEN {
CloseStream[in];
CloseStream[out];
RETURN [NIL]
};
state ¬ " (Initial communication established; Retrieving X server display information)";
IF sn.defaultScreenNumber>=0 AND sn.defaultScreenNumber<ScreenCount[c] THEN c.defaultScreenNumber ¬ sn.defaultScreenNumber;
c.screenDepthS ¬ CreateScreenDepthS[c];
c.cPriv ¬
NEW[ConnectionPrivate ¬ [
refRefSelf: NEW[Xl.Connection ¬ c]
]];
XlPrivateResources.InitPrivateResources[c, Info[c].resourceIdBase, Info[c].resourceIdMask];
XlPrivateSplit.SetupGraphics[c];
debugLastConnection ¬ c;
PutConnectionProp[c, $XlImplOutputStream, c.xmit];
XlPrivateErrorHandling.RegisterErrorMatch[c, errorMatch];
XlDispatch.InitConnection[c];
XlFinalizePrivate.Init[c, finalMatch];
XlPrivateSplit.StartMainLoop[c];
XlPrivateSplit.InitServiceStuff[c];
XlPrivateSplit.InitAtomStuff[c];
BEGIN
Put a resource on a known property to enable CloseConnection to call KillClient
s: Screen ¬ FirstScreen[c];
pixmap: Pixmap ¬ CreatePixmap[c: c, drawable: s.root, size: [1, 1], depth: s.rootDepth];
PutConnectionProp[c, $XlImplSomeResource, NEW[ID ¬ PixmapId[pixmap]]];
END;
Xl.PutConnectionProp[c, replyModulusKey, NEW[CARD32 ¬ 0]];
ForkOps.ForkPeriodically[99, ConnectionPeriodical, c];
RETURN [c]
EXITS Oops => RETURN [NIL];
};
sn: ScanedName;
pStart: INT ¬ Rope.SkipOver[server, 0, " \t\r\l"];--remove leading whitespace
pStop: INT ¬ Rope.SkipTo[server, pStart, "\r\l;"];--restrict to single line
IF pStart>=pStop THEN server ¬ NIL ELSE server ¬ Rope.Substr[server, pStart, pStop-pStart];
IF Rope.IsEmpty[server]
THEN {
server ¬ XlAccess.DefaultServer[applicationKey];
};
sn ¬ ScanName[server];
IF ~Rope.IsEmpty[sn.error]
THEN {
Failure["server name problem : ", sn.error]; ERROR; --proceed won't help
};
DO
--until succeeds and RETURNs, or, until signal is aborted
in, out: IO.STREAM;
state ¬ " (Trying to open streams to display machine but not yet on X level)";
success ¬ TRUE; c ¬ NIL;
[in, out] ¬ NetworkStream.CreateStreams[
protocolFamily: sn.protocolFamily,
remote: IO.PutFR["%g:%g", IO.rope[sn.remoteAddress], IO.int[sn.displayNumber+xPortNumber]],
transportClass: sn.transportClass
! NetworkStream.Error => {Failure[msg, ErrorDetails[codes]]; success ¬ FALSE; CONTINUE};
];
IF success
THEN {
c ¬ TryOnce[in, out];
IF Xl.Alive[c] THEN RETURN [c];
};
ENDLOOP;
};
CloseConnection:
PUBLIC
PROC [c: Connection] = {
Doesn't use connections monitor, just in case of wedges.
Must close stream now because flusher process might be sluggish and we want windows to disappear fast.
IF c#
NIL
THEN {
c.alive ¬ FALSE;
BEGIN
--Extra stuff to implement atomiticity without entering connections monitor
CalledJustOnce: InitializeProcType = {firstTime ¬ TRUE};
firstTime: BOOL ¬ FALSE;
[] ¬ GetConnectionPropAndInit[c, $unique, CalledJustOnce];
IF firstTime THEN ForkOps.Fork[DetachedClose, c];
END;
};
};
DetachedClose:
PROC [data:
REF] = {
--Detached, so bad connection does not wedge others
--Called on foreground priority
ENABLE RuntimeError.UNCAUGHT <<too much of a shame if close fails>> => GOTO oops;
c: Connection ~ NARROW[data];
rid: REF ID ¬ NIL;
xmit: IO.STREAM ¬ c.xmit;
WITH Xl.GetConnectionProp[c, $XlImplOutputStream]
SELECT
FROM
s:
IO.
STREAM => {
xmit ¬ s;
Xl.PutConnectionProp[c, $XlImplOutputStream, NIL];
};
ENDCASE => {};
WITH Xl.GetConnectionProp[c, $XlImplSomeResource]
SELECT
FROM
i:
REF
ID => {
rid ¬ i;
Xl.PutConnectionProp[c, $XlImplSomeResource, NIL];
};
ENDCASE => {};
IF xmit#
NIL
AND xmit#
IO.noWhereStream
THEN {
IF rid#
NIL
AND c.bufNext=0
THEN
TRUSTED {
--KillClient on prepared resource so windows disappear fast
--Not on connection monitor but ok since
--No other transmission happens outside monitor
--We check whether we are at a logical beginning point
--This is entered once only
BInit[c, 113, 0, 2]; --KillClient request
BPut32[c, rid];
IO.UnsafePutBlock[xmit, [base: LOOPHOLE[c.buf], startIndex: 0, count: 8]];
IO.Flush[xmit];
};
c.xmit ¬ IO.noWhereStream;
CloseStream[xmit];
};
CloseStream[c.recv];
EXITS oops => {};
};
DetachedKilling:
PROC [data:
REF] = {
--Detached, so bad connection does not wedge others
--Call this delayed to give a chance for an extra KillConnection request...
c: Connection ~ NARROW[data];
recv: IO.STREAM ¬ c.recv;
c.recv ¬ IO.noInputStream;
WITH Xl.GetConnectionProp[c, $XlImplOutputStream]
SELECT
FROM
xmit:
IO.
STREAM => {
Xl.PutConnectionProp[c, $XlImplOutputStream, NIL];
CloseStream[xmit];
};
ENDCASE => {};
XlPrivateSplit.ReleaseService[c];
XlPrivateSplit.KillReplies[c, FALSE];
--dont bother about c.replyStuff.r[i].replyReceived; there is a time out
XlPrivateResources.MarkDead[c];
IF recv#NIL AND recv#IO.noInputStream THEN CloseStream[recv];
};
ConnectionPeriodical:
PROC [data:
REF] = {
c: Connection ~ NARROW[data];
IF ~Xl.Alive[c]
OR c.bufProblem#
NIL
THEN {
c.alive ¬ FALSE;
ForkOps.Stop[ConnectionPeriodical, data];
ForkOps.ForkDelayed[200, DetachedKilling, c]; --extra delay
RETURN
};
WITH GetConnectionProp[c, replyModulusKey]
SELECT
FROM
ri:
REF
CARD32 => {
IF ri#
LAST[
CARD32]
AND ((
LOOPHOLE[c.sequenceNumber,
CARD32]-ri)
MOD 10000H) > 4000
THEN {
ri ¬ LAST[CARD32];
ForkOps.Fork[EnsureReplyModulus, c];
};
};
ENDCASE => {};
IF c.needFlushing OR c.bufReady#0 THEN Xl.Flush[c, FALSE];
};
EnsureReplyModulus:
PROC [data:
REF] = {
c: Connection ~ NARROW[data];
WITH GetConnectionProp[c, replyModulusKey]
SELECT
FROM
ri:
REF
CARD32 => {
Xl.RoundTrip[c, ignoreErrors];
ri ¬ c.sequenceNumber;
};
ENDCASE => {};
};
CheckReply:
PUBLIC
PROC [r: Reply] = {
IF r=NIL OR r.fix[0]#1 THEN NotAReply[r];
r.next ¬ 1
};
NotAReply:
PROC [r: Reply] = {
ev: REF EventRep.errorNotify ~ XlPrivateErrorHandling.NewErrorEvent[r];
ev.serverGenerated ¬ TRUE;
XlPrivateErrorHandling.RaiseErrorEvent[ev];
};
EventRope:
PUBLIC
PROC [event: Event]
RETURNS [r: Rope.
ROPE] = {
IF event=NIL THEN RETURN ["NIL-Event"];
r ¬ EventCodeRope[event.type];
r ¬ IO.PutFR["%g(%g)", IO.rope[r], IO.int[ORD[event.originalCodeByte]]];
};
EventCodeRope:
PUBLIC
PROC [code: EventCode]
RETURNS [r: Rope.
ROPE] = {
SELECT code
FROM
local => r ¬ "local";
extension => r ¬ "extension";
errorNotify => r ¬ "errorNotify";
keyPress => r ¬ "keyPress";
keyRelease => r ¬ "keyRelease";
buttonPress => r ¬ "buttonPress";
buttonRelease => r ¬ "buttonRelease";
motionNotify => r ¬ "motionNotify";
enterNotify => r ¬ "enterNotify";
leaveNotify => r ¬ "leaveNotify";
focusIn => r ¬ "focusIn";
focusOut => r ¬ "focusOut";
keymapNotify => r ¬ "keymapNotify";
expose => r ¬ "expose";
graphicsExposure => r ¬ "graphicsExposure";
noExposure => r ¬ "noExposure";
visibilityNotify => r ¬ "visibilityNotify";
createNotify => r ¬ "createNotify";
destroyNotify => r ¬ "destroyNotify";
unmapNotify => r ¬ "unmapNotify";
mapNotify => r ¬ "mapNotify";
mapRequest => r ¬ "mapRequest";
reparentNotify => r ¬ "reparentNotify";
configureNotify => r ¬ "configureNotify";
configureRequest => r ¬ "configureRequest";
gravityNotify => r ¬ "gravityNotify";
resizeRequest => r ¬ "resizeRequest";
circulateNotify => r ¬ "circulateNotify";
circulateRequest => r ¬ "circulateRequest";
propertyNotify => r ¬ "propertyNotify";
selectionClear => r ¬ "selectionClear";
selectionRequest => r ¬ "selectionRequest";
selectionNotify => r ¬ "selectionNotify";
colorMapNotify => r ¬ "colorMapNotify";
clientMessage => r ¬ "clientMessage";
mappingNotify => r ¬ "mappingNotify";
tipEvent => r ¬ "tipEvent";
ENDCASE => r ¬ "event";
};
FirstRoot:
PUBLIC
PROC [c: Connection]
RETURNS [w: Window] = {
RETURN [Xl.FirstScreen[c].root]
};
DefaultRoot:
PUBLIC
PROC [c: Connection]
RETURNS [w: Window] = {
RETURN [Xl.DefaultScreen[c].root]
};
LegalEvents:
PUBLIC
PROC [e: SetOfEvent]
RETURNS [SetOfEvent] = {
RETURN [LOOPHOLE[Basics32.BITAND[LOOPHOLE[e], 1FFFFFFH]]]
PointerEvents:
PUBLIC
PROC [e: SetOfEvent]
RETURNS [SetOfEvent] = {
RETURN [LOOPHOLE[Basics32.BITAND[LOOPHOLE[e], 07FFCH]]]
};
DeviceEvents:
PUBLIC
PROC [e: SetOfEvent]
RETURNS [SetOfEvent] = {
RETURN [LOOPHOLE[Basics32.BITAND[LOOPHOLE[e], 0304FH]]]
};
MergeAttributes:
PUBLIC
PROC [win, loose: Attributes]
RETURNS [x: Attributes] = {
x ¬ loose;
IF win.backgroundPixmap#illegalPixmap THEN x.backgroundPixmap ¬ win.backgroundPixmap;
IF win.backgroundPixel#illegalPixel THEN x.backgroundPixel ¬ win.backgroundPixel;
IF win.borderPixmap#illegalPixmap THEN x.borderPixmap ¬ win.borderPixmap;
IF win.borderPixel#illegalPixel THEN x.borderPixel ¬ win.borderPixel;
IF win.bitGravity#illegal THEN x.bitGravity ¬ win.bitGravity;
IF win.winGravity#illegal THEN x.winGravity ¬ win.winGravity;
IF win.backingStore#illegal THEN x.backingStore ¬ win.backingStore;
IF win.backingPlanes#undefinedBackingPlanes THEN x.backingPlanes ¬ win.backingPlanes;
IF win.backingPixel#illegalPixel THEN x.backingPixel ¬ win.backingPixel;
IF win.overrideRedirect#illegal THEN x.overrideRedirect ¬ win.overrideRedirect;
IF win.saveUnder#illegal THEN x.saveUnder ¬ win.saveUnder;
x.eventMask ¬ Xl.ORSetOfEvents[x.eventMask, win.eventMask];
x.doNotPropagateMask ¬ Xl.ORSetOfEvents[x.doNotPropagateMask, win.doNotPropagateMask];
IF win.colorMap#illegalColorMap THEN x.colorMap ¬ win.colorMap;
IF win.cursor#illegalCursor THEN x.cursor ¬ win.cursor;
};
FullCreateEventFilter:
PUBLIC
PROC [eventCodes:
LIST
OF EventCode ¬
NIL, activate: EventCodes ¬
ALL[
FALSE], extensions:
LIST
OF
REF
ANY ¬
NIL]
RETURNS [filter: EventFilter] = {
filter ¬ NEW[EventFilterRec ¬ [activate: activate, activateExtensions: extensions]];
FOR l:
LIST
OF EventCode ¬ eventCodes, l.rest
WHILE l#
NIL
DO
filter.activate[l.first] ¬ TRUE
ENDLOOP
};
CreateEventFilter:
PUBLIC
PROC [c1, c2, c3, c4: EventCode ¬ extension]
RETURNS [filter: EventFilter] = {
filter ¬ NEW[EventFilterRec];
filter.activate[c1] ¬ TRUE;
filter.activate[c2] ¬ TRUE;
filter.activate[c3] ¬ TRUE;
filter.activate[c4] ¬ TRUE;
filter.activate[extension] ¬ FALSE;
};
SetEventCodes:
PUBLIC
PROC [list:
LIST
OF EventCode]
RETURNS [ec: EventCodes ¬
ALL[
FALSE]] = {
FOR l:
LIST
OF EventCode ¬ list, l.rest
WHILE l#
NIL
DO
ec[l.first] ¬ TRUE
ENDLOOP
};
QueryScreen:
PUBLIC
PROC [c: Connection, drawable: Drawable]
RETURNS [Screen] = {
SELECT ScreenCount[c]
FROM
1 => RETURN [FirstScreen[c]];
ENDCASE => {
IF drawable=nullDrawable THEN RETURN [DefaultScreen[c]];
FOR i:
INT
IN [0..ScreenCount[c])
DO
s: Screen ¬ NthScreen[c, i];
IF s.root.drawable=drawable THEN RETURN [s];
ENDLOOP;
BEGIN
--should do caching... use LRUCache
gr: GeometryRec ¬ GetGeometry[c, drawable];
RETURN [QueryScreen[c, gr.root.drawable]];
END;
};
};
QueryScreenDepth:
PUBLIC
PROC [c: Connection, drawable: Drawable]
RETURNS [depth: ScreenDepth] = {
gr: GeometryRec; s: Screen;
IF ScreenCount[c]=1
THEN {
s ¬ FirstScreen[c];
IF s.nDepths=1 THEN RETURN [s.screenDepthL.first];
};
IF drawable=nullDrawable THEN drawable ¬ DefaultRoot[c].drawable;
gr ¬ GetGeometry[c, drawable];
s ¬ QueryScreen[c, gr.root.drawable];
FOR ld:
LIST
OF
READONLY ScreenDepth ¬ s.screenDepthL, ld.rest
WHILE ld#
NIL
DO
IF ld.first.depth=gr.depth THEN RETURN [ld.first];
ENDLOOP;
ERROR;
};
synchronousErrors:
PUBLIC Xl.Details ¬
NEW[Xl.DetailsRec ¬ [synchronous:
TRUE, localErrors: inline]];
ignoreErrors:
PUBLIC Xl.Details ¬
NEW[Xl.DetailsRec ¬ [localErrors: ignore, errorMatch:
NEW[Xl.MatchRep ¬ [proc: IgnoreErrors, handles:
NIL, tq: Xl.CreateTQ[]]]]];
debugErrCount: CARD ¬ 0;
IgnoreErrors: Xl.EventProcType = {debugErrCount ¬ debugErrCount+1};
flushIgnoreErrors: PUBLIC Xl.Details ¬ NEW[Xl.DetailsRec ¬ [flush: now, errorMatch: NEW[Xl.MatchRep ¬ [proc: IgnoreErrors, handles: NIL, tq: Xl.CreateTQ[]]]]];
flushSoonIgnoreErrors: PUBLIC Xl.Details ¬ NEW[Xl.DetailsRec ¬ [flush: soon, errorMatch: NEW[Xl.MatchRep ¬ [proc: IgnoreErrors, handles: NIL, tq: Xl.CreateTQ[]]]]];
END.