DIRECTORY 
Commander, IO, Rope, Xl, XlCursor, XlDetails, XlPredefinedAtoms, XTk, XTkMigration, XTkWidgets, XTkShellWidgets;

X11MigrationTool: CEDAR PROGRAM
IMPORTS Commander, IO, Xl, XlCursor, XlDetails, XTk, XTkMigration, XTkShellWidgets, XTkWidgets ~
BEGIN

MigrationToolInst: TYPE = RECORD [
toolShell: XTk.Widget ¬ NIL,
applicationSelectorButton: XTk.Widget ¬ NIL,
applicationLabel: XTk.Widget ¬ NIL,
applicationWindow: Xl.Window ¬ Xl.nullWindow,
destinationWidget: XTk.Widget ¬ NIL,
wmProtocolsAtom, migrateAtom: Xl.XAtom ¬ [0],
log: IO.STREAM ¬ NIL
];

ClearApplication: PROC [i: REF MigrationToolInst] = {
SetApplication[i, Xl.nullWindow, "-- none selected --"];
};

SetApplication: PROC [i: REF MigrationToolInst, w: Xl.Window, text: Rope.ROPE] = {
XTkWidgets.SetText[i.applicationLabel, text];
i.applicationWindow ¬ w;
};

ApplyMigrate: XTk.WidgetNotifyProc = {
i: REF MigrationToolInst ¬ NARROW[registerData];
applicationShellWindow: Xl.Window ¬ i.applicationWindow;
time: Xl.TimeStamp ¬ Xl.currentTime;
parameters: ARRAY[0..5) OF CARD32 ¬ [0, 0, 0, 0, 0];
destinationConnection: Xl.Connection;
destinationName: Rope.ROPE;
specialMode: BOOL ¬ FALSE;
commandAtom: Xl.XAtom ¬ i.migrateAtom;
IF applicationShellWindow=Xl.nullWindow THEN {
IO.PutRope[i.log, "Select an application first\n"];
GOTO oops;
};
IF ~VerifyApplication[i, applicationShellWindow] THEN {
IO.PutRope[i.log, "Application is no more valid\n"];
ClearApplication[i];
GOTO oops;
};
WITH event SELECT FROM
br: Xl.ButtonReleaseEvent => IF br.state.control THEN specialMode ¬ TRUE;
ENDCASE => {};
destinationName ¬ XTkWidgets.GetText[i.destinationWidget];
IF specialMode 
THEN {
commandAtom ¬ Xl.MakeAtom[i.toolShell.connection, "PARC_Migration_Owner"];
}
ELSE {
destinationConnection ¬ Xl.CreateConnection[server: destinationName ! Xl.connectionNotCreated => {
IO.PutRope[i.log, why.reason];
GOTO oops
}];
Xl.CloseConnection[destinationConnection];
};
Xl.ChangeProperty[c: i.toolShell.connection, w: i.destinationWidget.window, property: i.migrateAtom, type: i.migrateAtom, data: destinationName];
parameters[0] ¬ Xl.AtomId[commandAtom]; --command
parameters[1] ¬ time.t; 
parameters[2] ¬ Xl.WindowId[i.destinationWidget.window]; --window for property
parameters[3] ¬ Xl.AtomId[i.migrateAtom]; --property for destination
Xl.SendClientMessage32[c: i.toolShell.connection, destination: applicationShellWindow, window: applicationShellWindow, propagate: FALSE, eventMask: Xl.unspecifiedEvents, type: i.wmProtocolsAtom, data: parameters, details: XlDetails.ignoreErrors];
IF specialMode
THEN IO.PutRope[i.log, "whistle trained...\n"]
ELSE IO.PutRope[i.log, "migration request sent...\n"];
ClearApplication[i];
EXITS oops => {};
};

AppSelectDown: Xl.EventProcType = {
i: REF MigrationToolInst ~ NARROW[clientData];
ev: Xl.ButtonPressEvent ~ NARROW[event];
c: Xl.Connection ~ ev.connection;
IF Xl.SetButtonGrabOwner[c, ev.timeStamp, i]=succeeded THEN {
s: Xl.GrabStatus;
cursor: Xl.Cursor ¬ XlCursor.SharedStandardCursor[c, sailboat];
s ¬ Xl.GrabPointer[c: c, window: ev.eventWindow, ownerEvents: FALSE, eventMask: [buttonRelease: TRUE], pointerMode: asynchronous, keyboardMode: asynchronous, confine: Xl.nullWindow, cursor: cursor, timeStamp: ev.timeStamp];
IF s=success 
THEN {
XTkWidgets.SetStyleKey[i.applicationSelectorButton, $WhiteOnBlack];
}
ELSE {
XTkWidgets.SetStyleKey[i.applicationSelectorButton, NIL];
Xl.ClearButtonGrabOwner[c, ev.timeStamp];
};
}
};

