Topspeed_JPI/TS/MODBASE/MEMOFUNC.MOD

IMPLEMENTATION MODULE MemoFunctions;

(*
 *  ModBase
 *  Release 3.0
 *  (c) Copyright 1986 - 1991 John McMonagle & Donald G. Fletcher
 *  (c) Copyright 1986 - 1991 PMI
 *  P.O. Box 8402
 *  Green Bay Wi 53308
 *  All Rights Reserved
 *)

FROM SYSTEM IMPORT ADR,ADDRESS;

(*Repertoire modules*)
FROM HandleIO IMPORT BlockRead, BlockWrite,OpenFile,
     EndReached, SetFilePtr, GetFilePtr,FileOffSet;
FROM StringIO IMPORT ErrorMessage, NoError, PartialRead, PrintMessage;
FROM StrConv IMPORT StrToLongInteger, LongIntegerToStr;
FROM StrEdit IMPORT Append;
FROM M2Strings IMPORT Length,Pos;
FROM LowLevel IMPORT Fill;
FROM ErrorManager IMPORT WARN;
FROM Numbers IMPORT Min;
(*ModBase modules*)
FROM ModBase3 IMPORT DBFile, GetField,MemoSize, Replace,OpenMemo,MemoHandle;
  FROM VStorage IMPORT
    DosAlloc, DosDealloc;

  PROCEDURE DEALLOCATE(VAR loc:ADDRESS;size:CARDINAL);
  BEGIN
    DosDealloc(loc,size);
  END DEALLOCATE;

  PROCEDURE ALLOCATE(VAR loc:ADDRESS;size:CARDINAL);
  BEGIN
    DosAlloc(loc,size);
  END ALLOCATE;

CONST
  EndOfMemo = 32C;
  MemoBlockSize = 512;
  MaxMemoSize   =4000;


  PROCEDURE PadFile( FileHandle: CARDINAL; TheChar: CHAR;
      HowMany: CARDINAL );
    VAR
      TmpBufPtr: POINTER TO CARDINAL;
    BEGIN
      ALLOCATE( TmpBufPtr, HowMany );
      Fill( TmpBufPtr, HowMany, TheChar );
      IF BlockWrite( FileHandle, TmpBufPtr, HowMany ) # NoError THEN
        HALT;
      END;
      DEALLOCATE( TmpBufPtr, HowMany );
    END PadFile;

PROCEDURE GetMemoField(VAR alias: DBFile; fieldnum: CARDINAL; VAR
    memo: ARRAY OF CHAR);

  VAR
    FileError: ErrorMessage;
    memostr: ARRAY [0..9] OF CHAR;
    block: ARRAY[0..MemoSize-1] OF CHAR;
    memopos, memonum: LONGINT;
    handle,i: CARDINAL;
    fieldok: BOOLEAN;
  BEGIN
    IF NOT OpenMemo(alias)
    THEN
      WARN('Unable to open memo file')
    END;
    handle:=MemoHandle(alias);
    GetField(alias, fieldnum, memostr);
    (* First check to make sure there is a memo to read *)
    IF (StrToLongInteger(memostr,0, memonum))
        AND (memonum > VAL(LONGINT,0)) THEN
      memopos := VAL(LONGINT, MemoBlockSize) * memonum;
      SetFilePtr(handle, FromStart, memopos);
      memo[0] := 0C;
      block[0] := 0C;
      LOOP
        FileError := BlockRead(handle, ADR(block[0]), MemoSize);
        IF (FileError=NoError) OR (FileError=PartialRead)  THEN
          i:=Pos(EndOfMemo,block);
          IF i<MemoSize THEN
            block[i]:=0C;
            Append(memo,block);
            EXIT;
          ELSE
            Append(memo,block);
          END;
        ELSE
          EXIT
        END;
      END;
    ELSE (* the memofield was empty *)
      memo[0] := 0C;
    END;
  END GetMemoField;


PROCEDURE ReplaceM(VAR alias: DBFile; fieldnum: CARDINAL;VAR  memo:
    ARRAY OF CHAR);

  VAR
    FileError: ErrorMessage;
    ptrstr: ARRAY [0..9] OF CHAR;
    blocknum, blockpos: LONGINT;
    OldMemo   :POINTER TO ARRAY[0..MaxMemoSize]OF CHAR;
    handle:CARDINAL;
 (* seem a bit overkill but use of comparestr will use usualy 8K of stack *)
PROCEDURE StrEqual(VAR str1,str2:ARRAY OF CHAR):BOOLEAN;
VAR
  limit, count:CARDINAL;

BEGIN
  limit:=Min(HIGH(str1),HIGH(str2));
  count:=0;
  WHILE count<limit
  DO
    IF str1[count]#str2[count]
    THEN
      RETURN FALSE;
    ELSIF str1[count]=0C
    THEN
      RETURN TRUE;
    END;
    INC(count);
  END (* while *);
  IF HIGH(str1)<HIGH(str2)
  THEN
    RETURN str2[count]=0C;
  ELSIF HIGH(str1)>HIGH(str2)
  THEN
    RETURN str1[count]=0C
  ELSE
    RETURN TRUE;
  END;
END StrEqual;

  BEGIN
    IF NOT OpenMemo(alias)
    THEN
      WARN('Unable to open memo file')
    END;
    handle:=MemoHandle(alias);
    IF memo[0]#0C THEN (*  Added to avoid writing a '' Memo !!!! *)
      (* check to see if memo changed *)
      NEW(OldMemo);
      GetMemoField(alias,fieldnum,OldMemo^);
      IF  NOT StrEqual(OldMemo^,memo)
      THEN
        SetFilePtr(handle, FromStart, VAL(LONGINT,0));
        FileError := BlockRead(handle, ADR(blocknum), 4);
        blockpos := blocknum * VAL(LONGINT,MemoBlockSize);
        SetFilePtr(handle, FromStart, blockpos);
        FileError := BlockWrite(handle, ADR(memo), Length(memo));
        IF (Length(memo) MOD MemoBlockSize) # 0 THEN
          PadFile( handle, EndOfMemo, MemoBlockSize -
              (Length(memo) MOD MemoBlockSize) );
        END;
        LongIntegerToStr(blocknum,  10,ptrstr);
        Replace(alias, fieldnum, ptrstr);
        blockpos := GetFilePtr(handle);
          (* find what will be the next available block
             And write it to the first  4 bytes of the file *)
        blocknum := blockpos DIV VAL(LONGINT,MemoBlockSize);
        SetFilePtr(handle, FromStart, VAL(LONGINT,0));
        FileError := BlockWrite(handle, ADR(blocknum), 4);
      END;
      DISPOSE(OldMemo);
    ELSE
      Replace(alias, fieldnum,'          ');
    END;
  END ReplaceM;

BEGIN
END MemoFunctions.