Celestin Apprentice 4/Apprentice-Release4.iso/Source Code/Libraries/PNL Libraries/MyUtils.p

Text File | 1995-10-22 | 11.7 KB | 514 lines | [TEXT/CWIE]

unit MyUtils;

interface

    uses
        TextUtils, Events, Windows, MyTypes;

    const
        my_font_strh_id = 1900;

    type
        SavedWindowInfo = record
                oldport: GrafPtr;
                thisport: GrafPtr;
                font: integer;
                size: integer;
                face: Style;
            end;

    type
        MyFontType = (
                MFT_Geneva0, MFT_Geneva9, MFT_Geneva12,
                MFT_Courier0, MFT_Courier9, MFT_Courier12,
                MFT_Chicago0, MFT_Chicago9, MFT_Chicago12,
                MFT_System0, MFT_System9, MFT_System12,
                MFT_Monaco0, MFT_Monaco9, MFT_Monaco12
                );

    procedure GetMyFonts(ft:MyFontType; var font, size:integer);
    procedure SetMyFont(ft:MyFontType);
    function MyTrapAvailable (tNumber: INTEGER): BOOLEAN;
    function MyNumToString (n: longint): Str255;
    function NumToK(n:longint; extra:boolean):Str255;
    function NumToStr (n: longint): Str15;
    function NN (n: longint; len: integer): Str15;
    function N2 (n: longint): Str15;
    function HexN (n: longint): Char;
    function HexN2 (n: longint): Str15;
    function HexNN (n: longint; len: integer): Str15;
    function HexToNum (s: Str15): longint;
    function StrToNum (s: Str255): longint;
    procedure DotDotDot (var s: Str255; var width: integer);
    procedure PlotSICN (typ:OSType; id, index, v, h: integer);
    function LookupStrh (id: integer; match: Str255): Str255;
    function LookupStrhNumber (id: integer; n: longint): Str255;
    function DirtyKey (ch: char): boolean;
    function SendCharToIsDialogEvent (var er: EventRecord; cs: charSet): boolean;
    function GetVersionFromResFile: longint;
    procedure MySetTrapAddress (addr: UniversalProcPtr; trapword: integer);
    function MyGetTrapAddress (trapword: integer): UniversalProcPtr;
    procedure SafeDeviceLoop (drawingRgn: RgnHandle; drawingProc: DeviceLoopDrawingProcPtr; userData: univ longint; flags: DeviceLoopFlags);
    procedure SafeDeviceLoopRect (drawingRect: Rect; drawingProc: DeviceLoopDrawingProcPtr; userData: univ longint; flags: DeviceLoopFlags);
{ procedure drawingProc (depth: integer; deviceFlags: integer; targetDevice: GDHandle; item: longint); }
    procedure MakeRGBColor (red, green, blue: integer; var col: RGBColor);
    function IsExtensionVar (var name, ext: Str255): boolean;
    function IsExtension (name, ext: Str255): boolean;
    function IsPrefix (name, prefix: Str255): boolean;
    function TPbtst(value:longint; bit:integer):Boolean;
    procedure SetInvertHiliteMode;
    procedure HiliteInvertRect (r: rect);
    procedure HiliteInvertRgn (r: RgnHandle);
    procedure FixScrap;
    procedure HaveResources;

