Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/BIGED.ZIP/BEMAIN.PAS

Pascal/Delphi Source File | 1990-12-11 | 17.0 KB | 651 lines

{$F+,O+,A+,B-,D-,E+,I-,L-,N-,R-,S-,V-}

unit BEMain;

{$I OPDEFINE.INC}

interface

uses
  Dos,
  OpInline,
  OpRoot,
  OpCrt,
  OpDos,
  OpString,
{$IFDEF UseMouse}
  OpMouse,
{$ENDIF}
  OpCmd,
{$IFDEF UseDrag}
  OpDrag,
{$ENDIF}
  OpFrame,
  OpWindow,
  OpEdit,
  BigEd,
  ExecAccess;  {<-- NOTE: See OPro manual vol 3 pp 10-33 for this unit}


procedure Main;

implementation

const
    {NOTE: These *MUST* be full path\filename with extension!}
  TPC_Command  : PathStr = 'C:\TP\TPC.EXE';
  SwapFilePath : PathStr = 'C:\$ED1$.SWP';

const
  TTColors : ColorSet = (
    TextColor       : $1B; TextMono       : $0F;
    CtrlColor       : $1C; CtrlMono       : $07;
    FrameColor      : $13; FrameMono      : $07;
    HeaderColor     : $20; HeaderMono     : $70;
    ShadowColor     : $08; ShadowMono     : $70;
    HighlightColor  : $1E; HighlightMono  : $70;
    PromptColor     : $0E; PromptMono     : $07;
    SelPromptColor  : $0E; SelPromptMono  : $07;
    ProPromptColor  : $30; ProPromptMono  : $07;
    FieldColor      : $0F; FieldMono      : $0F;
    SelFieldColor   : $0F; SelFieldMono   : $0F;
    ProFieldColor   : $17; ProFieldMono   : $07;
    ScrollBarColor  : $13; ScrollBarMono  : $07;
    SliderColor     : $30; SliderMono     : $0F;
    HotSpotColor    : $30; HotSpotMono    : $70;
    BlockColor      : $30; BlockMono      : $0F;
    MarkerColor     : $4F; MarkerMono     : $70;
    DelimColor      : $31; DelimMono      : $0F;
    SelDelimColor   : $31; SelDelimMono   : $0F;
    ProDelimColor   : $31; ProDelimMono   : $0F;
    SelItemColor    : $3E; SelItemMono    : $70;
    ProItemColor    : $17; ProItemMono    : $07;
    HighItemColor   : $1F; HighItemMono   : $0F;
    AltItemColor    : $1F; AltItemMono    : $0F;
    AltSelItemColor : $3F; AltSelItemMono : $70;
    FlexAHelpColor  : $1F; FlexAHelpMono  : $0F;
    FlexBHelpColor  : $1F; FlexBHelpMono  : $0F;
    FlexCHelpColor  : $1B; FlexCHelpMono  : $70;
    UnselXrefColor  : $1E; UnselXrefMono  : $09;
    SelXrefColor    : $5F; SelXrefMono    : $70;
    MouseColor      : $4F; MouseMono      : $70
  );

type
  FileNodePtr = ^FileNode;
  FileNode =
    Object(DoubleListNode)
      Path : PathStr;
      State : StreamStateRec;

      constructor Init(P : PathStr; var S : StreamStateRec);
      destructor Done; virtual;
      procedure Update(P : PathStr; var S : StreamStateRec);
    end;

