(*
 * LANGUAGE    : ANS Forth
 * PROJECT     : Forth Environments
 * DESCRIPTION : Named pipes
 * CATEGORY    : Tools
 * AUTHOR      : Marcel Hendrix
 * LAST CHANGE : October 26, 1997, mhx; Linux's named pipes don't work with URL's (?)
 * LAST CHANGE : October 20, 1997, mhx; close handles after an error
 * LAST CHANGE : October 19, 1997, mhx
 *)

	MS-DOS? [IF] CR .( MS-DOS not supported ) ABORT [THEN]

        REVISION -npipes "ÄÄÄ Named pipes         Version 1.03 ÄÄÄ"

	PRIVATES

	CR .( Flash! Checkout disconnectpipe == #199 SYSCALL on Linux? )

DOC
(*
 See also sockets.frt.
 Try cliserv2.frt for an example.
 Note the required "\" for Windows!
*)
ENDDOC


-- Need to do this, unless the pipe is freshly created.
: disconnect ( handle -- )
	1 #199 SYSCALL 2DROP ;P ( don't want error )

: ?NPIPE ( err -- )
	?DUP IF CR ." error #" DUP DEC.
		PAD #256 ROT ERROR>TEXT IF 2DROP ELSE TYPE ENDIF
		ABORT
	  ENDIF ;

\ The new server talks to clients via the returned handle.
\ The server resides on the local machine: S" //./pipe/forthserver" create-named-pipe
\ /queue is the maximum number of clients that will be put on hold.
: CREATE-NAMED-PIPE  ( c-addr u /queue -- handle )
	3 #230 SYSCALL ?NPIPE ;

\ CONNECT-NAMED-PIPE? tests if a client is available.
\ Because of non-blocking, NT returns immediately with result 0, error=ERROR_PIPE_CONNECTED ( 6 ) 
\ The write-named-pipe call fails because the client has not even started.
\ This is a bug in my understanding how this is supposed to work. 
\ The problem is likely in the attributes of CREATE-NAMED-PIPE .
CR .( FIXME: hold back the server until the client has started up! )
: CONNECT-NAMED-PIPE? ( handle -- bool )
	1 #231 SYSCALL DROP ;

\ This call blocks the server until a client appears.
: ACCEPT-CLIENT ( handle -- )
	DUP disconnect 
	BEGIN  DUP connect-named-pipe? 
		\ 0=
		EKEY? IF  EKEY 2DROP FALSE  ENDIF ( press key once client has started )
	WHILE  #100 MS
	REPEAT DROP ;

LINUX? 
  [IF]
	\ CLOSE-NAMED-PIPE closes the connection to a client, not the 
	\ %connector handle. This is a bug, to make Linux and NT compatible.
	
-1 VALUE %connector
: CREATE&ACCEPT ( c-addr u /queue -- handle )
	3 #230 SYSCALL ?NPIPE DUP TO %connector 
	1 #231 SYSCALL ?NPIPE ;

[ELSE]

: CREATE&ACCEPT ( c-addr u /queue -- handle )
	CREATE-NAMED-PIPE DUP ACCEPT-CLIENT ;
	
[THEN]

\ The named pipe can be located anywhere on the network, example:
\   S" //pigsandponies/pipe/forthserver" open-named-pipe
\ A time out is possible.
: OPEN-NAMED-PIPE  ( c-addr u timeout -- handle )
	3 #232 SYSCALL ?NPIPE ;

\ Linux could have tested for further connections on %connector,
\ however NT can't do this ?!
: CLOSE-NAMED-PIPE  ( handle -- )
	1 #235 SYSCALL DROP ?NPIPE 
[ LINUX? ] [IF] %connector 1 #235 SYSCALL DROP ?NPIPE 
	 [THEN]	;

\ iForth's named pipes are non-blocking.
\ NT's pipes can have an ERROR_NO_DATA == 232 error.
: (RNP) ( c-addr u handle -- size )
	3 #233 SYSCALL
	DUP #232 = IF 2DROP 0
		 ELSE ?NPIPE
		ENDIF ;P

: READ-NAMED-PIPE  ( c-addr u handle -- size )
	DUP >R ['] (RNP) CATCH ?DUP IF R> 1 #235 SYSCALL 2DROP
				       CR ." read-named-pipe fail" THROW
				  ELSE -R
			    	 ENDIF ;

\ This one is also non-blocking.
\ A size of 64000 is about the maximum Windows NT will handle (because of NOWAIT?)
\ Writes 15 Mb/sec interprocess, 712 Kb/sec over the network (10Mb/s card, P166)
: (WNP) ( c-addr u handle -- )
	LOCALS| handle sz buf |
	BEGIN
	  buf sz #64000 UMIN handle 3 #234 SYSCALL ?NPIPE ( written)
	  DUP +TO buf  NEGATE +TO sz
	  sz 0=
	UNTIL ;P

: WRITE-NAMED-PIPE  ( c-addr u handle -- )
	DUP >R ['] (WNP) CATCH ?DUP IF R> 1 #235 SYSCALL 2DROP
				       CR ." write-named-pipe fail" THROW
				  ELSE -R
			    	 ENDIF ;

\ There is a time out of 10 seconds (arbitrary, change if you like).
\ Reads 15 Mb/sec interprocess, 712 Kb/sec over the network (10Mb/s card, P166)
: READ-NAMED-PIPEX ( c-addr size handle -- c-addr size )
	0 0 ?MS #10000 +  LOCALS| tmr %read sz handle maxlen addr |
	 BEGIN  addr maxlen handle READ-NAMED-PIPE DUP TO %read
		      IF ( read some, reset timer and read more)
		         ?MS #10000 + TO tmr  TRUE
		    ELSE ( no bytes at all, try again unless time out)
			 tmr ?MS U>
		   ENDIF
	 WHILE  %read +TO sz  %read +TO addr  %read NEGATE +TO maxlen
	        maxlen 0<=
	 ?REPEATED
	?MS tmr U> IF handle CLOSE-NAMED-PIPE 1 ABORT" read-named-pipex :: time out" ENDIF
	addr sz - sz ;

[DEFINED] ltesting [IF]

:ABOUT	CR ." cliserv2.frt contains a complete client-server example" ;

        	.ABOUT -npipes CR
[THEN]

		DEPRIVE

                              (* End of Source *)