(* * LANGUAGE : ANS Forth * PROJECT : Forth Environments * DESCRIPTION : Sockets * CATEGORY : Tools * AUTHOR : Marcel Hendrix * LAST CHANGE : Sunday, December 22, 2002 7:28 PM, mhx; (RLS), read-line functionality added * LAST CHANGE : Wednesday, December 18, 2002 1:18 PM, mhx; GET/SET-SOCKET-TIMEOUT value '0' no error in (RS) * LAST CHANGE : Sunday, December 15, 2002 9:19 PM, mhx; GET/SET-SOCKET-TIMEOUT special value '0' for telnet * LAST CHANGE : Saturday, September 14, 2002 11:07 PM, mhx; added GET/SET-SOCKET-TIMEOUT * LAST CHANGE : October 20, 1997, mhx; CATCH, bug in READ-SOCKET over real network * LAST CHANGE : October 17, 1997, mhx; found bug in READ-SOCKET, Linux worked too well.. * LAST CHANGE : October 16, 1997, Marcel Hendrix; added listen and accept-socket * LAST CHANGE : September 28, 1997, Marcel Hendrix; FINGER worked. * LAST CHANGE : September 21, 1997, Marcel Hendrix *) MS-DOS? [IF] CR .( MS-DOS not supported ) ABORT [THEN] REVISION -sockets "ÄÄÄ Socket interface Version 1.09 ÄÄÄ" PRIVATES DOC (* Open the FINGER server at my ISP (79 is the defined port# for finger, for Linux I used s" iaehv.iaehv.nl"): s" iaehv.iaehv.nl" 79 open-service =: FINGER s" mhx" +cr FINGER write-socket FINGER pad 1024 read-socket CR type FINGER close-socket Or (Linux see above): s" iaehv.nl" 80 open-service =: WWW s" GET /users/mhx/mxforth.html" +cr WWW write-socket WWW pad 40000 read-socket CR type WWW close-socket Note that READ-FILE, WRITE-FILE and CLOSE-FILE are illegal, you have to use READ-SOCKET WRITE-SOCKET and CLOSE-SOCKET. This is a deficiency of Winsock. For Linux the *-FILE words will work instead of the *-SOCKET ones, but please don't do it for code compatibility's sake. Try the cliserv.frt file (Skip Carter) for a server example. BUGS: Linux: It is sometimes very difficult to use a port# for the second time (error #98, address already in use). Keep trying. Maybe the threads.frt file uses these call better! # # services This file describes the various services that are # available from the TCP/IP subsystem. It should be # consulted instead of using the numbers in the ARPA # include files, or, worse, just guessing them. # # Version: @(#)/etc/services 3.02 02/21/93 # # Author: Fred N. van Kempen, # tcpmux 1/tcp # rfc-1078 echo 7/tcp echo 7/udp discard 9/tcp sink null discard 9/udp sink null systat 11/tcp users daytime 13/tcp daytime 13/udp netstat 15/tcp qotd 17/tcp quote chargen 19/tcp ttytst source chargen 19/udp ttytst source ftp-data 20/tcp ftp 21/tcp telnet 23/tcp smtp 25/tcp mail time 37/tcp timserver time 37/udp timserver rlp 39/udp resource # resource location name 42/udp nameserver whois 43/tcp nicname # usually to sri-nic domain 53/tcp domain 53/udp mtp 57/tcp # deprecated bootps 67/udp # bootp server bootpc 68/udp # bootp client tftp 69/udp rje 77/tcp finger 79/tcp link 87/tcp ttylink supdup 95/tcp # BSD supdupd(8) hostnames 101/tcp hostname # usually to sri-nic iso-tsap 102/tcp x400 103/tcp # ISO Mail x400-snd 104/tcp csnet-ns 105/tcp pop-2 109/tcp # PostOffice V.2 pop-3 110/tcp # PostOffice V.3 sunrpc 111/tcp sunrpc 111/tcp portmapper # RPC 4.0 portmapper UDP sunrpc 111/udp sunrpc 111/udp portmapper # RPC 4.0 portmapper TCP ident 113/tcp auth tap # identd sftp 115/tcp uucp-path 117/tcp nntp 119/tcp usenet # Network News Transfer ntp 123/tcp # Network Time Protocol ntp 123/udp # Network Time Protocol netbios-ns 137/tcp nbns netbios-ns 137/udp nbns netbios-dgm 138/tcp nbdgm netbios-dgm 138/udp nbdgm netbios-ssn 139/tcp nbssn NeWS 144/tcp news # Window System snmp 161/udp snmp-trap 162/udp exec 512/tcp # BSD rexecd(8) biff 512/udp comsat login 513/tcp # BSD rlogind(8) who 513/udp whod # BSD rwhod(8) shell 514/tcp cmd # BSD rshd(8) syslog 514/udp # BSD syslogd(8) printer 515/tcp spooler # BSD lpd(8) talk 517/udp # BSD talkd(8) ntalk 518/udp # SunOS talkd(8) efs 520/tcp # for LucasFilm route 520/udp router routed # 521/udp too timed 525/udp timeserver tempo 526/tcp newdate courier 530/tcp rpc # experimental conference 531/tcp chat netnews 532/tcp readnews netwall 533/udp # -for emergency broadcasts uucp 540/tcp uucpd # BSD uucpd(8) UUCP service new-rwho 550/udp new-who # experimental remotefs 556/tcp rfs_server rfs # Brunhoff remote filesystem rmonitor 560/udp rmonitord # experimental monitor 561/udp # experimental pcserver 600/tcp # ECD Integrated PC board srvr mount 635/udp # NFS Mount Service pcnfs 640/udp # PC-NFS DOS Authentication bwnfs 650/udp # BW-NFS DOS Authentication listen 1025/tcp listener RFS remote_file_sharing nterm 1026/tcp remote_login network_terminal ingreslock 1524/tcp tnet 1600/tcp # transputer net daemon nfs 2049/udp # NFS File Service irc 6667/tcp # Internet Relay Chat dos 7000/tcp msdos *) ENDDOC CREATE CRLF 2 C, ^M C, ^J C, -- +CR appends a crlf to the string at the address. -- This is the standard telnet default line termination. : +CR ( c-addr u -- c-addr2 u2 ) CRLF COUNT $+ ; LINUX? [IF] #11 [ELSE] #10035 [THEN] =: EWOULDBLOCK -- means that the call would have blocked were BLOCKING-MODE not false : ?SOCKET ( err -- ) ?DUP IF DUP CR ." error #" DEC. 1 #220 SYSCALL TYPE ABORT ENDIF ;P CREATE $hostname #128 ALLOT : HOSTNAME ( -- c-addr u ) $hostname #128 2 #221 SYSCALL ?SOCKET $hostname SWAP ; : OPEN-SERVICE ( c-addr u port# -- socket ) 3 #223 SYSCALL ?SOCKET ; -- The new server listens for clients on the returned socket : CREATE-SERVER ( port# -- lsocket ) 1 #222 SYSCALL ?SOCKET ; -- /queue is the maximum number of clients that will be put on hold -- After LISTEN the server is ready to serve clients : LISTEN ( lsocket /queue -- ) 2 #228 SYSCALL DROP ?SOCKET ; -- This call blocks the server until a client appears. The client uses socket to -- converse with the server. : ACCEPT-SOCKET ( lsocket -- socket ) 1 #229 SYSCALL ?SOCKET ; : CLOSE-SOCKET ( socket -- ) 1 #227 SYSCALL NIP ?SOCKET ; -- Linux doesn't like non-blocking (or gets confused). : BLOCKING-MODE ( socket on/off -- ) [ LINUX? ] [IF] 2DROP [ELSE] 0= 2 #225 SYSCALL NIP ?SOCKET [THEN] ; -- No time out, assume a socket will accept the data immediately. -- Doesn't seem to have a size limitation. -- Writes around 37Mb/sec over a real network (10Mb card, P166), and 24 MB/sec between processes. -- (this is undoubtedly a function of the available memory in the sending machine). : BWRITE-SOCKET ( c-addr size socket -- ior ) -ROT 3 #226 SYSCALL NIP ; : (WS) ( c-addr size socket -- ) BWRITE-SOCKET ?SOCKET ;P : WRITE-SOCKET ( c-addr size socket -- ) DUP >R ['] (WS) CATCH ?DUP IF R> 1 #227 SYSCALL 2DROP ( close socket ) THROW ELSE -R ENDIF ; -- Read-socket may not return all available data at once. -- There is a time out of 10 seconds. -- Reads around 1Mb/sec over a real network (10Mb card, P166), and 5 MB/sec between processes. : BREAD-SOCKET ( socket c-addr u -- ior ) 3 #224 SYSCALL NIP ; -- Interactive mode: set time out of 0 ms. If timeout is 0 ms a size of 0 is possible. #2000 VALUE socket_time_out PRIVATE : SET-SOCKET-TIMEOUT ( u -- ) TO socket_time_out ; : GET-SOCKET-TIMEOUT ( -- u ) socket_time_out ; -- EWOULDBLOCK doesn't work under/confuses Windows? : (RS) ( socket c-addr maxlen -- c-addr size ) 0 0 ?MS GET-SOCKET-TIMEOUT + LOCALS| tmr %read sz maxlen addr socket | socket FALSE BLOCKING-MODE BEGIN socket addr maxlen 3 #224 SYSCALL SWAP TO %read DUP EWOULDBLOCK = IF DROP tmr ?MS U> ELSE ?SOCKET %read IF ( read some, reset timer and read more) ?MS GET-SOCKET-TIMEOUT + TO tmr TRUE ELSE ( no bytes at all, try again unless time out) tmr ?MS U> ENDIF ENDIF WHILE %read +TO sz %read +TO addr %read NEGATE +TO maxlen maxlen 0<= ?REPEATED socket TRUE BLOCKING-MODE addr sz - sz ;P : READ-SOCKET ( socket c-addr maxlen -- c-addr size ) 2 PICK >R ['] (RS) CATCH ?DUP IF R> 1 #227 SYSCALL 2DROP ( close-socket ) THROW ELSE -R ENDIF ; ?DEF testing [IF] -- FRUNOBULAX is the name of my main PC. (The other one is PIGSANDPONIES) -- This works under NT, not under Linux. Not tried on my ISP. : .QUOTE ( -- ) S" frunobulax" #17 open-service ( -- socket ) DUP PAD #2000 read-socket CR TYPE close-socket ; -- Works everywhere : .TIME-OF-DAY ( -- ) S" frunobulax" #13 open-service ( -- socket ) DUP PAD #2000 read-socket CR TYPE close-socket ; -- Works on Linux and ISP : .FINGER-ME ( -- ) S" iae.nl" #79 open-service LOCAL FINGER S" mhx" +cr FINGER write-socket FINGER pad 1024 read-socket CR type FINGER close-socket ; -- Note the _double_ CRLF, without it it won't work (under Linux). -- Try: S" /users/mhx/mxforth.html" TEST-GET -- I got 5760 bytes/sec with a 31K0 modem connection (NT), 2900 bytes/sec with Linux. -- (NT enables compression behind the scenes?) : TEST-GET ( c-addr u -- ) S" iae.nl" #80 open-service LOCAL WWW S" GET " 2SWAP $+ S" HTTP/1.0" $+ +cr +cr WWW write-socket ?MS >R WWW pad UNUSED read-socket ( addr size ) NIP #1000 * ?MS R> - 1 MAX / DEC. ." bytes/sec." WWW close-socket ; CREATE _tempbuf_ #128 CHARS ALLOT -- Try: S" sockets.frt" S" /pub/users/mhx/socks" TEST-PUT -- This doesn't work, because the protocol is violated or because a WWW server doesn't allow PUT? : TEST-PUT ( c-addr1 u1 c-addr2 u2 -- ) S" iae.nl" #80 open-service LOCAL WWW S" PUT " 2SWAP $+ S" HTTP/1.0" $+ +CR +CR 2DUP CR TYPE WWW write-socket WWW pad UNUSED read-socket CR TYPE _tempbuf_ PACK COUNT R/O BIN OPEN-FILE ?FILE >R PAD UNUSED R@ READ-FILE ?FILE ( count ) LOCAL size R> CLOSE-FILE ?FILE ?MS >R pad size WWW write-socket size #1000 * ?MS R> - 1 MAX / DEC. ." bytes/sec." WWW close-socket ; :ABOUT CR ." Try: hostname type" CR ." .quote" CR ." .time-of-day" CR .~ S" iae.nl" #79 open-service constant finger~ CR .~ S" mhx" +cr finger write-socket~ CR .~ finger pad 1024 read-socket cr type~ CR ." finger close-socket" CR CR ." Note: Perform the write/read on the same line or you may miss the response" CR ." Note: cliserv.frt contains a complete client-server example" CR ." Note: Some more internet examples in /dfwforth/examples/internet" ; .ABOUT -sockets CR [THEN] DEPRIVE (* End of Source *)