Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Peter Lewis/PNL Libraries/MyUtils.p

Text File | 1994-09-08 | 8.1 KB | 377 lines | [TEXT/PJMM]

unit MyUtils;

interface

    uses
{$IFC undefined THINK_Pascal}
        Events,
 {$ENDC}
        MyTypes;

    function TrapAvailable (tNumber: INTEGER): BOOLEAN;
    function MyNumToString (n: longInt): str255;
    function NumToStr (n: longInt): str255;
    function NN (n: longInt; len: integer): str31;
    function N2 (n: longInt): str31;
    function StrToNum (s: str255): longInt;
    procedure DotDotDot (var s: str255; var width: integer);
    function MyFrontWindow: boolean;
    function DAFrontWindow: boolean;
    function GetIndStrSize (size, id, index: integer): str255;
    function GetDirID (wdrn: integer; var vrn: integer; var dirID: longInt): OSErr;
    function GetVolInfo (var name: str63; var vrn: integer; index: integer; var CrDate: longInt): OSErr;
    procedure PlotSICN (id, index, v, h: integer);
    function LookupStrh (id: integer; match: str255): str255;
    function LookupStrhNumber (id: integer; n: longInt): str255;
    procedure BlockZero (p: ptr; len: longInt);
    procedure BlockFill (p: univ ptr; len: longInt; value: integer);
    function CheckCancel: boolean;
    procedure TrashHandle (h: handle);
    function WindowInWindowList (w: windowPtr): boolean;
    function DirtyKey (ch: char): boolean;
    function SendCharToIsDialogEvent (var er: EventRecord; cs: charSet): boolean;
    procedure HiliteInvertRect (r: rect);

    procedure FixScrap;
    procedure HaveResources;

