Liren Large Software Subsidy 9/09.iso/l/l041/2.ddi/MISC.ARC/TAEDIT.PAS

Pascal/Delphi Source File | 1987-12-31 | 13.4 KB | 483 lines

(****************************************************************)
(*                     DATABASE TOOLBOX 4.0                     *)
(*     Copyright (c) 1984, 87 by Borland International, Inc.    *)
(*                                                              *)
(*                           TAEdit                             *)
(*                                                              *)
(*    Purpose:  Editing routines for TABuild that use BINED     *)
(*                                                              *)
(****************************************************************)
unit TAEdit;

interface
uses DOS,
     CRT,
     BinEd,
{    If a compiler error occurs here, you need the unit BINED.TPU
     from the Turbo Pascal Editor Toolbox 4.0.  See the documentation
     at the beginning of TABUILD.PAS for detailed instructions. }

     MiscTool,
{    If a compiler error occurs here, you need to unpack the source
     to the MiscTool unit from the archived file Tools.arc.  See the
     README file on disk 1 for detailed instructions. }

     EditLn,
     FileUtil;

function CreateTypeFile(var UserFileSpec : FileSpec) : boolean;

function EditTypeFile(var UserFileSpec : FileSpec) : boolean;

function FixError(var CompErrors : text;
                  MainFileNm : FileName;
                  var OutputFile,
                      UserFileSpec : FileSpec) : boolean;

