Celestin Apprentice 4/Apprentice-Release4.iso/Source Code/Pascal/Applications/NIH Image 1.59/1.59 Source/Text.p

Text File | 1995-05-11 | 18.1 KB | 716 lines | [TEXT/PJMM]

unit text;
{This unit contains routines for opening, saving, scrolling and editing text windows.}

interface

    uses
        Memory, QuickDraw, Packages, Menus, Events, Fonts, Scrap, ToolUtils, Resources, Errors, Palettes, StandardFile, globals, Utilities, Graphics, File2;

    procedure UpdateScrollBars;
    procedure UpdateTextWindow (WhichWindow: WindowPtr);
    procedure ActivateTextWindow (WhichWindow: WindowPtr; Activating: boolean);
    procedure DoMouseDownInText (event: EventRecord; WhichWindow: WindowPtr);
    procedure ScrollText;
    procedure GrowTextWindow (NewSize: LongInt);
    function MakeNewTextWindow (name: str255; width, height: integer): boolean;
    function OpenTextFile (name: str255; RefNum: integer): boolean;
    procedure DoKeyDownInText (ch: char);
    procedure ChangeFontOrSize;
    procedure DoTextCopy;
    procedure DoTextPaste;
    procedure DoTextClear;
    procedure SaveText;
    procedure SaveTextAs;
    function SaveTextChanges: integer;
    procedure InsertText (str: str255; EndOfLine: boolean);
    procedure DoFind;
    procedure DecrementTextWindowNums (num: integer);
    procedure SaveTextUsingPath (name:str255);
    procedure SelectAllText;