AppSelectUp: Xl.EventProcType = {
i: REF MigrationToolInst ~ NARROW[clientData];
ev: Xl.ButtonReleaseEvent ~ NARROW[event];
Xl.UngrabPointer[ev.connection, ev.timeStamp];
IF i=Xl.ButtonGrabOwner[ev.connection] THEN {
Xl.ClearButtonGrabOwner[ev.connection, ev.timeStamp];
XTkWidgets.SetStyleKey[i.applicationSelectorButton, NIL];
FindApplication[i, ev];
}
};

FindApplication: PROC [i: REF MigrationToolInst, ev: Xl.ButtonReleaseEvent] = {	
name: Rope.ROPE ¬ NIL;
error, foundGood, foundBad: BOOL ¬ FALSE;
pointerReply: Xl.PointerReply;
propertyRec1, propertyRec2: Xl.PropertyReturnRec;
parent: Xl.Window ¬ ev.root;
WHILE parent#Xl.nullWindow AND ~foundGood AND ~error AND ~foundBad DO
pointerReply ¬ Xl.QueryPointer[ev.connection, parent];
IF pointerReply.child#Xl.nullWindow THEN {
propertyRec1 ¬ Xl.GetProperty[c: ev.connection, w: pointerReply.child, property: i.wmProtocolsAtom ! Xl.XError => {error ¬ TRUE; CONTINUE}];
IF error THEN EXIT;
WITH propertyRec1.value SELECT FROM
list: REF Xl.Card32Sequence => {
FOR n: NAT IN [0..list.leng) DO
IF list[n]=Xl.AtomId[i.migrateAtom] THEN {foundGood ¬ TRUE; EXIT};
ENDLOOP;
IF ~foundGood THEN foundBad ¬ TRUE;
};
ENDCASE => {
IF propertyRec1.value#NIL THEN foundBad ¬ TRUE
}; 
propertyRec2 ¬ Xl.GetProperty[c: ev.connection, w: pointerReply.child, property: XlPredefinedAtoms.wmName ! Xl.XError => {error ¬ TRUE; CONTINUE}];
IF ~error THEN {
WITH propertyRec2.value SELECT FROM
r: Rope.ROPE => name ¬ r;
ENDCASE => {};
};
IF foundGood THEN EXIT;
IF name#NIL THEN {foundBad ¬ TRUE; EXIT};
propertyRec1 ¬ Xl.GetProperty[c: ev.connection, w: pointerReply.child, property: XlPredefinedAtoms.wmHints ! Xl.XError => {error ¬ TRUE; CONTINUE}];
IF error THEN EXIT;
IF propertyRec1.value#NIL THEN {foundBad ¬ TRUE; EXIT}; 
propertyRec1 ¬ Xl.GetProperty[c: ev.connection, w: pointerReply.child, property: XlPredefinedAtoms.wmNormalHints ! Xl.XError => {error ¬ TRUE; CONTINUE}];
IF error THEN EXIT;
IF propertyRec1.value#NIL THEN {foundBad ¬ TRUE; EXIT}; 
};
parent ¬ pointerReply.child
ENDLOOP;
IF error THEN {
IO.PutF1[i.log, "error while trying to find top level application %g\n", IO.rope[name]];
RETURN;
};
IF foundBad THEN {
IO.PutF1[i.log, "%g does not support migration\n", IO.rope[name]];
RETURN;
};
IF ~foundGood THEN {
IO.PutF1[i.log, "no top level application window found %g\n", IO.rope[name]];
RETURN;
};
IO.PutF[i.log, "selected [%g] %g\n", IO.card[pointerReply.child.drawable.id], IO.rope[name]];
SetApplication[i, pointerReply.child, IO.PutFR["%g [%g]", IO.rope[name], IO.card[pointerReply.child.drawable.id]]];
};

VerifyApplication: PROC [i: REF MigrationToolInst, applicationWindow: Xl.Window] RETURNS [ok: BOOL ¬ FALSE] = {
c: Xl.Connection ¬ i.toolShell.connection;
propertyRec: Xl.PropertyReturnRec;
error: BOOL ¬ FALSE;
IF Xl.Alive[c] THEN {
propertyRec ¬ Xl.GetProperty[c: c, w: applicationWindow, property: i.wmProtocolsAtom ! Xl.XError => {error ¬ TRUE; CONTINUE}];
IF ~error AND propertyRec.value#NIL THEN {
WITH propertyRec.value SELECT FROM
list: REF Xl.Card32Sequence => {
FOR n: NAT IN [0..list.leng) DO
IF list[n]=Xl.AtomId[i.migrateAtom] THEN RETURN [ok ¬ TRUE];
ENDLOOP;
};
ENDCASE => {}; 
};
};
};

