( doc day 22.06.01 )

\ Palm docs support.
\ Supports compressed Docs.
\ Docs can be nested.

needs openDB database
needs cond cond

10 constant lf
0 value curDocRec

: dfield
  create over w, +
  does> w@ curDocRec +
;

0
2    dfield .version
2    dfield .reserved1
cell dfield .doc_size
2    dfield .num_recs
2    dfield .rec_size
cell dfield .reserved2
dup constant /docrec0

cell dfield curDoc
cell dfield unpackBuf
cell dfield unpackPos
cell dfield lastLine
cell dfield residuaryRecs

constant /docrec

: docbuf ( -- addr u )
   unpackBuf @ unpackPos @
;

: openDoc ( addr u -- ref )
   /docrec allocate throw to curDocRec
   r/o openDB dup curDoc !
   c/l cell+ allocate throw dup 
   lastLine ! 0!
;

: GetHeader ( ref )
   0 DmQueryRecord ?DmErr
   dup MemHandleLock >rel 
   curDocRec /docrec0 cmove
   MemHandleUnlock throw
   .rec_size w@ c/l +
   allocate throw unpackBuf !
   .num_recs w@ residuaryRecs !
;

: CloseDoc
   curDoc @ DmCloseDatabase throw
   unpackBuf @ free throw
   lastLine @ free throw
   curDocRec free throw
;

: OutChar ( c )
   docbuf + c!
   unpackPos 1+!
;

: Decompress  ( addr1 u1 -- addr2 u2 )
   lastLine @ dup @ swap cell+ swap
   dup unpackPos !
   unpackBuf @ swap cmove
   .version w@
   2 = \ compressed
   if
     over + swap 
     begin dup c@
       cond
         dup 0= over 9 128 within or if outChar else
         dup 128 192 within if
         >r 1+ dup c@ r> 8 lshift +
         dup 16383 and  3 rshift
         swap  7 and 3 + 0 
         do
           dup >r docbuf +
           r> - c@ outChar
         loop drop else
         dup 192 256 within if bl outChar 127 and outChar else
         dup 1 9 within if 0 do 1+ dup c@ outChar loop
       thens
       1+ 2dup =
     until 2drop
   else 
      docbuf +
      over unpackPos +!
      swap cmove
   then docbuf
;

: DetachLastLine ( addr u -- addr u1 )
   residuaryRecs @ 0= if exit then
   tuck
   begin
     dup
   while
     2dup + 1- c@ lf =
     if
       rot >r 2dup + \ from
       over r> swap - \ how much
       lastline @ 2dup !
       cell+ swap cmove
       exit
     then
     1-
   repeat rot drop
;                

: GetRecord ( index -- addr u )
   curDoc @ swap DmQueryRecord ?DmErr
   dup MemHandleLock >rel
   over MemHandleSize Decompress
   DetachLastLine
   rot MemHandleUnlock throw
;

: ProcessDoc ( addr u -- ior )
    source-id >r
    include-ptr throw
    r> to source-id
;

: docinc ( addr u )
   curDocRec >r curMemo @ >r
   2dup heap-copy curMemo !
   OpenDoc GetHeader
   .num_recs w@ 1+ 1 
   ?do
     -1 residuaryRecs +!
     i GetRecord ProcessDoc
   loop
   CloseDoc
   curMemo @ free throw
   r> curMemo ! r> to curDocRec
;

: dneeds ( "name" "lib" -- )
  NextWord NextWord 2swap sfind
  if drop 2drop
  else 2drop docinc
  then
;