implementation


    type
        CharArrayType = packed array[0..32767] of char;
        CharArrayPtr = ^CharArrayType;


    procedure UpdateScrollBars;
        var
            vMax, vValue, hMax, hValue: integer;
    begin
        with TextInfo^ do begin
                hlock(handle(TextTE));
                with TextTE^^, TextTE^^.viewRect do begin
                        vTextPageSize := (bottom - top) div LineHeight;
                        hTextPageSize := right - left;
                        vMax := nLines - vTextPageSize;
                        hMax := 0;
                        vValue := (top - destRect.top) div LineHeight;
                        hValue := left - destRect.left;
                        if vMax < 0 then
                            vMax := 0;
                        if vValue < 0 then
                            vValue := 0;
                        if hMax < 0 then
                            hMax := 0;
                        if vValue < 0 then
                            vValue := 0;
                        SetControlMaximum(vTextScrollBar, vMax);
                        SetControlValue(vTextScrollBar, vValue);
                        SetControlMaximum(hTextScrollBar, hMax);
                        SetControlValue(hTextScrollBar, hValue);
                    end;
                hunlock(handle(TextTE));
            end;
{ShowMessage(concat('nListColumns= ', Long2str(nListColumns), crStr, 'hListPageSize= ', long2str(hListPageSize)));}
    end;


    procedure SetTextInfo;
  {Updates TextInfo so it points to the active text window.}
        var
            kind: integer;
    begin
        kind := CurrentWindow;
    end;


    procedure UpdateTextWindow (WhichWindow: WindowPtr);
    begin
        TextInfo := TextInfoPtr(WindowPeek(WhichWindow)^.RefCon);
        if TextInfo <> nil then
            with TextInfo^ do begin
                    SetPort(TextWindowPtr);
                    DrawControls(TextWindowPtr);
                    DrawGrowIcon(TextWindowPtr);
                    EraseRect(TextTE^^.viewRect);
                    TEUpdate(TextTE^^.viewRect, TextTE);
                    UpdateScrollBars;
                end; {with}
        SetTextInfo;
    end;


    procedure ActivateTextWindow (WhichWindow: WindowPtr; Activating: boolean);
    begin
        if Activating then
            UpdateTextWindow(WhichWindow);
        TextInfo := TextInfoPtr(WindowPeek(WhichWindow)^.RefCon);
        if TextInfo <> nil then
            with TextInfo^ do
                if Activating then begin
                        TEActivate(TextTE);
                        ShowControl(hTextScrollBar);
                        ShowControl(vTextScrollBar);
                        WhatToUndo := NothingToUndo;
                    end
                else begin
                        TEDeactivate(TextTE);
                        HideControl(hTextScrollBar);
                        HideControl(vTextScrollBar);
                    end;
        SetTextInfo;
    end;


    procedure SetFontSize;
        var
            fInfo: FontInfo;
    begin
        with TextInfo^ do begin
                SetPort(TextWindowPtr);
                TextFont(CurrentFontID);
                TextSize(CurrentSize);
                with TextTE^^, fInfo do begin
                        GetFontInfo(fInfo);
                        TxSize := CurrentSize;
                        LineHeight := ascent + descent + leading;
                        FontAscent := ascent;
                    end;
            end;
    end;


    procedure InitTextEdit;
        var
            dRect, vRect: rect;
    begin
        with TextInfo^ do begin
                SetPort(TextWindowPtr);
                SetRect(vrect, 0, 0, TextWidth - ScrollBarWidth, TextHeight - ScrollBarWidth);
                drect := vrect;
                InsetRect(drect, 4, 4);
                TextTE := TENew(drect, vrect);
                with TextTE^^ do begin
                        TxFont := CurrentFontID;
                        SetFontSize;
                        crOnly := 1; {do word wrap}
                    end;
                TESetSelect(0, 0, TextTE);
                UpdateScrollBars;
                TEAutoView(true, TextTE); {Enable auto-scrolling}
            end;
    end;


    procedure ScrollText;
        var
            value: integer;
    begin
        with TextInfo^, TextInfo^.TextTE^^ do
            TEScroll(0, (viewRect.top - destRect.top) - (GetControlValue(vTextScrollBar) * LineHeight), TextTE);
    end;


    procedure ScrollAction (theCtl: ControlHandle; partCode: integer);
        var
            bInc, pInc, delta: integer;
    begin
        if TextInfo <> nil then
            with TextInfo^ do begin
                    if theCtl = vTextScrollBar then begin
                            bInc := 1;
                            pInc := vTextPageSize
                        end
                    else begin
                            bInc := 4;
                            pInc := hTextPageSize
                        end;
                    case partCode of
                        kControlUpButtonPart:
                            delta := -bInc;
                        kControlDownButtonPart:
                            delta := bInc;
                        kControlPageUpPart:
                            delta := -pInc;
                        kControlPageDownPart:
                            delta := pInc;
                        otherwise
                            exit(ScrollAction);
                    end;
                    SetControlValue(theCtl, GetControlValue(theCtl) + delta);
                    ScrollText;
                end; {with}
    end;


    procedure DoMouseDownInText (event: EventRecord; WhichWindow: WindowPtr);
        var
            theCtl: ControlHandle;
            cValue: integer;
            loc: point;
    begin
        TextInfo := TextInfoPtr(WindowPeek(WhichWindow)^.RefCon);
        if TextInfo = nil then
            exit(DoMouseDownInText);
        SelectWindow(WhichWindow);
        SetPort(WhichWindow);
        loc := event.where;
        GlobalToLocal(loc);
        with TextInfo^ do
            if PtInRect(loc, TextTE^^.viewRect) then begin
                    TEClick(loc, BitTst(@event.modifiers, 6), TextTE);
                    UpdateScrollBars;
                end
            else
                case FindControl(loc, WhichWindow, theCtl) of
                    kControlUpButtonPart, kControlDownButtonPart, kControlPageUpPart, kControlPageDownPart:
                        if TrackControl(theCtl, loc, TextScrollActionProc) <> 0 then
                            ;
                    kControlIndicatorPart:
                        if TrackControl(theCtl, loc, nil) <> 0 then
                            ScrollText;
                    otherwise
                end;
    end;


    procedure GrowTextWindow (NewSize: LongInt);
    begin
        if TextInfo <> nil then
            with TextInfo^ do begin
                    TextWidth := LoWrd(NewSize);
                    TextHeight := HiWrd(NewSize);
                    SetPort(TextWindowPtr);
                    SizeWindow(TextWindowPtr, TextWidth, TextHeight, true);
                    EraseRect(TextWindowPtr^.PortRect);
                    MoveControl(hTextScrollBar, -1, TextHeight - ScrollBarWidth);
                    MoveControl(vTextScrollBar, TextWidth - ScrollBarWidth, -1);
                    SizeControl(hTextScrollBar, TextWidth - 13, ScrollBarWidth + 1);
                    SizeControl(vTextScrollBar, ScrollBarWidth + 1, TextHeight - 13);
                    InvalRect(TextWindowPtr^.PortRect);
                    with TextTE^^ do begin
                            SetRect(viewRect, 0, 0, TextWidth - ScrollBarWidth, TextHeight - ScrollBarWidth);
                            viewRect.bottom := (viewRect.bottom div lineHeight) * lineHeight;
                            destRect := viewRect;
                            InsetRect(destRect, 4, 4);
                        end;
                    TECalText(TextTE);
                    ScrollText;
                end; {with}
    end;


    function MakeNewTextWindow (name: str255; width, height: integer): boolean;
        var
            wrect, crect: rect;
    begin
        MakeNewTextWindow := false;
        if nTextWindows >= 10 then begin
                PutError(concat('NIH Image cannot open more than ', long2str(MaxTextWindows), ' text windows.'));
                exit(MakeNewTextWindow);
            end;
        TextInfo := TextInfoPtr(NewPtr(SizeOf(TextInfoRec)));
        if TextInfo = nil then
            exit(MakeNewTextWindow);
        with TextInfo^ do begin
                TextWidth := width;
                TextHeight := height;
                TextLeft := PicLeft;
                TextTop := PicTop;
                PicLeft := PicLeft + hPicOffset;
                PicTop := PicTop + vPicOffset;
                if ((PicLeft + TextWidth) > ScreenWidth) or ((PicTop + TextHeight) > ScreenHeight) then begin
                        PicLeft := PicLeftBase;
                        PicTop := PicTopBase;
                    end;
                if (TextTop + TextHeight) > ScreenHeight then
                    TextHeight := ScreenHeight - TextTop - 4;
                SetRect(wrect, TextLeft, TextTop, TextLeft + TextWidth, TextTop + TextHeight);
                TextWindowPtr := NewWindow(nil, wrect, name, true, 0, pointer(-1), true, 0);
                if TextWindowPtr = nil then begin
                        DisposePtr(ptr(TextInfo));
                        TextInfo := nil;
                        exit(MakeNewTextWindow);
                    end;
                WindowPeek(TextWindowPtr)^.WindowKind := TextKind;
                WindowPeek(TextWindowPtr)^.RefCon := LongInt(TextInfo);
                SetRect(crect, TextWidth - ScrollBarWidth, -1, TextWidth + 1, TextHeight - 14);
                vTextScrollBar := NewControl(TextWindowPtr, crect, '', true, 0, 0, TextHeight - 14, ScrollBarProc, 0);
                SetRect(crect, -1, TextHeight - ScrollBarWidth, TextWidth - 14, TextHeight + 1);
                hTextScrollBar := NewControl(TextWindowPtr, crect, '', true, 0, 0, TextWidth - 14, ScrollBarProc, 0);
                InitTextEdit;
                DrawControls(TextWindowPtr);
                WhatToUndo := NothingToUndo;
                TextTitle := name;
                TextRefNum := 0;
                Changes := false;
                TooBig := false;
                InsertMenuItem(WindowsMenuH, 'Dummy', WindowsMenuItems - 1 + nTextWindows);
                SetMenuItemText(WindowsMenuH, WindowsMenuItems + nTextWindows, name);
                nTextWindows := nTextWindows + 1;
                WindowNum := nTextWindows;
                TextWindow[nTextWindows] := TextWindowPtr;
                if TextScrollActionProc=nil
                    {then TextScrollActionProc:=NewControlActionProc(@ScrollAction);} {ppc-bug}
                    then TextScrollActionProc:=NewRoutineDescriptor(@ScrollAction, uppControlActionProcInfo, GetCurrentISA);
                MakeNewTextWindow := true;
            end; {with}
    end;


    function OpenTextFile (name: str255; RefNum: integer): boolean;
        var
            err: OSErr;
            f, item: integer;
            TextFileSize: LongInt;
            LargerThan32K: boolean;
    begin
        OpenTextFile := false;
        if FreeMem < MinFree then begin
                PutError('Not enough memory to open this text file.');
                exit(OpenTextFile);
            end;
        LargerThan32K := false;
        err := FSOpen(name, RefNum, f);
        err := GetEof(f, TextFileSize);
        if TextFileSize > MaxTextBufSize then begin
                item := PutMessageWithCancel('This text file is larger than 32K. Would you like to to open the first 32K?');
                if item = cancel then begin
                        err := fsclose(f);
                        exit(OpenTextFile);
                    end
                else begin
                        TextFileSize := 30000;
                        LargerThan32K := true;
                    end;
            end;
        if not MakeNewTextWindow(name, 500, 400) then begin
                err := fsclose(f);
                exit(OpenTextFile);
            end;
        with TextInfo^ do begin
                SetHandleSize(TextTE^^.hText, TextFileSize);
                if MemError <> noErr then begin
                        err := fsclose(f);
                        PutError('Out of memory.');
                        DisposePtr(ptr(TextInfo));
                        TextInfo := nil;
                        exit(OpenTextFile);
                    end;
                err := SetFPos(f, fsFromStart, 0);
                ShowWatch;
                TextTE^^.teLength := TextFileSize;
                err := fsRead(f, TextFileSize, TextTE^^.hText^);
                if err <> noErr then begin
                        TextTE^^.teLength := 0;
                        SetHandleSize(TextTE^^.hText, 0);
                        err := fsclose(f);
                        exit(OpenTextFile);
                    end;
                TECalText(TextTE);
                TextTitle := name;
                TextRefNum := RefNum;
                TooBig := LargerThan32K;
            end; {with}
        err := fsclose(f);
        OpenTextFile := true;
    end;


    procedure DoKeyDownInText (ch: char);
    begin
        if TextInfo <> nil then begin
                TEKey(ch, TextInfo^.TextTE);
                TextInfo^.Changes := true;
                UpdateScrollBars;
{with TextInfo^ do ShowMessage(concat(long2str(TextTE^^.teLength), '  ', long2str(GetHandleSize(TextTE^^.hText))));}
                WhatToUndo := NothingToUndo;
            end;
    end;


    procedure ChangeFontOrSize;
    begin
        if TextInfo <> nil then
            with TextInfo^ do begin
                    TextTE^^.TxFont := CurrentFontID;
                    SetFontSize;
                    SetPort(TextWindowPtr);
                    EraseRect(TextTE^^.viewRect);
                    TEUpdate(TextTE^^.viewRect, TextTE);
                    UpdateScrollBars;
                end; {with}
    end;


    procedure DoTextCopy;
        var
            err: OSErr;
    begin
        if TextInfo <> nil then begin
                TECopy(TextInfo^.TextTE);
                err := ZeroScrap;
                if err = NoErr then begin
                        err := TEToScrap;
                        WhatsOnClip := NothingOnClip; {It is on System Scrap}
                    end;
            end;
    end;


    procedure DoTextPaste;
        var
            err: OSErr;
    begin
        if TextInfo <> nil then begin
                err := TEFromScrap;
                if err = NoErr then
                    TEPaste(TextInfo^.TextTE);
                TextInfo^.Changes := true;
                UpdateScrollBars;
                WhatToUndo := NothingToUndo;
            end;
    end;


    procedure DoTextClear;
        var
            err: OSErr;
    begin
        if TextInfo <> nil then begin
                TEDelete(TextInfo^.TextTE);
                TextInfo^.Changes := true;
            end;
        UpdateScrollBars;
        WhatToUndo := NothingToUndo;
    end;


    procedure DoSaveText;
        var
            err, f: integer;
            TheInfo: FInfo;
            ByteCount: LongInt;
    begin
        if TextInfo <> nil then
            with TextInfo^ do begin
                    hlock(handle(TextTE));
                    with TextTE^^ do begin
                            ByteCount := TELength;
                            if ByteCount = 0 then
                                exit(DoSaveText);
                            err := GetFInfo(TextTitle, TextRefNum, TheInfo);
                            case err of
                                NoErr:
                                    if TheInfo.fdType <> 'TEXT' then begin
                                            TypeMismatch(TextTitle);
                                            exit(DoSaveText)
                                        end;
                                FNFerr:  begin
                                        err := create(TextTitle, TextRefNum, 'Imag', 'TEXT');
                                        if CheckIO(err) <> 0 then
                                            exit(DoSaveText);
                                    end;
                                otherwise
                                    if CheckIO(err) <> 0 then
                                        exit(DoSaveText)
                            end;
                            ShowWatch;
                            err := fsopen(TextTitle, TextRefNum, f);
                            if CheckIO(err) <> 0 then
                                exit(DoSaveText);
                            err := fswrite(f, ByteCount, hText^);
                            if CheckIO(err) <> 0 then
                                exit(DoSaveText);
                            err := SetEof(f, ByteCount);
                            err := fsclose(f);
                            err := FlushVol(nil, TextRefNum);
                            Changes := false;
                        end; {with}
                    hunlock(handle(TextTE));
                end; {with}
    end;


    procedure SaveTextAs;
        var
            where: Point;
            reply: SFReply;
    begin
        if TextInfo <> nil then begin
                where.v := 60;
                where.h := 100;
                SFPutFile(where, 'Save Text as?', TextInfo^.TextTitle, nil, reply);
                if reply.good then
                    with reply, TextInfo^ do begin
                            TextTitle := fname;
                            TextRefNum := vRefNum;
                            DoSaveText;
                            SetWTitle(TextWindowPtr, TextTitle);
                            SetMenuItemText(WindowsMenuH, WindowsMenuItems - 1 + WindowNum, TextTitle);
                        end;
            end;
    end;


    procedure SaveTextUsingPath(name:str255);
    var
        SaveTitle:str255;
    begin
        if TextInfo <> nil then with TextInfo^ do begin
            SaveTitle:=TextTitle;
            TextTitle := name;
            TextRefNum := 0;
            DoSaveText;
            TextTitle:=SaveTitle;
        end;
    end;


    procedure SaveText;
    begin
        if TextInfo <> nil then begin
                with TextInfo^ do
                    if (TextRefNum = 0) or TooBig then
                        SaveTextAs
                    else
                        DoSaveText;
            end;
    end;


    function SaveTextChanges: integer;
        const
            yesID = 1;
            NoID = 2;
            CancelID = 3;
        var
            id: integer;
            reply: SFReply;
    begin
        id := 0;
        with TextInfo^ do
            if changes and not TooBig then begin
                    if macro and (MacroCommand = DisposeC) then begin
                            SaveTextChanges := ok;
                            exit(SaveTextChanges);
                        end;
                    ParamText(TextTitle, '', '', '');
                    InitCursor;
                    id := alert(600, nil);
                    if id = yesID then
                        SaveText;
                end; {if changes}
        if id = cancelID then
            SaveTextChanges := cancel
        else
            SaveTextChanges := ok;
    end;