implementation
{$V-}
const
  F2  = #60;
  F10 = #68;
  {Commands other than ^K^D to exit editor}
  ExitCommands : array[0..9] of Char = (#2, #0, F10,
                                        #2, #0, F2,
                                        #2, ^K, ^Q, #0);
  MakeBackup = True;
  {Initial Coordinates of the editor window}
  Windx1 = 2;
  Windy1 = 2;
  Windx2 = 78;
  Windy2 = 19;

var
  EdData : EdCB;              {Editor control block}
  ExitCode : integer;
  ExitCommand : Word;         {Code for command used to leave editor}
  Fname : String;             {Input name of file being edited}

type
  BorderElements = (topleft, topright, botleft, botright, horiz, vert);
  BorderChars = array[BorderElements] of Char;
const
  Border :   BorderChars = '┌┐└┘─│';
  NoBorder : BorderChars = '      ';

  {Procedures and functions used as part of the demo}

procedure DrawBox(Border : BorderChars; x1, y1, x2, y2 : byte);
{-Draw a box around an editor window}
var
  i : Word;
  bar : String;
  barlen : Byte absolute bar;

begin                       {DrawBox}
  {Build horizontal bar}
  barlen := 3+X2-X1;
  FillChar(bar[1], barlen, Border[horiz]);
  {Draw top bar}
  bar[1] := Border[topleft];
  bar[barlen] := Border[topright];
  CRTputFast(X1, Y1, bar);
  {Draw bottom bar}
  bar[1] := Border[botleft];
  bar[barlen] := Border[botright];
  CRTputFast(X1, Y2+2, bar);

{Vertical bars}
  for i := Succ(Y1) to Succ(Y2) do
  begin
    CRTputFast(X1, i, Border[vert]);
    CRTputFast(X2+2, i, Border[vert]);
  end;
end;                        {DrawBox}

procedure WriteStatus(msg : String);
{-Write a status message to the bottom line of the screen}
var
  msglen : Byte absolute msg;

begin                       {WriteStatus}
  FillChar(msg[Succ(msglen)], 80-msglen, #32);
  msglen := 80;
  CRTputFast(1, 25, CAerr+msg);
end;                        {WriteStatus}

procedure CheckInitBinary(ExitCode : Word);
{-Check the results of the editor load operation}
begin                       {CheckInitBinary}
  if ExitCode <> 0 then
  begin
    {Couldn't initialize editor}
    GoToXY(1, 25);
    case ExitCode of
      1 : WriteLn('Insufficient heap space for text buffer');
    else
      WriteLn('Unknown load error');
    end;
    Halt(1);
  end;
end;                        {CheckInitBinary}

procedure CheckReadFile(ExitCode : Word; Fname : String);
{-Check the results of the file read}
var
  f : file;

begin                       {CheckReadFile}
  if ExitCode <> 0 then
  begin
    {Couldn't read file}
    case ExitCode of
      1 : begin
            {New file, assure valid file name}
            {$I-}
            Assign(f, Fname);
            Rewrite(f);
            if IOResult <> 0 then
            begin
              Close(f);
              WriteStatus('Illegal file name '+Fname);
            end
            else
            begin
              Close(f);
              Erase(f);
              Write('New File');
              Delay(2000);
              Write(^M);
              ClrEol;
              GoToXY(1, 1);
              ClrEol;
              Exit;
            end;
            {$I+}
          end;
          2 : WriteStatus('Insufficient text buffer size');
        else
          WriteStatus('Unknown read error');
      end;
      GoToXY(1, 25);
      Halt(1);
  end;
  GoToXY(1, 1);
  ClrEol;
end;                        {CheckReadFile}

procedure CheckSaveFile(ExitCode : Word; Fname : String);
{-Check the results of a file save}
begin                       {CheckSaveFile}
  if ExitCode <> 0 then
  begin
    {Couldn't save file}
    case ExitCode of
      1 : WriteStatus('Unable to create output file '+Fname);
      2 : WriteStatus('Error while writing output to '+Fname);
      3 : WriteStatus('Unable to close output file '+Fname);
      else
        WriteStatus('Unknown write error');
    end;
    GoToXY(1, 25);
    Halt(1);
  end;
end;                        {CheckSaveFile}

procedure WriteKeyboardToggles(info : Word);
{-Write the status of the keyboard toggles}
var
  s : String;

begin                       {WriteKeyboardToggles}
  s := CAerr;
  if (info and $40) <> 0 then
    s := s+'CL'
  else
    s := s+'  ';
  if (info and $20) <> 0 then
    s := s+' NL'
  else
    s := s+'   ';
  if (info and $10) <> 0 then
    s := s+' SL'
  else
    s := s+'   ';
  CRTputFast(72, 25, s);
end;                        {WriteKeyboardToggles}

{$F+}
procedure UserEventCheck(EventNo, KbdFlagInfo : Word);
    {-User hook for a background process called at every keypressed check}
begin                       {UserEventCheck}
  {Update keyboard toggles whenever changed}
  WriteKeyboardToggles(kbdflaginfo);
end;                        {UserEventCheck}
{$F-}

procedure InitWindow(var EdData : EdCB);
{-Draw a nice screen frame around the editor window}
var
  MsgPos : Byte;
  DemoMsg : String;

begin                       {InitWindow}
  {Draw a frame around the editor window}
  with EdData do
  begin
    DrawBox(Border, x1, y1, x2, y2);
    DemoMsg := ' Enter your database record and key type definitions ';
    MsgPos := 2+((X2+X1-Length(DemoMsg)) shr 1);
    CRTputFast(MsgPos, Y2+2, CAerr+DemoMsg);
  end;
end;                        {InitWindow}

procedure InitStatusLine;
{-Draw a status/prompt line for the editor demo}
begin                       {InitStatusLine}
  WriteStatus('        F10-Start Build          F2-saves file          ^K^Q - quit');
end;

const
  Save1 = -1;
  StartBuild = 0;
  Save2 =  1;
  Quit = 2;


function ExitBinaryEditor(var EdData : EdCB; ExitCommand : Integer)
    : Boolean;
{-Handle an editor exit - save or abandon file}
var
  ExitCode : Word;

begin                       {ExitBinaryEditor}
  case ExitCommand of
    StartBuild : begin                 {F10}
                   if ModifiedFileBinaryEditor(EdData) then
                   begin
                     ExitCode := SaveFileBinaryEditor(EdData, MakeBackup);
                     CheckSaveFile(ExitCode, FilenameBinaryEditor(eddata));
                   end;
                   ExitBinaryEditor := true;
                  GoToXY(1, 25);
                end;
    Save1,
    Save2 : begin {^K^D, F2 }
               ExitCode := SaveFileBinaryEditor(EdData, MakeBackup);
               CheckSaveFile(ExitCode, FilenameBinaryEditor(eddata));
               ExitBinaryEditor := false;
             end;
    Quit : begin   {^K^Q}
             ExitBinaryEditor := true;
             GoToXY(1, 25);
             Abort('User Terminated');
           end;
  end;
end;                        {ExitBinaryEditor}


function EditTypeFile(var UserFileSpec : FileSpec) : boolean;
begin
  EditTypeFile := false;
  {Initialize a window for the file}
  ExitCode :=
  InitBinaryEditor(
  EdData,                     {Editor control block, initialized by InitBinaryEditor}
  MaxFileSize,                {Size of data area to reserve for binary editor text buffer, $FFE0 max}
  Windx1,                     {Coordinates of editor window, upper left 1..80}
  Windy1,                     {Coordinates of editor window, upper left 1..25}
  Windx2,                     {Coordinates of editor window, lower right}
  Windy2,                     {Coordinates of editor window, lower right}
  True,                       {True to wait for retrace on color cards}
  EdOptInsert+EdOptIndent,    {Initial editor toggles}
  '.TYP',                     {Default extension for file names}
  ExitCommands,               {Commands to exit editor}
  @UserEventCheck);                       {Address of user event handler}
  CheckInitBinary(ExitCode);

  {Read the file}
  with UserFileSpec do
    ExitCode := ReadFileBinaryEditor(EdData, Path + Name + Ext);
  CheckReadFile(ExitCode, FilenameBinaryEditor(eddata));

  {Reset the editor for the new file}
  ResetBinaryEditor(EdData);

  {Write a status and prompt line}
  InitStatusLine;

  repeat
    {Set up the window border and title}
    InitWindow(EdData);

    {Edit the file}
    ExitCommand := UseBinaryEditor(EdData, '');

    {Handle the exit by saving the file or whatever}
  until ExitBinaryEditor(EdData, ExitCommand);
  TextBackground(Black);
  if ExitCommand = StartBuild then
  begin
    EditTypeFile := true;
    ClrScr;
    ReleaseBinaryEditorHeap(EdData);
  end
  else
    Halt;
end; { EditTypeFile }

const
  TPCOUT = 'TPC.OUT';
var
  CompErrors : text;

type
  ErrorRec = record
               LineNum,
               Column : integer;
               FN : FileName;
               Message,
               ErrLine : string;
             end;

procedure DisplayError(E : ErrorRec; Y : integer;
                       MainFileNm : FileNm;
                       var UserFileSpec : FileSpec);
const
  RecTypeStr = 'MaxDataType';
  KeyTypeStr = 'MaxKeyType';
var
  ErrorSpotted : boolean;
begin
  ErrorSpotted := false;
  ClrScr;
  GotoXY(1, Y);
  with E do
  begin
    if Pos(MainFileNm, FN) > 0 then
    begin
      if Pos(RecTypeStr, ErrLine) > 0 then
      begin
        Writeln;
        Writeln('TABuild Error: You did not define ', RecTypeStr);
        ErrorSpotted := true
      end;
      if not ErrorSpotted and
         (Pos(KeyTypeStr, ErrLine) > 0) then
      begin
        Writeln;
        Writeln('Tabuild Error: You did not define ', KeyTypeStr);
        ErrorSpotted := true;
      end;
    end;
    if not ErrorSpotted then
    begin
      if Pos(UpCaseStr('TAccess.typ'), FN) = 0 then
        Writeln('File ', FN);
      Writeln('Line number ', LineNum);
      Writeln(ErrLine);
      Write(' ':Column - 1,'^', Message);
    end;
  end;
end;

function ParseError(MsgFileNm : FileName;
                     var E : ErrorRec) : boolean;
var
  LastTwo : array[1..2] of string;
  MsgFile : text;
  CurLine : string;
  found : boolean;

procedure StripOut(var Dest, Source : String; Target : char);
var
  i : integer;
begin
  i := Pos(Target, Source);
  Dest := Copy(Source, 1, i - 1);
  Delete(Source, 1, i);
end;

var
  temp : string;
  code : integer;

begin { ParseError }
  Assign(MsgFile, MsgFileNm);
  Reset(MsgFile);
  FillChar(LastTwo, SizeOf(LastTwo), 0);
  found := false;
  while not eof(MsgFile) and not found do
  begin
    Readln(MsgFile, CurLine);
    E.Column := Pos('^', CurLine );
    if E.Column > 0 then
      found := true
    else
    begin
      LastTwo[1] := LastTwo[2];
      LastTwo[2] := CurLine;
    end;
  end;
  Close(MsgFile);
  if found then
    with E do
    begin
      ErrLine := LastTwo[2];
      StripOut(FN, LastTwo[1], '(');
      StripOut(temp, LastTwo[1], ')');
      Val(temp, LineNum, Code);
      Message := LastTwo[1];
      Delete(Message, 1, 2);
    end;
  ParseError := found;
end; { ParseError }

function FixError(var CompErrors : text;
                  MainFileNm : FileName;
                  var OutputFile,
                      UserFileSpec : FileSpec) : boolean;

var
  TypeError : ErrorRec;
begin
  with OutPutFile do
    if not ParseError(Path + Name + Ext, TypeError) then
      Abort('Not enough memory to compile/run TASizes');
  ClrScr;
  DisplayError(TypeError, WindY2 + 2, MainFileNm, UserFileSpec);
  FixError := EditTypeFile(UserFileSpec);
  Erase(CompErrors);
end;

function CreateTypeFile(var UserFileSpec : FileSpec): boolean;
const
  NumLines = 1;
  TypeDefTemplate : array[1..NumLines] of String[70] =
    ('{ Turbo Access Record and Key type for ');
var
  NewTypeFile : Text;
  CurLine : integer;
begin
  CreateTypeFile := false;
  with UserFileSpec do
    Assign(NewTypeFile, Path + Name + Ext);
  {$I-}
  Rewrite(NewTypeFile);
  {$I+}
  if IOResult <> 0 then
    Exit;
  for CurLine := 1 to NumLines do
  begin
    Write(NewTypeFile, TypeDefTemplate[CurLine]);
    if CurLine = 1 then
      Write(NewTypeFile, UserFileSpec.Name, ' }');
    Writeln(NewTypeFile);
  end;
  Close(NewTypeFile);
  CreateTypeFile := true;
end; { CreateTypeFile }

end.