implementation

    uses
{$IFC undefined THINK_Pascal}
        Desk, Scrap, Packages, Windows, ToolUtils, Resources, Memory,
  {$ENDC}
        Folders, Traps, MyStrings;

    function TrapAvailable (tNumber: INTEGER): BOOLEAN;
{Check to see if a given trap is implemented. Babble as taken from IM6 }
        const
            TrapMask = $0800;
        var
            tType: TrapType;
    begin
        if BAND(tNumber, TrapMask) > 0 then begin
            tType := ToolTrap;
        end
        else begin
            tType := OSTrap;
        end;
        if tType = ToolTrap then begin
            tNumber := BAND(tNumber, $7FF);
            if tNumber >= $400 then begin
                tNumber := _Unimplemented;
            end
            else if tNumber >= 512 then begin { 512 = $200, but that tickles a MW compiler bug }
                if NGetTrapAddress($A86E, ToolTrap) <> NGetTrapAddress($AA6E, ToolTrap) then begin
                    tNumber := _Unimplemented;
                end;
            end;
        end;
        TrapAvailable := NGetTrapAddress(tNumber, tType) <> GetTrapAddress(_Unimplemented);
    end; {TrapAvailable}

    function MyNumToString (n: longInt): str255;
        var
            s: str255;
    begin
        if abs(n) < 4096 then
            NumToString(n, s)
        else if abs(n) < 4194304 then begin
            NumToString(n div 1024, s);
            s := Concat(s, 'k');
        end
        else begin
            NumToString(n div 1048576, s);
            s := Concat(s, 'M');
        end;
        MyNumToString := s;
    end;

    function NumToStr (n: longInt): str255;
        var
            s: str255;
    begin
        NumToString(n, s);
        NumToStr := s;
    end;

    function NN (n: longInt; len: integer): str31;
        var
            s: str31;
    begin
        s := NumToStr(n);
        while length(s) < len do
            s := concat('0', s);
        NN := s;
    end;

    function N2 (n: longInt): str31;
    begin
        N2 := NN(n, 2);
    end;

    function StrToNum (s: str255): longInt;
        var
            n: longInt;
    begin
        StringToNum(s, n);
        StrToNum := n;
    end;

    procedure DotDotDot (var s: str255; var width: integer);
        var
            maxwidth, len: integer;
    begin
        maxwidth := width;
        width := StringWidth(s);
        if width > maxwidth then begin
            width := width + CharWidth('…');
{$PUSH}
{$R-}
            len := ord(s[0]);
            while (len > 0) and (width > maxwidth) do begin
                width := width - CharWidth(s[len]);
                len := len - 1;
            end;
            len := len + 1;
            s[0] := chr(len);
            s[len] := '…';
{$POP}
        end;
    end;

    function MyFrontWindow: boolean;
        var
            wp: windowPtr;
    begin
        wp := FrontWindow;
        if wp = nil then
            MyFrontWindow := false
        else
            MyFrontWindow := windowPeek(wp)^.windowKind >= userKind;
    end;

    function DAFrontWindow: boolean;
        var
            wp: windowPtr;
    begin
        wp := FrontWindow;
        if wp = nil then
            DAFrontWindow := false
        else
            DAFrontWindow := windowPeek(wp)^.windowKind < 0;
    end;

    function GetIndStrSize (size, id, index: integer): str255;
        var
            s: str255;
    begin
        GetIndString(s, id, index);
        GetIndStrSize := TPcopy(s, 1, size - 1);
    end;

    function GetDirID (wdrn: integer; var vrn: integer; var dirID: longInt): OSErr;
        var
            procID: longInt;
            oe: OSErr;
    begin
        oe := GetWDInfo(wdrn, vrn, dirID, procID);
        if oe <> noErr then begin
            vrn := wdrn;
            dirID := 0;
        end;
        GetDirID := oe;
    end;

    function GetVolInfo (var name: str63; var vrn: integer; index: integer; var CrDate: longInt): OSErr;
        var
            pb: paramBlockRec;
            oe: OSErr;
    begin
        if (name <> '') & (name[length(name)] <> ':') then
            name := concat(name, ':');
        pb.ioNamePtr := @name;
        pb.ioVRefNum := vrn;
        pb.ioVolIndex := index;
        oe := PBGetVInfo(@pb, false);
        if oe = noErr then begin
            vrn := pb.ioVRefNum;
            CrDate := pb.ioVCrDate;
        end;
        GetVolInfo := oe;
    end;

    procedure PlotSICN (id, index, v, h: integer);
        var
            sh: Handle;
            bm: BitMap;
            r: Rect;
            gp: grafptr;
    begin
        sh := GetResource('SICN', id);
        HLock(sh);
        bm.baseAddr := Ptr(longInt(sh^) + (index - 1) * 32);
        bm.rowBytes := 2;
        SetRect(r, h, v, h + 16, v + 16);
        bm.bounds := r;
        GetPort(gp);
        CopyBits(bm, gp^.portBits, r, r, srcCopy, nil);
        HUnlock(sh);
        HPurge(sh);
    end;

    function LookupStrh (id: integer; match: str255): str255;
        var
            t, s: str255;
            i: integer;
    begin
        t := '';
        i := 1;
        repeat
            GetIndString(s, id, i);
            if s = match then begin
                GetIndString(t, id, i + 1);
                leave;
            end;
            i := i + 2;
        until s = '';
        LookupStrh := t;
    end;

    function LookupStrhNumber (id: integer; n: longInt): str255;
        var
            s, t: str255;
    begin
        NumToString(n, s);
        t := LookupStrh(id, s);
        if t = '' then
            t := s;
        LookupStrhNumber := t;
    end;

    procedure TrashHandle (h: handle);
        var
            p: ptr;
            i: longInt;
    begin
        if (h <> nil) & (h^ <> nil) then begin
            p := h^;
            for i := 1 to GetHandleSize(h) do begin
                p^ := -27;
                longInt(p) := longInt(p) + 1;
            end;
        end;
    end;

    function CheckCancel: boolean;
        var
            er: eventRecord;
    begin
        if GetNextEvent(everyEvent, er) then begin
            CheckCancel := (er.what = keyDown) and (BAND(er.message, charCodeMask) = ord('.')) and (BAND(er.modifiers, cmdKey) <> 0)
        end
        else begin
            CheckCancel := false;
        end;
    end;

    procedure BlockZero (p: ptr; len: longInt);
        var
            i: longInt;
    begin
        if len > 0 then begin
            while (BAND(ord(p), 3) <> 0) & (len > 0) do begin
                p^ := 0;
                longInt(p) := longInt(p) + 1;
                len := len - 1;
            end;
            while len >= 4 do begin
                longIntPtr(p)^ := 0;
                longInt(p) := longInt(p) + 4;
                len := len - 4;
            end;
            while len > 0 do begin
                p^ := 0;
                longInt(p) := longInt(p) + 1;
                len := len - 1;
            end;
        end
    end;

    procedure BlockFill (p: univ ptr; len: longInt; value: integer);
    begin
        while (len > 0) do begin
            p^ := value;
            len := len - 1;
            longInt(p) := longInt(p) + 1;
        end;
    end;

    function WindowInWindowList (w: windowPtr): boolean;
        type
            windowPtrPtr = ^windowPtr;
        var
            nw: windowPtr;
    begin
        nw := windowPtrPtr($9D6)^;
        while (nw <> nil) & (w <> nw) do begin
            nw := windowPtr(windowPeek(nw)^.nextwindow);
        end;
        WindowInWindowList := nw <> nil;
    end;

    function DirtyKey (ch: char): boolean;
    begin
        case ord(ch) of
            homeChar, endChar, helpChar, pageUpChar, pageDownChar, leftArrowChar, rightArrowChar, upArrowChar, downArrowChar:
                DirtyKey := false;
            otherwise
                DirtyKey := true;
        end;
    end;

    function SendCharToIsDialogEvent (var er: EventRecord; cs: charSet): boolean;
        var
            ch: char;
    begin
        SendCharToIsDialogEvent := true;
        if ((er.what = keyDown) | (er.what = autoKey)) & (BAND(er.modifiers, cmdKey) = 0) then begin
            ch := chr(BAND(er.message, $FF));
            if not (ch in (cs + [tab, del, bs])) & DirtyKey(ch) then begin
                SendCharToIsDialogEvent := false;
            end;
        end;
    end;

    procedure HiliteInvertRect (r: rect);
        const
            HiliteMode = $938;
    begin
        BitClr(POINTER(HiliteMode), pHiliteBit);
        InvertRect(r);
    end;

{$S Main}
    procedure FixScrap;
        var
            scrap: PScrapStuff;
            junk, offset: longInt;
    begin
        scrap := InfoScrap;
        if scrap^.scrapHandle = nil then begin
            scrap^.scrapState := -1;
        end;
        junk := GetScrap(nil, 'XXXX', offset);
        junk := UnloadScrap;
    end;

{$S Main}
    procedure HaveResources;
    begin
        if Get1Resource('BNDL', 128) = nil then begin
            SysBeep(1);
            ExitToShell;
        end;
    end;

end.