InitSomeFields: PROC [i: REF MigrationToolInst] = {
c: Xl.Connection ¬ i.destinationWidget.connection;
XTkWidgets.SetText[i.destinationWidget, Xl.ServerName[c]];
i.wmProtocolsAtom ¬ Xl.MakeAtom[c, "WM_PROTOCOLS"];
i.migrateAtom ¬ Xl.MakeAtom[c, "PARC_Migration"];
};

CreateMigrationToolWidget: PROC [connection: REF ¬ NIL] ~ {
i: REF MigrationToolInst ¬ NEW[MigrationToolInst];
container: XTk.Widget ¬ XTkWidgets.CreateYStack[];
appTQ: Xl.TQ ¬ Xl.CreateTQ[];
doButton: XTk.Widget ¬ XTkWidgets.CreateButton[[], "Do migrate", [], ApplyMigrate, i];
appButton: XTk.Widget ¬ i.applicationSelectorButton ¬ XTkWidgets.CreateLabel[text: "Select application"];
appLabel: XTk.Widget ¬ i.applicationLabel ¬ XTkWidgets.CreateLabel[text: "-- none selected --"];
logWidget: XTk.Widget ¬ XTkWidgets.CreateStreamWidget[widgetSpec: [geometry: [size: [300, 100]]]];
i.toolShell ¬ XTkShellWidgets.CreateShell[windowHeader: "Migration Tool", packageName: "X11", shortName: "X11MigrationTool"];
i.destinationWidget ¬ XTkWidgets.CreateLabeledField[label: "destination:", init: "..."];
i.log ¬ XTkWidgets.CreateStream[logWidget];
XTk.AddPermanentMatch[
appButton, 
[proc: AppSelectUp, handles: Xl.CreateEventFilter[buttonRelease], tq: appTQ, data: i], 
[buttonRelease: TRUE]
];
XTk.AddPermanentMatch[appButton, [proc: AppSelectDown, handles: Xl.CreateEventFilter[buttonPress], tq: appTQ, data: i], [buttonPress: TRUE]];
XTkWidgets.SetShellChild[i.toolShell, container];
XTkWidgets.AppendChild[container, doButton];
XTkWidgets.AppendChild[container, appButton];
XTkWidgets.AppendChild[container, appLabel];
XTkWidgets.AppendChild[container, i.destinationWidget];
XTkWidgets.AppendChild[container, XTkWidgets.CreateRuler[widgetSpec: [geometry: [size: [-1, 1]]]]];
XTkWidgets.AppendChild[container, logWidget];
XTk.PutWidgetProp[i.toolShell, $MigrationTool, i];
XTkMigration.RegisterMigrator[i.toolShell, MigrateSelf];
XTkWidgets.BindScreenShell[shell: i.toolShell, connection: connection];
InitSomeFields[i];
XTkWidgets.RealizeShell[shell: i.toolShell];
};

CreateMigrationTool: Commander.CommandProc ~ {
CreateMigrationToolWidget[]
};

MigrateSelf: XTkMigration.MigrationProc = {
log: IO.STREAM ¬ IO.noWhereStream;
WITH XTk.GetWidgetProp[shell, $MigrationTool] SELECT FROM
i: REF MigrationToolInst => log ¬ i.log;
ENDCASE => {};
CreateMigrationToolWidget[destination];
IO.PutF1[log, "New MigrationTool on server %g created\n", IO.rope[Xl.ServerName[destination]]];
};

Commander.Register["X11MigrationTool", CreateMigrationTool, "Create window migration tool"];
END.


LX11MigrationTool.mesa
Copyright Σ 1991, 1992, 1993 by Xerox Corporation.  All rights reserved.
Created by Christian Jacobi, August 5, 1991 7:19 pm PDT
Christian Jacobi, May 4, 1993 3:47 pm PDT
Willie-s, November 25, 1991 4:48 pm PST

--THIS IS HORRIBLE;  I don't know how to atomicly get the application of the buttonRelease 
Κ	=•NewlineDelimiter