procedure InsertText (str: str255; EndOfLine: boolean);
  var
   text: Ptr;
   len: LongInt;
 begin
  if TextInfo <> nil then
   with TextInfo^ do
    begin
     if EndOfLine then
     str := concat(str, cr);
     len := length(str);
     if (TextTE^^.TELength + len) > 32767 then begin
       AbortMacro;
       exit(InsertText);
     end;
     if len > 0 then
      begin
       TEDelete(TextTE);
       text := Ptr(Ord4(@str) + 1);
       TEInsert(text, len, TextTE);
       Changes := true;
       UpdateScrollBars;
       WhatToUndo := NothingToUndo;
      end;
    end;
 end;



    procedure GoToLine (str: str255; data: CharArrayPtr);
        var
            pos, line: integer;
            found: boolean;
            n: LongInt;
    begin
        with TextInfo^.TextTE^^ do begin
                found := false;
                delete(str, 1, 1);
                StringToNum(str, n);
                pos := 0;
                line := 1;
                if n = 1 then
                    found := true
                else
                    repeat
                        if data^[pos] = cr then
                            line := line + 1;
                        pos := pos + 1;
                        if line = n then begin
                                found := true;
                                leave;
                            end;
                    until (pos >= teLength);
                if found then begin
                        TESetSelect(pos, pos, TextInfo^.TextTE);
                        TEKey('x', TextInfo^.TextTE);
                        TEKey(BackSpace, TextInfo^.TextTE);
                        UpdateScrollBars;
                    end
                else
                    beep;
            end;
    end;


    procedure DoFind;
        const
            StringID = 3;
        var
            mylog: DialogPtr;
            item: integer;
            i, firstpos, lastpos, pos: integer;
            slength: integer;
            match: boolean;
            data: CharArrayPtr;
            c: char;
            str: str255;
    begin
        if TextInfo = nil then
            exit(DoFind);
        hlock(handle(TextInfo^.TextTE));
        with TextInfo^.TextTE^^ do begin
                if not OptionKeyWasDown then begin
                        InitCursor;
                        ParamText('What would you like to find?', '', '', '');
                        mylog := GetNewDialog(170, nil, pointer(-1));
                        SetDString(MyLog, StringID, SearchString);
                        SelectdialogItemText(MyLog, StringID, 0, 32767);
                        OutlineButton(MyLog, ok, 16);
                        repeat
                            ModalDialog(nil, item);
                        until (item = ok) or (item = cancel);
                        if item = cancel then begin
                                DisposeDialog(mylog);
                                exit(DoFind)
                            end;
                        SearchString := GetDString(MyLog, StringID);
                        DisposeDialog(mylog);
                    end;
                slength := Length(SearchString);
                if slength = 0 then
                    exit(DoFind);
                str := SearchString;
                MakeLowerCase(str);
                data := CharArrayPtr(htext^);
                if (slength > 1) and (str[1] = '#') and (str[2] >= '0') and (str[2] <= '9') then begin
                        GoToLine(str, data);
                        hunlock(handle(TextInfo^.TextTE));
                        exit(DoFind);
                    end;
                match := false;
                lastpos := teLength - slength - 1;
                match := false;
                for firstpos := selEnd to lastpos do begin
                        match := true;
                        for i := 1 to slength do begin
                                c := data^[firstpos + i - 1];
                                if (c >= 'A') and (c <= 'Z') then
                                    c := chr(ord(c) + 32);
                                if c <> str[i] then begin
                                        match := false;
                                        leave
                                    end;
                            end;
                        if match then begin
                                pos := firstpos;
                                leave;
                            end;
                    end;
                if match then begin
                        TESetSelect(pos, pos, TextInfo^.TextTE);
                        TEKey('x', TextInfo^.TextTE);
                        TEKey(BackSpace, TextInfo^.TextTE);
                        TESetSelect(pos, pos + slength, TextInfo^.TextTE);
                        UpdateScrollBars;
                    end
                else
                    beep;
            end; {with}
        hunlock(handle(TextInfo^.TextTE));
    end;


    procedure SelectAllText;
    begin
        if TextInfo<>nil then
            TESetSelect(0, TextInfo^.TextTE^^.TELength, TextInfo^.TextTE)
    end;



end.