\ memo 2/11/99 7:57 pm AC

needs core-ext
needs tools-ext
needs toolkit
needs zstrings
needs ids
needs DataMgr

15 constant categoryMask
(hex) 80 constant deleteMask

ID DATA    ID memo
2variable _MemoDBR
: MemoDBR  _MemoDBR 2@ ;
variable index
variable attrP
variable sSize
2variable sPtr

\ Support Routines

: NewMemo ( len -- ptr. )
  s>d index >abs MemoDBR 
  ( len. &index. DBR. ) DmNewRecord 
  MemHandleLock ;

: ReleaseCurrentMemo ( dirty -- err )
  index @  MemoDBR 
  DmReleaseRecord ;

: getCurrentMemoAttr ( -- attr )
  0. 0. attrP >abs index @ MemoDBR 
  DmRecordInfo drop attrP @ ;

: setCurrentMemoAttr ( attr -- err )
  attrP ! 0. attrP >abs  index @ 
  MemoDBR DmSetRecordInfo ;

: getCurrentMemoCategory 
  ( -- cat )
  getCurrentMemoAttr  
  categoryMask and ;

: setCurrentMemoCategory
  ( cat -- )
  getCurrentMemoAttr 
  categoryMask invert and or 
  setCurrentMemoAttr drop ;

: QueryMemo ( index -- handle. )
  MemoDBR DmQueryRecord ;

: GetCurrentMemo ( -- ptr. )
  index @ QueryMemo MemHandleLock ;

: NumMemo (  -- n )
  MemoDBR DmNumRecords ;

: CurrentMemoSize ( -- size )
  index @ QueryMemo 
  MemHandleSize d>s ;

: CurrentMemoDeleted? ( -- delflg )
  getCurrentMemoAttr deleteMask 
  and ;

: GrowCurrentMemo ( size -- ptr. )
  CurrentMemoSize + s>d 
  index @ memoDBR DmResizeRecord 
  MemHandleLock ;

\ Main Access 

: OpenMemoDB ( -- )
  dmModeReadWrite memo DATA  
  DmOpenDatabaseByTypeCreator
  2dup or 0= drop _MemoDBR 2! ;

: CloseMemoDB ( -- )
  MemoDBR DmCloseDatabase drop ;

: WriteNewMemo ( z-addr len -- )
  \ index = index of new memo 
  0 index !   1+ dup NewMemo
  2>r s>d rot >abs  0.  2r@
  ( length. &data. offset.  DBR. )
  DmWrite drop
  2r> MemPtrUnlock drop
  true ReleaseCurrentMemo drop ;

: WriteNewMemoInCategory
  ( cat z-addr length -- )
  \ index = index of new memo
  WriteNewMemo 
  setCurrentMemoCategory ;

: FindMemoInCategory
  ( cat c-add u -- success)
  \ if success = 1, index is valid
  sSize ! sPtr ! NumMemo 1- 0 do dup 
     i index !  
     getCurrentMemoCategory =
     CurrentMemoDeleted? 0= and if 
      GetCurrentMemo 2dup sSize @
      s>d 2swap sPtr @ >abs 
      strNCompare 0= if
          MemPtrUnlock drop
          0 ReleaseCurrentMemo drop
          unloop drop 1 exit
      else MemPtrUnlock drop 
          0 ReleaseCurrentMemo drop
      then 
      then
  loop drop 0 ;

: AppendCurrentMemo ( z-addr u -- )
  \ requires a valid "index"
  dup >r 1+ s>d rot >abs 
  CurrentMemoSize 1- s>d
  r> GrowCurrentMemo 2dup 2>r 
  DmWrite drop 2r>
  MemPtrUnlock drop
  true ReleaseCurrentMemo drop ;

0 [if]
: string1 z" hello world!" ;
: string2 z" abcdefg" ;
: test \ tests write in category 
  openMemoDB 6 string1
  WriteNewMemoInCategory
  closeMemoDB ;
: test1 \ tests find in category
  openMemoDB
  6 string1 FindMemoInCategory
  closeMemoDB ;
: test2 \ tests appending memo 
  openMemoDB string2 
  appendcurrentmemo closeMemoDB ;
[then]