\ doc 98.11.4 12:27 am NAB
needs DataMgr
needs core-ext
needs condthens
needs double
needs Mem
decimal

2variable docDBR

2variable out
variable out-semaphore
0 out-semaphore !
: outinit ( -- )
  out-semaphore @ 0= if
    4096 (allocate) throw out 2!
  then  1 out-semaphore +! ;
: outfree ( -- )
  -1 out-semaphore +!
  out-semaphore @ 0= if
  out 2@ (free) throw  then ;
variable #out
: out, ( c -- )
  out 2@ #out @ m+ c!a  1 #out +! ;

: OpenDocDB
  ( mode zaddr len -- dbr. )
  OpenDB 2dup docDBR 2!  outinit ;

: CloseDocDB ( dbr. -- )
  CloseDB  outfree ;

\ Decompress a Doc record from a
\ 32-bit address to a special buffer:
: Decompress ( addr. len -- a. n ) 
  0 #out !  >r  2dup  r> m+  2swap
  ( end. addr. )
  begin  2dup c@a
    cond
\ 0, 9..127: verbatim
      dup 0=  over 9 128 within  or if out,
\ 128..191: repeat earlier sequence
      else  dup 128 192 within if
        >r  1 m+ 2dup c@a  r> 8 lshift  +
        dup  16383 and  3 rshift
        swap  7 and 3 +  0 do
          dup >r out 2@ #out @ m+
          r> negate m+  c@a out,
        loop drop
\ 192..255: space plus char&127
      else  dup 192 256 within if
        bl out, 127 and out,
\ 1..8: escape next n chars
      else  dup 1 9 within if
        0 do 1 m+  2dup c@a out,  loop
    thens
    1 m+
  2over 2over d= until
  2drop 2drop  out 2@ #out @ ;

\ Get a record from the current open
\ Doc file and decompress to a fixed
\ buffer.
: GetRecord ( index -- addr u )
  dup docDBR 2@ DmQueryRecord
  2dup MemHandleSize drop >r
  MemHandleLock
    2dup r> Decompress  >r 2>r
  MemPtrUnlock throw
  false swap docDBR 2@
    DmReleaseRecord throw  2r> r> ;

needs tools-ext
0 [if]
needs zstrings
: display ( c-addr. u -- )
   0 do
    2dup i m+ c@a dup 10 = if drop cr
    else emit then loop 2drop ;
: go
  DmModeReadOnly
  z" PalmOS SysTraps"
  OpenDocDB
  2dup DmNumRecords 1 do
    i GetRecord display
  loop CloseDocDB ;
[then]