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