var
  BE : BigEditorPtr;
  BW : StackWindow;
  W  : Word;
  LC : Word;
  CC : Word;
  FilesList : DoubleList;
  Report : String;
  ErrFnd : Boolean;
  NFName : PathStr;
  CmpFile : PathStr;
  State : StreamStateRec;


  constructor FileNode.Init(P : PathStr; var S : StreamStateRec);
  begin
    if NOT DoubleListNode.Init then Fail;
    FileNode.Update(P,S);
  end;

  destructor FileNode.Done;
  begin
    DoubleListNode.Done;
  end;

  procedure FileNode.Update(P : PathStr; var S : StreamStateRec);
  begin
    Path := StUpCase(P);
    State := S;
  end;

  function FindFileInList(PS : PathStr) : FileNodePtr;
  var P : FileNodePtr;
  begin
    PS := StUpCase(PS);
    with FilesList do begin
      P := FileNodePtr(Head);
      while P <> NIL do begin
        if P^.Path = PS then begin
          FindFileInList := P;
          exit;
        end;
        P := FileNodePtr(Next(P));
      end;
      FindFileInList := NIL;
    end;
  end;

  procedure AddFileToList(PS : PathStr; var S : StreamStateRec);
  var P : FileNodePtr;
  begin
    P := FindFileInList(PS);
    if P = NIL then begin
      New(P,Init(PS,S));
      FilesList.Append(P);
    end
    else P^.Update(PS,S);
  end;


  procedure Status(CWP : BigEditorPtr);
  const
    TPath : String[12] = '            ';
    DefLine : String[80] =
  {          1         2         3         4         5         6         7         8 }
  { 12345678901234567890123456789012345678901234567890123456789012345678901234567890 }
   ' xxxxxxxx.xxx   Line: xxxxx  Col: xxxx  xxxk  Ins Ind Smart Wrap Save           ';
  var
    S,T : String;

    procedure Mov(L : String; I : Integer);
    begin
      Move(L[1],S[i],Length(L));
    end;

  begin
    with CWP^ do begin
        {fix display path if a new file}
      if LongFlagIsSet(beOptions,beNewFile) then begin
        TPath := Pad(JustFileName(Path),13);
        ClearLongFlag(beOptions,beNewFile);
      end;

        {do nothing else if we're in a hurry}
      if (LongFlagIsSet(beOptions,beFastScrUpd)) and
         (cwCmdPtr^.cpKeyPressed) then exit;

      S := DefLine;
      Mov(Pad(Long2Str(CurTopIdx+CurLineOfs),5),23);
      Mov(Pad(Long2Str(COfs+XOfs),4),35);
      Mov(LeftPad(Long2Str(MemAvail div 1024),3),41);

      if beOptionsAreOn(beInsert) then
        Mov('Ins',47)
      else
        Mov('Ovr',47);
      if NOT beOptionsAreOn(beIndent) then
        Mov('   ',51);
      if NOT beOptionsAreOn(beModified) then
        Mov('    ',66);
      if NOT beOptionsAreOn(beWordWrap) then
        Mov('    ',61);
      if NOT beOptionsAreOn(beSmartTabs) then
        Mov('     ',55);
      Mov(TPath,2);
      S[0] := Chr(ScreenWidth);
      with TTColors do
        FastWrite(S,Pred(wYL),wXL,ColorMono(HeaderColor,HeaderMono));
    end;
  end;

  procedure UserHook(CPP : CommandProcessorPtr; MT : MatchType; Key : Word);
    {-Called each time CommandProcessor evaluates a keystroke}
  var
    S : string[2];
    {$IFDEF UseMouse}
    SaveMouse : Boolean;
    {$ENDIF}
  begin
    S := '  ';
    if MT = PartMatch then
      if Lo(Key) < Ord(' ') then begin
        S[1] := '^';
        S[2] := Char(Lo(Key)+$40);
      end
      else
        S[1] := '+';

    {$IFDEF UseMouse}
    HideMousePrim(SaveMouse);
    {$ENDIF}

    with TTColors do
      FastWrite(S, 1, 1, ColorMono(PromptColor, PromptMono));

    {$IFDEF UseMouse}
    ShowMousePrim(SaveMouse);
    {$ENDIF}
  end;

  procedure Abort(Msg : string);
    {-Display an error message and halt}
  begin
    {$IFDEF UseMouse}
    {hide the mouse cursor}
    HideMouse;
    {$ENDIF}

    Window(1, 1, ScreenWidth, ScreenHeight);
    TextAttr := $07;
    ClrScr;
    WriteLn(Msg);
    Halt(1);
  end;

  procedure ClearPromptLine;
    {-Clear the status line}
  {$IFDEF UseMouse}
  var
    SaveMouse : Boolean;
  {$ENDIF}
  begin
    {$IFDEF UseMouse}
    HideMousePrim(SaveMouse);
    {$ENDIF}

    with TTColors do
      FastWrite(CharStr(' ', ScreenWidth), 1, 1, ColorMono(PromptColor, PromptMono));

    {$IFDEF UseMouse}
    ShowMousePrim(SaveMouse);
    {$ENDIF}
  end;

  procedure DisplayMessage(Msg : string);
    {-Display a message at the top of the screen}
  {$IFDEF UseMouse}
  var
    SaveMouse : Boolean;
  {$ENDIF}
  begin
    {$IFDEF UseMouse}
    HideMousePrim(SaveMouse);
    {$ENDIF}

    ClearPromptLine;
    if Length(Msg) > ScreenWidth then Msg[0] := Chr(ScreenWidth);
    with TTColors do
      FastWrite(Msg, 1, 1, ColorMono(PromptColor, PromptMono));

    {$IFDEF UseMouse}
    ShowMousePrim(SaveMouse);
    {$ENDIF}

    GotoXYabs(Length(Msg)+1, 1);
  end;

  procedure ErrorProc(UnitCode : Byte; var ErrCode : Word; Msg : string);
    {-Error handler}
  var
    I : Word;
    CursorSL, CursorXY : Word;
  begin
    {save the cursor position and shape}
    GetCursorState(CursorXY, CursorSL);

    {clear the status line}
    ClearPromptLine;

    {display the error message}
    NormalCursor;
    DisplayMessage(' '+Msg+'. Press any key...');

    {wait for a keypress}
    I := ReadKeyWord;

    {clear the prompt line}
    ClearPromptLine;

    {Restore cursor position and shape}
    RestoreCursorState(CursorXY, CursorSL);
  end;

  function EditProc(MsgCode : Word;
                    Prompt : string;
                    ForceUp : Boolean;
                    TrimBlanks : Boolean;
                    MaxLen : Byte;
                    var S : string) : Boolean;
   {-Line editing routine}
  var
    LE : LineEditor;
    Width : Byte;
  begin
    with LE do begin
      ClearPromptLine;
      Init(TTColors);
      if ForceUp then
        leEditOptionsOn(leForceUpper)
      else
        leEditOptionsOff(leForceUpper);
      if TrimBlanks then
        leEditOptionsOn(leTrimBlanks)
      else
        leEditOptionsOff(leTrimBlanks);
      Prompt := ' '+Prompt;
      if Length(Prompt)+MaxLen > 80 then
        Width := 79-Length(Prompt)
      else
        Width := MaxLen;
      ReadString(Prompt, 1, 1, MaxLen, Width, S);
      EditProc := (GetLastCommand <> ccQuit);
      ClearPromptLine;
    end;
  end;

  function YesNoFunc(MsgCode : Word; Prompt : string;
                     Default : Byte; QuitAndAll : Boolean) : Byte;
    {-Get a response to a yes-no question}
  var
    LE : LineEditor;
    Ch : Char;
    CharsToTake : CharSet;
  begin
    with LE do begin
      ClearPromptLine;
      Init(TTColors);
      leEditOptionsOn(leAllowEscape+leDefaultAccepted+leForceUpper);
      if Default = beYes then
        Ch := 'Y'
      else
        Ch := 'N';
      if QuitAndAll then begin
        CharsToTake := ['Y', 'N', 'A', 'Q'];
        Prompt := Prompt+' (Y/N/A/Q)'
      end
      else
        CharsToTake := ['Y', 'N'];
      ReadChar(Prompt, 1, 1, CharsToTake, Ch);
      if GetLastCommand = ccQuit then
        YesNoFunc := beQuit
      else case Ch of
        'Y' : YesNoFunc := beYes;
        'N' : YesNoFunc := beNo;
        'A' : YesNoFunc := beAll;
        'Q' : YesNoFunc := beQuit;
      end;
      ClearPromptLine;
    end;
  end;

  function GetFile(MsgCode : Word; Prompt : string;
                   ForceUp, TrimBlanks, Writing, MustExist : Boolean;
                   MaxLen : Byte; DefExt : ExtStr;
                   var S : string) : Boolean;
    {-Get a filename}
  var
    I : Word;
  begin
    if not EditProc(0, Prompt, ForceUp, TrimBlanks, MaxLen, S) then
      GetFile := False
    else if Writing then
      if ExistFile(S) then
        GetFile := YesNoFunc(0, 'File exists. Overwrite it?', beNo, False) = beYes
      else
        GetFile := True
    else if ExistFile(S) or not MustExist then
      GetFile := True
    else begin
      I := 0;
      ErrorProc(0, I, 'File not found');
      GetFile := False;
    end;
  end;

  procedure FindCompileError;
  var S,T : String;
      I,N : Integer;
  begin
    for I := 1 to ScreenHeight do begin
      FastRead(ScreenWidth,I,1,S);
      if Pos('): Error',S) > 0 then begin
        Report := S;
        NFName := Copy(S,1,Pred(Pos('(',S)));
        T := Copy(S,Pos('(',S)+1,5);
        while (Length(T) > 0) and (NOT(T[length(T)] in ['0'..'9'])) do Dec(T[0]);
        if Str2Word(T,LC) then begin
          N := 0;  CC := I;
          while CC <= ScreenHeight do begin
            Inc(CC);
            Inc(N);
            FastRead(ScreenWidth,CC,1,S);
            if Trim(S) = '^' then begin
              CC := Pos('^',S) + (80 * Pred(N div 2));
              exit;
            end;
          end;
        end;
      end;
    end;
  end;

  procedure FindCompileGood;
  var S : String;
      I : Integer;
  begin
    for I := 1 to ScreenHeight do begin
      FastRead(ScreenWidth,I,1,S);
      if Pos(' lines, ',S) > 0 then begin
        Report := S;
        exit;
      end;
    end;
  end;

  procedure CallTPC;
  var I : Integer;
  begin
    with BE^ do begin
      BW.Select;
      ClrScr;
      Report := '';
      I := ExecDOSSwap(TPC_Command+' '+CmpFile,False,NIL,SwapFilePath);
      if DOSExitCode <> 0 then begin
        FindCompileError;
        Select;
        Draw;
        if NFName <> CmpFile then
          if NOT beLoad(NFName,False) then begin
            GotError(epNonFatal+ecDeviceRead,'Couldn''t read '+NFName);
            exit;
          end;
        beJumpToLine(LC);
        beCursorHome;
        beCursorRight(CC-1);
      end
      else begin
        FindCompileGood;
        Select;
        Draw;
      end;
      DisplayMessage('  '+Report);
    end;
  end;

  procedure CallCompiler;
{$IFDEF UseMouse}
  var
    B : Boolean;
{$ENDIF}
  begin
{$IFDEF UseMouse}
    if (MouseInstalled) then begin
      HideMousePrim(B);
{$IFDEF UseDrag}
      RemoveISRs;
{$ENDIF}
    end;
{$ENDIF}

      {NOTE: In case you're wondering why these two routines are broken apart,
       it's because I lifted 'em from my older OpEditor-based program that
       can call TCC, TASM and TD as well.}
    CallTPC;

{$IFDEF UseMouse}
    if (MouseInstalled) then begin
{$IFDEF UseDrag}
      InstallISRs;
{$ENDIF}
      with TTColors do
        SoftMouseCursor($0000,(ColorMono(MouseColor,MouseMono) SHL 8) + $04);
      ShowMousePrim(B);
    end;
{$ENDIF}
  end;

  procedure PromptNewFile;
  var TmpS : String;
      B : Byte;
      W : Word;
      SSR : StreamStateRec;
      P : FileNodePtr;
  begin
    with BE^ do begin
      if LongFlagIsSet(beOptions,beModified) then begin
        B := beYesNo(0, 'File modified.  Save it?', beYes, False);
        if (B = beYes) and (Path <> '') then
          if beStore(Path) then ;
      end;
      beSaveStreamState(SSR,True);
      AddFileToList(FExpand(Path),SSR);
      TmpS := Path;
      if (beGetFileName(0,'New file: ',TmpS,False,False)) and
         (StUpCase(TmpS) <> Path) then begin
        TmpS := DefaultExtension(TmpS,beDefExt);
        beInformation(0,'Working...');
        if NOT beLoad(FExpand(TmpS),False) then begin
          GotError(epFatal+ecDeviceRead,'Error loading new file');
          SetLastCommand(ccError);
        end
        else begin
          P := FindFileInList(Path);
          if P = NIL then begin
            beSaveStreamState(SSR,True);
            AddFileToList(Path,SSR);
          end
          else beRestoreStreamState(P^.State,True);
          ClearLongFlag(beOptions,beModified);
        end;
      end;
      CmpFile := TmpS;
      beForceRedraw := True;
      beInformation(0,'');
    end;
  end;

  procedure Main;
  begin
      {init our screen-saver window}
    BW.Init(1,1,ScreenWidth,ScreenHeight);
      {init our BigEditor}
    New(BE,InitCustom(2, 3, ScreenWidth-1, ScreenHeight-1, TTColors,
                         DefWindowOptions or wBordered,
                         DefBigEdOptions or beFastScrUpd or beHighlightOn));
    if BE = NIL then
      Abort('Error '+Long2Str(InitStatus)+' making BigEditor');

    with BE^ do begin
        {fix up appearence items}
      Dec(wXL);
      with wFrame do begin
        DefArrows := TriangleArrows;
        AddCustomScrollBar(frRR,0,MaxLongInt,1,1,'■','░',TTColors);
        AddCustomScrollBar(frBB,0,1023,0,1,'■','░',TTColors);
      end;

        {set up our various procedure pointers}
      beSetStatusProc(Status);
      with BigEdCommands do begin
        SetUserHookProc(UserHook);
        AddCommand(ccAbandonFile, 1, $2D00, 0);  {AltX  Exit}
        AddCommand(ccUser2,       1, $4300, 0);  {F9    Compile}
        AddCommand(ccUser3,       1, $3D00, 0);  {F3    Load new}
        AddCommand(ccSearch,      1, $3F00, 0);  {F5    Search}
        AddCommand(ccReplace,     1, $4000, 0);  {F6    Search/Replace}
      end;
      beSetInfoProc(DisplayMessage);
      beSetEditProc(EditProc);
      beSetGetFileProc(GetFile);
      beSetYesNoProc(YesNoFunc);
      SetErrorProc(ErrorProc);
      SetDefaultExtension('PAS');

        {draw the base window}
      BW.Draw;
      ClrScr;

        {draw the edit window before loading file}
      BE^.Draw;

      if ParamCount = 0 then
        Path := 'NOFILE.'
      else begin
        Path := StUpcase(ParamStr(1));
        Path := DefaultExtension(Path,BE^.beDefExt);
        if NOT beLoad(Path,False) then with BE^ do begin
          Path := 'NOFILE.';
          beNewLineList;
          beResetLineList;
        end;
      end;
      CmpFile := Path;
      beSaveStreamState(State,True);
      AddFileToList(FExpand(Path),State);

      ClearErrors;

      while True do begin
        Process;
        case GetLastCommand of
          ccError :
            begin
              W := GetLastError;
              ErrorProc(0,W,'');
            end;

          ccAbandonFile :
            if (NOT(beOptionsAreOn(beModified))) or
               (YesNoFunc(0,'File modified.  Abandon changes?',beNo,False) = beYes) then begin
              DisplayMessage('Working...');
              Dispose(BE,Done);
              BW.Erase;
              BW.Done;
              NormalCursor;
              exit;
            end;

          ccUser2 :
            begin
              if beOptionsAreOn(beModified) and (Path <> '') then begin
                if beStore(Path) then begin
                  ClearLongFlag(beOptions,beModified);
                  beSaveStreamState(State,True);
                  AddFileToList(FExpand(Path),State);
                end;
              end;
              CallCompiler;
              beForceRedraw := True;
            end;

          ccUser3 :
            PromptNewFile;

          else
            ;
        end;
      end;
    end;
  end;

begin
  FilesList.Init;
end.