\ 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]