–
(cedarcode) style˜
codeš
œ™Kšœ
Οe
œ=™HK™7K™)K™'K™—šΟk	œ
˜
K˜pK˜—šΟnœžœ
ž˜KšžœY˜`—Kš
ž˜K˜šœžœžœ˜"Kšœžœ
˜Kšœ(žœ
˜,Kšœžœ
˜#Kš
œ-˜-Kšœ žœ
˜$Kš
œ-˜-Kšœžœ
žœž˜Kš
œ˜K˜—šŸœžœžœ˜5Kš
œ8˜8K˜—K˜šŸœžœžœ-žœ˜RKš
œ-˜-Kš
œ˜K˜—K˜šŸœ˜&Kšœžœžœ˜0Kš
œ8˜8Kš
œ$˜$Kšœžœžœ
žœ˜4Kš
œ%˜%Kšœžœ
˜Kšœ
žœ
žœ
˜Kš
œ&˜&šžœ&žœ˜.Kšžœ1˜3Kšžœ˜
K˜—šžœ/žœ˜7Kšžœ2˜4Kš
œ˜Kšžœ˜
K˜—šžœžœ
ž˜Kšœžœžœžœ
˜IKšžœ˜—Kš
œ:˜:šžœ
˜šžœ˜Kš
œJ˜JK˜
—šžœ˜š
œb˜bKšžœ˜Kšžœ˜	Kš
œ˜—Kš
œ*˜*K˜——Kš
œ‘
˜‘
Kšœ(Οc	˜1Kš
œ˜Kšœ9 ˜NKšœ* ˜DKšœ‚
žœo˜φ
šžœ˜Kšžœ
žœ'˜.Kšžœ
žœ/˜6—Kš
œ˜Kšžœ˜Kš
œ˜K˜—šŸ
œ˜#Kšœžœžœ
˜.Kšœžœ˜(Kš
œ!˜!šžœ5žœ˜=Kš
œ˜Kš
œ?˜?Kšœ>žœžœ{˜ί
šžœ˜
šžœ˜Kš
œC˜CK˜
—šžœ˜Kšœ4žœ˜9Kš
œ)˜)Kš
œ˜——K˜
—K˜K˜—šŸœ˜!Kšœžœžœ
˜.Kšœžœ˜*Kš
œ.˜.šžœ%žœ˜-Kš
œ5˜5Kšœ4žœ˜9Kš
œ˜Kš
œ
˜
—K˜—K˜šŸœžœžœ3˜PK™[Kšœžœžœ
˜Kšœžœžœ
˜)Kš
œ˜Kš
œ1˜1Kš
œ˜š	žœžœžœžœž˜EKš
œ6˜6šžœ"žœ˜*Kšœ{žœžœ˜Œ
Kšžœžœ
žœ
˜šžœžœ
ž˜#šœžœ˜ šžœžœ
žœž˜Kšžœ"žœžœžœ˜BKšžœ
˜—Kšžœžœžœ
˜#Kš
œ˜—šžœ˜Kšžœžœ
žœž˜.Kš
œ˜——Kšœ‚
žœžœ˜“
šžœžœ˜šžœžœ
ž˜#Kšœžœ
˜Kšžœ˜—Kš
œ˜—Kšžœžœ
žœ
˜Kš
žœžœ
žœ
žœžœ˜)Kšœƒ
žœžœ˜”
Kšžœžœ
žœ
˜Kš
žœžœ
žœ
žœžœ˜8Kšœ‰
žœžœ˜š
Kšžœžœ
žœ
˜Kš
žœžœ
žœ
žœžœ˜8K˜—Kš
œ˜Kšžœ
˜—šžœžœ˜KšžœGžœ
˜XKšžœ
˜K˜—šžœ
žœ˜Kšžœ1žœ
˜BKšžœ
˜K˜—šžœžœ˜Kšžœ<žœ
˜MKšžœ
˜K˜—Kšžœ#žœ'žœ
˜]Kšœ&žœžœ
žœ(˜sKš
œ˜—K˜šŸœžœžœ2žœžœžœ˜oKš
œ*˜*Kš
œ"˜"Kšœžœžœ
˜šžœ
žœ˜Kšœmžœžœ˜~šžœžœžœ
žœ˜*šžœžœ
ž˜"šœžœ˜ šžœžœ
žœž˜Kšžœ"žœ
žœžœ˜<Kšžœ
˜—Kš
œ˜—Kšžœ˜—K˜—K˜—K˜K˜—šŸœžœžœ˜3Kš
œ2˜2Kš
œ:˜:Kš
œ3˜3Kš
œ1˜1K˜K˜—šŸœžœžœžœ˜;Kšœžœžœ˜2Kš
œ2˜2Kšœ
žœ˜Kš
œV˜VKš
œi˜iKš
œ`˜`Kš
œb˜bKš
œ}˜}Kš
œX˜XKš
œ+˜+š
œ˜Kš
œ˜Kš
œW˜WKšœžœ
˜Kš
œ˜—Kšœ†
žœ˜
Kš
œ1˜1Kš
œ,˜,Kš
œ-˜-Kš
œ,˜,Kš
œ7˜7Kš
œc˜cKš
œ-˜-Kš
œ2˜2Kš
œ8˜8Kš
œG˜GKš
œ˜Kš
œ,˜,K˜—K˜šŸœ˜.Kš
œ˜K˜—K˜šŸœ ˜+Kšœžœ
žœžœ˜"šžœ*žœ
ž˜9Kšœžœ"˜(Kšžœ˜—K˜'Kšžœ8žœ#˜_Kš
œ˜—K˜Kš
œ\˜\Kšžœ
˜K˜—…—#ΐ.I