Carousel Volume 2 #1/carousel.iso/mactosh/da/clipmagi.sit/testmagic.p

Text File | 1989-06-01 | 8KB | 368 lines

program main;
    uses
        UConvertor;
    type
        PLongint = ^Longint;
        PResType = ^ResType;
        EightChar = packed array[1..8] of char;
    var
        myList: ListHandle;
        aString: str255;
        i: integer;
        appleMenu, fileMenu, editMenu: menuHandle;
        quit: boolean;
        theWindow: windowPtr;

    function GoExec (rInfoPtr: routineInfoPtr; pInfoPtr: parmInfoPtr; excAddr: Ptr): OSErr;
    inline
        $205F, $4e90;{ move.l (A7)+, A0;  jsr (A0)}

    procedure NumToHex (aLong: longint; var aEightChar: EightChar);
        var
            i, digit: integer;
    begin
        for i := 8 downto 3 do
            begin
                digit := BAnd(aLong, 15);
                if digit < 10 then
                    aEightChar[i] := chr(ord('0') + digit)
                else
                    aEightChar[i] := chr(ord('A') + digit - 10);
                aLong := BSR(aLong, 4);
            end;
        aEightChar[1] := ' ';
        aEightChar[2] := ' ';
    end;

    procedure GetSelected (var theType: ResType; var theHandle: Handle);
        var
            curCell: point;
            tempBuf: packed array[1..12] of char;
            v, i: integer;
            theValue: longint;
            dataLen: integer;
            aChar: char;
    begin
        theValue := 0;
        setPt(curCell, 0, 0);
        if LGetSelect(TRUE, curCell, myList) then
            begin
                dataLen := 4;
                LGetCell(@theType, dataLen, curCell, myList);
                dataLen := 12;
                LGetCell(@tempBuf, dataLen, curCell, myList);
                for i := 1 to 6 do
                    begin
                        aChar := tempBuf[i + 6];
                        if aChar > '9' then
                            v := ord(aChar) - ord('A') + 10
                        else
                            v := ord(aChar) - ord('0');
                        theValue := theValue * 16 + v;
                    end;
            end;
        theHandle := Handle(theValue);
    end;

    procedure CopySelected;
        var
            ahandle: Handle;
            aType: ResType;
            dummy: integer;
    begin
        GetSelected(aType, aHandle);
        if aHandle <> nil then
            begin
                dummy := ZeroScrap;
                HLock(aHandle);
                dummy := PutScrap(GetHandleSize(aHandle), aType, aHandle^);
                HUnLock(aHandle);
            end;
    end;

    procedure CutSelected;
        var
            curCell: point;
            aHandle: Handle;
            aType: ResType;
    begin
        setPt(curCell, 0, 0);
        if LGetSelect(TRUE, curCell, myList) then
            begin
                GetSelected(aType, aHandle);
                if aHandle <> nil then
                    begin
                        CopySelected;
                        DisposHandle(aHandle);
                    end;
                LDelRow(1, curCell.v, myList);
            end;
    end;

    procedure AddToList (theType: ResType; theHandle: Handle);
        var
            aEightChar: EightChar;
            theCell: point;
            theRow: integer;
    begin
        NumToHex(ord(theHandle), aEightChar);
        theRow := LAddRow(1, myList^^.dataBounds.bottom, myList);
        SetPt(theCell, 0, theRow);
        LSetCell(@theType, 4, theCell, myList);
        LAddToCell(@aEightChar, 8, theCell, myList);
    end;

    procedure PasteScrap;
        var
            disp: longint;
            theSize: longint;
            dummy: longint;
            theType: ResType;
            scrapPtr: PScrapStuff;
            err: OSErr;
            aHandle: Handle;
    begin
        scrapPtr := InfoScrap;
        with scrapPtr^ do
            begin
                dummy := LoadScrap;
                disp := 0;
                while disp < scrapSize do
                    begin
                        theType := PResType(ord(scrapHandle^) + disp)^;
                        disp := disp + 4;
                        theSize := PLongint(ord(scrapHandle^) + disp)^;
                        disp := disp + 4;
                        HLock(scrapHandle);
                        if PtrToHand(Ptr(ord(scrapHandle^) + disp), aHandle, theSize) = NoErr then
                            AddToList(theType, aHandle);
                        HUnLock(scrapHandle);
                        disp := disp + theSize;
                        if odd(disp) then
                            disp := disp + 1;
                    end;
            end;
    end;

    function CallByName (rtnRsrc: ResType; rtnName: str255; theParCount: integer; usingDefault: boolean; aParmPtr: parmInfoPtr): OSErr;
        var
            flag: SignedByte;
            rtnInfo: routineInfo;
            resHandle: handle;
    begin
        resHandle := Get1NamedResource(rtnRsrc, rtnName);
        if resHandle <> nil then
            begin
                if rtnRsrc = 'CNVT' then
                    aParmPtr^.dstHandle := nil;
                GetResInfo(resHandle, rtnInfo.resID, rtnRsrc, rtnName);
                with rtnInfo do
                    begin
                        entryPoint := @CallByName;
                        parmCount := theParCount;
                        useDefault := usingDefault;
                    end;
                MoveHHi(resHandle);
                flag := HGetState(resHandle);
                HLock(resHandle);
                CallByName := GoExec(@rtnInfo, aParmPtr, resHandle^);
                HSetState(resHandle, flag);
            end
        else
            CallByName := ResError;
    end;

    procedure DoSelected;
        var
            aRoutineInfo: routineInfo;
            aParmInfo: parmInfo;
            aType: ResType;
            aHandle: Handle;
            aPtr: Ptr;
            dataLen: longint;
            dataEnd: longint;
    begin
        GetSelected(aType, aHandle);
        if (testType = '****') or (testType = '____') or (testType = aType) then
            if (aHandle <> nil) or (testType = '____') then
                begin
                    with aRoutineInfo do
                        begin
                            entryPoint := @CallByName;
                            resID := testID;
                            parmCount := 4;
                            useDefault := true;
                        end;
                    with aParmInfo do
                        begin
                            srcType := aType;
                            srcHandle := aHandle;
                            dstHandle := nil;
                        end;
                    if xMain(@aRoutineInfo, @aParmInfo) = NoErr then
                        if aParmInfo.dstHandle <> nil then
                            with aParmInfo do
                                begin
                                    if dstType <> 'scrp' then
                                        AddToList(dstType, dstHandle)
                                    else
                                        begin
                                            HLock(dstHandle);
                                            aPtr := dstHandle^;
                                            dataEnd := ord(aPtr) + GetHandleSize(dstHandle);
                                            while ord(aPtr) < dataEnd do
                                                begin
                                                    aType := PResType(aPtr)^;
                                                    aPtr := Ptr(ord(aPtr) + 4);
                                                    dataLen := PLongint(aPtr)^;
                                                    aPtr := Ptr(ord(aPtr) + 4);
                                                    if PtrToHand(aPtr, aHandle, dataLen) = NoErr then
                                                        AddToList(aType, aHandle);
                                                    if odd(dataLen) then
                                                        dataLen := dataLen + 1;
                                                    aPtr := Ptr(ord(aPtr) + dataLen);
                                                end;
                                            HUnLock(dstHandle);
                                            DisposHandle(dstHandle);
                                        end;
                                end;
                end;
    end;

    procedure Initalize;
        var
            aString: str255;
            r, bounds: rect;
            cSize: point;
    begin
        aString := ' ';
        aString[1] := chr(appleMark);
        appleMenu := NewMenu(1, aString);
        AddResMenu(appleMenu, 'DRVR');
        aString := 'File';
        fileMenu := NewMenu(2, aString);
        AppendMenu(fileMenu, 'Test/T;-;Quit/Q');
        aString := 'Edit';
        editMenu := NewMenu(3, aString);
        AppendMenu(editMenu, 'Cut/X;Copy/C;Paste/V');
        InsertMenu(appleMenu, 0);
        InsertMenu(fileMenu, 0);
        InsertMenu(editMenu, 0);
        DrawMenuBar;
        quit := false;
        InitCursor;
        SetRect(r, 20, 50, 140, 180);
        theWindow := NewWindow(nil, r, '', true, 2, Pointer(-1), false, 0);
        SetPort(theWindow);
        OffsetRect(r, -20, -50);
        InsetRect(r, 1, 1);
        r.right := r.right - 15;
        SetRect(bounds, 0, 0, 1, 0);
        SetPt(cSize, r.right - r.left, 16);
        myList := LNew(r, bounds, cSize, 0, theWindow, true, false, false, true);
        with myList^^ do
            begin
                selFlags := lOnlyOne;
                listFlags := lDoVAutoScroll;
            end;
        PasteScrap;
    end;

    procedure DoMenu (result: longint);
        var
            menu, item: integer;
    begin
        menu := HiWord(result);
        item := LoWord(result);
        case menu of
            1:
                begin
                    GetItem(appleMenu, item, aString);
                    i := OpenDeskAcc(aString);
                end;
            2:
                begin
                    case item of
                        1:
                            DoSelected;
                        3:
                            quit := true;
                    end;
                end;
            3:
                begin
                    case item of
                        1:
                            CutSelected;
                        2:
                            CopySelected;
                        3:
                            PasteScrap;
                    end
                end;
        end;
        HiliteMenu(0);
    end;

    procedure MainEventLoop;
        var
            event: EventRecord;
            aWindow: windowPtr;
            locPt: point;
            part: integer;
            i: integer;
    begin
        SystemTask;
        if GetNextEvent(everyEvent, event) then
            ;
        case event.what of
            activateEvt:
                if WindowPtr(event.message) = theWindow then
                    begin
                        LActivate(odd(event.modifiers), myList);
                    end;

            mouseDown:
                begin
                    part := FindWindow(event.where, aWIndow);
                    case part of
                        inDesk:
                            ;
                        inSysWindow:
                            SystemClick(event, aWindow);
                        inMenuBar:
                            begin
                                DoMenu(MenuSelect(event.where));
                            end;
                        inContent:
                            if FrontWindow <> theWindow then
                                SelectWindow(theWindow)
                            else
                                begin
                                    locPt := event.where;
                                    GlobalToLocal(locPt);
                                    if LClick(locPt, event.modifiers, myList) then
                                        DoSelected;
                                end;
                    end;
                end;

            keyDown:
                if BitAnd(event.modifiers, CmdKey) <> 0 then
                    DoMenu(MenuKey(Chr(BitAnd(event.message, CharCodeMask))));

            updateEvt:
                begin
                    BeginUpdate(theWindow);
                    LUpdate(theWindow^.VisRgn, myList);
                    EndUpdate(theWindow);
                end;
        end;
    end;
begin
    Initalize;
    repeat
        MainEventLoop;
    until quit;
    LDispose(myList);
end.