
    <<X11MigrationTool.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>>
        <<>>
    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] = {    
        <<--THIS IS HORRIBLE;  I don't know how to atomicly get the application of the buttonRelease >>
        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.