net2o-file.fs 10.2 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
\ file states

\ Copyright (C) 2010-2014   Bernd Paysan

\ This program is free software: you can redistribute it and/or modify
\ it under the terms of the GNU Affero General Public License as published by
\ the Free Software Foundation, either version 3 of the License, or
\ (at your option) any later version.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU Affero General Public License for more details.

\ You should have received a copy of the GNU Affero General Public License
\ along with this program.  If not, see <http://www.gnu.org/licenses/>.

18 19
Sema file-sema

20
Variable net2o-path
bernd's avatar
bernd committed
21
pad $400 get-dir net2o-path $!
22 23 24 25 26 27 28 29 30 31 32 33

cmd-class class
    64field: fs-size
    64field: fs-seek
    64field: fs-seekto
    64field: fs-limit
    64field: fs-time
    field: fs-fid
    field: fs-path
    field: fs-id
    field: term-w
    field: term-h
bernd's avatar
bernd committed
34 35
    field: fs-inbuf
    field: fs-outbuf
36
    field: fs-termtask
37 38 39 40
    method fs-read
    method fs-write
    method fs-open
    method fs-close
bernd's avatar
bernd committed
41
    method fs-poll
42 43 44 45 46 47 48 49 50 51 52 53 54
end-class fs-class

Variable fs-table