implementation

    uses
        Scrap, Packages, ToolUtils, Resources, Memory, Processes, Folders, Traps, Fonts,
        MyStrings, MyCallProc;

    const
        HiliteMode = $938;

    procedure SetInvertHiliteMode;
    begin
        BitClr(POINTER(HiliteMode), pHiliteBit);
    end;

    procedure HiliteInvertRect (r: rect);
    begin
        SetInvertHiliteMode;
        InvertRect(r);
    end;

    procedure HiliteInvertRgn (r: RgnHandle);
    begin
        SetInvertHiliteMode;
        InvertRgn(r);
    end;

    function TPbtst(value:longint; bit:integer):Boolean;
    begin
        TPbtst := btst(value, bit);
    end;

    procedure GetMyFonts(ft:MyFontType; var font, size:integer);
        var
            s:Str255;
            n:longint;
    begin
        GetIndString(s,my_font_strh_id,2*ord(ft) + 1);
        GetFNum(s,font);
        GetIndString(s,my_font_strh_id,2*ord(ft) + 2);
        StringToNum(s,n);
        size := n;
    end;

    procedure SetMyFont(ft:MyFontType);
        var
            font, size:integer;
    begin
        GetMyFonts(ft, font, size);
        TextFont(font);
        TextSize(size);
    end;

    function IsExtensionVar (var name, ext: Str255): boolean;
        var
            pn, pe: integer;
    begin
        if false then begin
            IsExtensionVar := IUEqualString(TPCopy(name, length(name) - length(ext) + 1, 255), ext) = 0;
        end
        else begin
            IsExtensionVar := false;
            if length(name) >= length(ext) then begin
                pn := length(name) - length(ext) + 1;
                pe := 1;
                while pe <= length(ext) do begin
                    if UpCase(name[pn]) <> UpCase(ext[pe]) then begin
                        leave;
                    end;
                    pn := pn + 1;
                    pe := pe + 1;
                end;
                IsExtensionVar := pe > length(ext);
            end;
        end;
    end;

    function IsPrefix (name, prefix: Str255): boolean;
    begin
        IsPrefix := IUEqualString(TPCopy(name, 1, length(prefix)), prefix) = 0;
    end;

    function IsExtension (name, ext: Str255): boolean;
    begin
        IsExtension := IsExtensionVar(name, ext);
    end;

    procedure MakeRGBColor (red, green, blue: integer; var col: RGBColor);
    begin
        col.red := red;
        col.green := green;
        col.blue := blue;
    end;

    procedure SafeDeviceLoop (drawingRgn: RgnHandle; drawingProc: DeviceLoopDrawingProcPtr; userData: univ longint; flags: DeviceLoopFlags);
    begin
        if MyTrapAvailable(_DeviceLoop) then begin
            DeviceLoop(drawingRgn, drawingProc, userData, flags);
        end
        else begin
            CallPascal02244(1, 0, nil, userData, drawingProc);
        end;
    end;

    procedure SafeDeviceLoopRect (drawingRect: Rect; drawingProc: DeviceLoopDrawingProcPtr; userData: univ longint; flags: DeviceLoopFlags);
        var
            rgn: RgnHandle;
    begin
        rgn := NewRgn;
        RectRgn(rgn, drawingRect);
        SafeDeviceLoop(rgn, drawingProc, userData, flags);
        DisposeRgn(rgn);
    end;

    function GetVersionFromResFile: longint;
        var
            versh: VersRecHndl;
    begin
        GetVersionFromResFile := 0;
        versh := VersRecHndl(Get1Resource('vers', 1));
        if versh <> nil then begin
            GetVersionFromResFile := longint(versh^^.numericVersion);
        end; (* if *)
    end;

    function MyTrapAvailable (tNumber: INTEGER): BOOLEAN;
{Check to see if a given trap is implemented. Babble as taken from IM6 }
        const
            TrapMask = $0800;
        var
            tType: TrapType;
            numtraps: integer;
    begin
        tType := TrapType(TPbtst(tNumber, 11));
        if (tType = ToolTrap) then begin
            if NGetTrapAddress($A86E, ToolTrap) = NGetTrapAddress($AA6E, ToolTrap) then begin
                numtraps := $0200;
            end
            else begin
                numtraps := $0400;
            end;
            if BAND(tNumber, $07FF) >= numtraps then begin
                tNumber := _Unimplemented;
            end;
        end;
        MyTrapAvailable := MyGetTrapAddress(tNumber) <> MyGetTrapAddress(_Unimplemented);
    end;

    function MyNumToString (n: longint): Str255;
        var
            s, t: Str255;
    begin
        if abs(n) < 4096 then begin
            NumToString(n, s)
        end else if abs(n) < 4194304 then begin
            NumToString(n div 1024, s);
            GetIndString(t, 935, 2);
            s := Concat(s, t);
        end
        else begin
            GetIndString(t, 935, 3);
            NumToString(n div 1048576, s);
            s := Concat(s, t);
        end;
        MyNumToString := s;
    end;

    function NumToK(n:longint; extra:boolean):Str255;
        const
            K = 1024;
            M = 1048576;
        var
            f:integer;
            s, dot:Str255;
    begin
        if (n < 1048576) & extra then begin
            n := n*1024;
            extra := false;
        end;
        if (n < K) then begin
            { extra is false }
            NumToString(n,s);
        end else begin
            { n >= K }
            f := ord(extra);
            while n >= M do begin
                f := f + 1;
                n := n div K;
            end;
            { K <= n < M } { Display n/1024 GetIndStr(935,f+2) }
            GetIndString(s, 935, f+2);
            GetIndString(dot, 935, 1);
            if n>=1024000 then begin
                n := n div 1024;
                s := concat(NumToStr(n),s);
            end else if n>=102400 then begin
                n:= n*10 div 1024;
                s := concat(NumToStr(n div 10),dot,NN(n mod 10,1),s);
            end else if n>=10240 then begin
                n:= n*100 div 1024;
                s := concat(NumToStr(n div 100),dot,NN(n mod 100,2),s);
            end else begin
                n := n*1000 div 1024;
                s := concat(NumToStr(n div 1000),dot,NN(n mod 1000,3),s);
            end;
        end;
        NumToK:=s;
    end;

    function NumToStr (n: longint): Str15;
        var
            s: Str255;
    begin
        NumToString(n, s);
        NumToStr := s;
    end;

    function NN (n: longint; len: integer): Str15;
        var
            s: Str255;
    begin
        if len > 15 then begin
            len := 15;
        end;
        NumToString(n, s);
        while length(s) < len do begin
            s := concat('0', s);
        end;
        NN := s;
    end;

    function N2 (n: longint): Str15;
    begin
        N2 := NN(n, 2);
    end;

    function HexN (n: longint): Char;
    begin
        n := BAND(n, $F);
        if n >= 10 then begin
            n := n + 7;
        end;
        n := n + 48;
        HexN := Chr(n);
    end;

    function HexN2 (n: longint): Str15;
    begin
        HexN2 := concat(HexN(BSR(n, 4)), HexN(n));
    end;

    function HexNN (n: longint; len: integer): Str15;
        var
            s: Str15;
    begin
        if len > 15 then begin
            len := 15;
        end;
        s := HexN(n);
        while length(s) < len do begin
            n := BAND(BSR(n, 4), $0FFFFFFF);
            s :=concat(HexN(n), s);
        end;
        HexNN := s;
    end;

    function HexToNum (s: Str15): longint;
        var
            n: longint;
            i, v: integer;
    begin
        i := 1;
        n := 0;
        while (i <= length(s)) & (s[i] in ['A'..'Z', 'a'..'z', '0'..'9']) do begin
            case s[i] of
                'A'..'Z':
                    v := ord(s[i]) - 55;
                'a'..'z':
                    v := ord(s[i]) - 87;
                '0'..'9':
                    v := ord(s[i]) - 48;
            end;
            n := BSL(n, 4) + v;
            i := i + 1;
        end;
        HexToNum := n;
    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;

    procedure PlotSICN (typ:OSType; id, index, v, h: integer);
        var
            sh: Handle;
            bm: BitMap;
            r: Rect;
            gp: grafptr;
    begin
        sh := GetResource(typ, 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 begin
            t := s;
        end;
        LookupStrhNumber := t;
    end;

    function DirtyKey (ch: char): boolean;
    begin
        DirtyKey := not (ord(ch) in [homeChar, endChar, helpChar, pageUpChar, pageDownChar, leftArrowChar, rightArrowChar, upArrowChar, downArrowChar]);
    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;

    function MyGetTrapAddress (trapword: integer): UniversalProcPtr;
    begin
        MyGetTrapAddress := UniversalProcPtr(NGetTrapAddress(trapword, TrapType(TPbtst(trapword, 11))));
    end;

    procedure MySetTrapAddress (addr: UniversalProcPtr; trapword: integer);
    begin
        NSetTrapAddress(addr, trapword, TrapType(TPbtst(trapword, 11)));
    end;

    procedure FixScrap;
        var
            scrap: ScrapStuffPtr;
            junk, offset: longint;
    begin
        scrap := InfoScrap;
        if scrap^.scrapHandle = nil then begin
            scrap^.scrapState := -1;
        end;
        junk := GetScrap(nil, 'XXXX', offset);
        junk := UnloadScrap;
    end;

    procedure HaveResources;
    begin
        if Get1Resource('BNDL', 128) = nil then begin
            SysBeep(1);
            ExitToShell;
        end;
    end;

end.

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

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

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