: >seek ( size 64to 64seek -- size' )
    64dup 64>d fs-fid @ reposition-file throw 64- 64>n umin ;

: fs-timestamp! ( mtime fileno -- ) >r
    [IFDEF] android  rdrop 64drop
    [ELSE]  \ ." Set time: " r@ . 64dup 64>d d. cr
	64>d 2dup statbuf ntime!
	statbuf 2 cells + ntime!
	r> statbuf futimens ?ior [THEN] ;
bernd's avatar
bernd committed
55 56 57
: fs-size! ( 64size -- )
    64dup fs-size 64! fs-limit 64!
    64#0 fs-seek 64! 64#0 fs-seekto 64! 64#0 fs-time 64! ;
58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78

:noname ( addr u -- n )
    fs-limit 64@ fs-seekto 64@ >seek
    fs-fid @ read-file throw
    dup n>64 fs-seekto 64+!
; fs-class to fs-read
:noname ( addr u -- n )
    fs-limit 64@ fs-size 64@ 64umin
    fs-seek 64@ >seek
    tuck fs-fid @ write-file throw
    dup n>64 fs-seek 64+!
; fs-class to fs-write
:noname ( -- )
    fs-fid @ 0= ?EXIT
    fs-time 64@ 64dup 64-0= IF  64drop
    ELSE
	fs-fid @ flush-file throw
	fs-fid @ fileno fs-timestamp!
    THEN
    fs-fid @ close-file throw  fs-fid off
; fs-class to fs-close
bernd's avatar
bernd committed
79 80 81
:noname ( -- size )
    fs-fid @ file-size throw d>64
; fs-class to fs-poll
82 83 84 85 86 87
:noname ( addr u mode -- ) fs-close 64>n
    msg( dup 2over ." open file: " type ."  with mode " . cr )
    >r 2dup absolut-path?  !!abs-path!!
    net2o-path open-path-file throw fs-path $! fs-fid !
    r@ r/o <> IF  0 fs-fid !@ close-file throw
	fs-path $@ r@ open-file throw fs-fid  !  THEN  rdrop
bernd's avatar
bernd committed
88
    fs-poll fs-size!
89 90
; fs-class to fs-open

bernd's avatar
bernd committed
91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114
\ subclassing for other sorts of files

fs-class class
end-class socket-class

:noname ( addr u port -- ) fs-close 64>n
    msg( dup 2over ." open socket: " type ."  with port " . cr )
    open-socket fs-fid ! 64#0 fs-size! ; socket-class to fs-open
:noname ( -- size )
    fs-fid @ fileno check_read dup 0< IF  -512 + throw  THEN
    n>64 fs-size 64@ 64+ ; socket-class to fs-poll

fs-class class
end-class termclient-class

:noname ( addr u -- u ) tuck type ; termclient-class to fs-write
:noname ( addr u -- u ) 0 -rot bounds ?DO
	key? 0= ?LEAVE  key I c! 1+  LOOP ; termclient-class to fs-read
:noname ( addr u 64n -- ) 64drop 2drop ; termclient-class to fs-open
:noname ( -- ) ; termclient-class to fs-close

termclient-class class
end-class termserver-class

115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
Variable termserver-tasks
User termfile

: ts-type ( addr u -- ) termfile @ .fs-outbuf $+! ;
: ts-emit ( c -- ) termfile @ .fs-outbuf c$+! ;
: ts-form ( -- w h ) termfile @ >o term-w @ term-h @ o> ;
: ts-key? ( -- flag ) termfile @ .fs-inbuf $@len 0<> ;
: ts-key ( -- key )
    BEGIN  ts-key? 0=  WHILE  stop  REPEAT
    termfile @ >o fs-inbuf $@ drop c@ fs-inbuf 0 1 $del o> ;

' ts-type ' ts-emit what's cr ' ts-form output: termserver-out
op-vector @
what's at-xy what's at-deltaxy what's page what's attr!
termserver-out
IS attr! IS page IS at-deltaxy IS at-xy
op-vector !
' ts-key  ' ts-key? input: termserver-in

1 Constant file-permit#
2 Constant socket-permit#
4 Constant ts-permit#
8 Constant tc-permit#
file-permit# Value fs-class-permit \ by default permit only files

: >termserver-io ( -- )
    [: up@ { w^ t } t cell termserver-tasks $+! ;] file-sema c-section
    ts-permit# fs-class-permit or to fs-class-permit ;

event: ->termfile ( o -- ) dup termfile ! >o form term-w ! term-h ! o>
    termserver-in termserver-out ;
event: ->termclose ( -- ) termfile off  default-in default-out ;

bernd's avatar
bernd committed
148 149 150 151
:noname ( addr u -- u ) tuck fs-inbuf $+! ; termserver-class to fs-write
:noname ( addr u -- u ) fs-outbuf $@len umin >r
    fs-outbuf $@ r@ umin rot swap move
    fs-outbuf 0 r@ $del r> ; termserver-class to fs-read
152 153 154 155 156 157 158 159 160 161 162 163
:noname ( addr u 64n -- )  64drop 2drop
    [: termserver-tasks $@ 0= !!no-termserver!!
	@ termserver-tasks 0 cell $del dup fs-termtask !
	<event o elit, ->termfile event>
    ;] file-sema c-section
; termserver-class to fs-open
:noname ( -- )
    [: fs-termtask @ ?dup-IF
	    <event ->termclose event>
	    fs-termtask cell termserver-tasks $+! fs-termtask off
	THEN ;] file-sema c-section
; termserver-class to fs-close
bernd's avatar
bernd committed
164 165 166 167 168 169 170 171 172

Create file-classes
' fs-class ,
' socket-class ,
' termclient-class ,
' termserver-class ,

here file-classes - cell/ Constant file-classes#

bernd's avatar
bernd committed
173 174 175 176 177
: fs-class! ( n -- )
    dup file-classes# u>= !!fileclass!!
    1 over lshift fs-class-permit and 0= !!fileclass!!
    cells file-classes + @ o cell- ! ;

bernd's avatar
bernd committed
178 179
\ id handling

180 181 182 183 184 185 186 187 188 189 190 191 192 193 194
: id>addr ( id -- addr remainder )
    >r file-state $@ r> cells /string >r dup IF  @  THEN r> ;
: id>addr? ( id -- addr )
    id>addr cell < !!fileid!! ;
: new>file ( id -- )
    [: fs-class new { w^ fsp } fsp cell file-state $+!
      fsp @ >o fs-id !
      fs-table @ token-table ! 64#-1 fs-limit 64! o> ;]
    filestate-lock c-section ;

: lastfile@ ( -- fs-state ) file-state $@ + cell- @ ;
: state-addr ( id -- addr )
    dup >r id>addr dup 0< !!gap!!
    0= IF  drop r@ new>file lastfile@  THEN  rdrop ;

bernd's avatar
bernd committed
195 196
\ state handling

197 198 199 200 201 202 203 204 205 206 207 208 209 210
: dest-top! ( addr -- )
    \ dest-tail @ dest-size @ + umin
    dup dup dest-top @ U+DO
	data-ackbits @ I I' fix-size dup { len }
	chunk-p2 rshift swap chunk-p2 rshift swap bit-erase
    len +LOOP  dest-top ! ;

: dest-back! ( addr -- )
    dup dup dest-back @ U+DO
	data-ackbits @ I I' fix-size dup { len }
	chunk-p2 rshift swap chunk-p2 rshift swap bit-fill
    len +LOOP  dest-back ! ;

: size! ( 64 -- )
bernd's avatar
bernd committed
211 212
    64dup fs-size 64!  fs-limit 64umin! ;
: seek-off ( -- )
213 214 215 216 217 218
    64#0 fs-seekto 64! 64#0 fs-seek 64! ;
: seekto! ( 64 -- )
    fs-size 64@ 64umin fs-seekto 64umax! ;
: limit-min! ( 64 id -- )
    fs-size 64@ 64umin fs-limit 64! ;
: init-limit! ( 64 id -- )  state-addr .fs-limit 64! ;
bernd's avatar
bernd committed
219 220
: poll! ( 64 -- 64 )
    fs-limit 64! fs-poll 64dup size! ;
221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340

: file+ ( addr -- ) >r 1 r@ +!
    r@ @ id>addr nip 0<= IF  r@ off  THEN  rdrop ;

: fstates ( -- n )  file-state $@len cell/ ;

: fstate-off ( -- )  file-state @ 0= ?EXIT
    file-state $@ bounds ?DO  I @ .dispose  cell +LOOP
    file-state $off ;
: n2o:save-block ( id -- delta )
    rdata-back@ file( over data-rmap @ .dest-raddr @ -
    { os } ." file write: " 2 pick . os hex.
\    os addr>ts data-rmap @ .dest-cookies @ + over addr>ts xtype space
\    data-rmap @ .data-ackbits @ os addr>bits 2 pick addr>bits bittype space
    )
    rot id>addr? .fs-write dup /back file( dup hex. residualwrite @ hex. cr ) ;

\ careful: must follow exactpy the same loic as slurp (see below)
: n2o:spit ( -- ) fstates 0= ?EXIT
    [: +calc fstates 0 { states fails }
	BEGIN  rdata-back?  WHILE
		write-file# @ n2o:save-block
		IF 0 ELSE fails 1+ residualwrite off THEN to fails
		residualwrite @ 0= IF
		    write-file# file+ blocksize @ residualwrite !  THEN
	    fails states u>= UNTIL  THEN msg( ." Write end" cr ) +file ;]
    file-sema c-section ;

: save-to ( addr u n -- )  state-addr >o
    r/w create-file throw fs-fid ! o> ;

\ file status stuff

: n2o:get-stat ( -- mtime mod )
    fs-fid @ fileno statbuf fstat ?ior
    statbuf st_mtime ntime@ d>64
    statbuf st_mode l@ $FFF and ;

: n2o:track-mod ( mod fileno -- )
    [IFDEF] android 2drop
    [ELSE] swap fchmod ?ior [THEN] ;

: n2o:set-stat ( mtime mod -- )
    fs-fid @ fileno n2o:track-mod fs-time 64! ;

\ open/close a file - this needs *way more checking*! !!FIXME!!

User file-reg#

: n2o:close-file ( id -- )
    id>addr? .fs-close ;

: blocksize! ( n -- )
    dup blocksize !
    file( ." file read: ======= " cr ." file write: ======= " cr )
    dup residualread !  residualwrite ! ;

: n2o:close-all ( -- )
    [: fstates 0 ?DO
	    I n2o:close-file
	LOOP  file-reg# off  fstate-off
	blocksize @ blocksize!
	read-file# off  write-file# off ;] file-sema c-section ;

: n2o:open-file ( addr u mode id -- )
    state-addr .fs-open ;

\ read in from files

: n2o:slurp-block ( id -- delta )
    data-head@ file( over data-map @ .dest-raddr @ -
    >r ." file read: " rot dup . -rot r> hex. )
    rot id>addr? .fs-read dup /head file( dup hex. residualread @ hex. cr ) ;

\ careful: must follow exactpy the same loic as n2o:spit (see above)
: n2o:slurp ( -- head end-flag )
    data-head? 0= fstates 0= or IF  head@ 0  EXIT  THEN
    [: +calc fstates 0 { states fails }
	0 BEGIN  data-head?  WHILE
		read-file# @ n2o:slurp-block
		IF 0 ELSE fails 1+ residualread off THEN to fails
		residualread @ 0= IF
		    read-file# file+  blocksize @ residualread !  THEN
	    fails states u>= UNTIL  THEN msg( ." Read end" cr ) +file
	head@ fails states u>= ;]
    file-sema c-section file( dup IF  ." data end" cr  THEN ) ;
    
: n2o:track-seeks ( idbits xt -- ) { xt } ( i seeklen -- )
    8 cells 0 DO
	dup 1 and IF
	    I dup id>addr? >o fs-seek 64@ fs-seekto 64@ 64<> IF
		fs-seekto 64@ 64dup fs-seek 64! o>
		xt execute  ELSE  drop o>  THEN
	THEN  2/
    LOOP  drop ;

: n2o:track-all-seeks ( xt -- ) { xt } ( i seeklen -- )
    fstates 0 ?DO
	I dup id>addr? >o fs-seek 64@ fs-seekto 64@ 64<> IF
	    fs-seekto 64@ 64dup fs-seek 64! o>
	    xt execute  ELSE  drop o>  THEN
    LOOP ;

0 [IF]
Local Variables:
forth-local-words:
    (
     (("event:") definition-starter (font-lock-keyword-face . 1)
      "[ \t\n]" t name (font-lock-function-name-face . 3))
     (("debug:" "field:" "2field:" "sffield:" "dffield:" "64field:") non-immediate (font-lock-type-face . 2)
      "[ \t\n]" t name (font-lock-variable-name-face . 3))
     ("[a-z\-0-9]+(" immediate (font-lock-comment-face . 1)
      ")" nil comment (font-lock-comment-face . 1))
    )
forth-local-indent-words:
    (
     (("event:") (0 . 2) (0 . 2) non-immediate)
    )
End:
[THEN]