%ZISTCP ;ISC/RWF,ISD/HGW - DEVICE HANDLER TCP/IP CALLS ;07/11/14 11:37
;;8.0;KERNEL;**36,34,59,69,118,225,275,638**;Jul 10, 1995;Build 16
;Per VA Directive 6402, this routine should not be modified.
Q
;
CALL(IP,SOCK,TO) ;Open a socket to the IP address <procedure>
N %A,ZISOS,X,NIO
S ZISOS=^%ZOSF("OS"),TO=$G(TO,30)
N $ETRAP S $ETRAP="G OPNERR^%ZISTCP"
S POP=1
I '$$VALIDATE^XLFIPV(IP) S IP=$$ADDRESS^XLFNSLK(IP) ;Lookup the name
I '$$VALIDATE^XLFIPV(IP) Q ;Not in the IP format
I (SOCK<1)!(SOCK>65535) Q
G CVXD:ZISOS["VAX",CONT:ZISOS["OpenM",CGTM:ZISOS["GT.M",CMSM:ZISOS["MSM"
S POP=1
Q
CVXD ;Open VAX DSM Socket
S NIO=SOCK
O NIO:(TCPCHAN,ADDRESS=IP):TO G:'$T NOOPN
U NIO:NOECHO D VAR(NIO)
Q
CMSM ;Open MSM Socket
S NIO=56 O NIO::TO G:'$T NOOPN
U NIO::"TCP" W /SOCKET(IP,SOCK) I $KEY="" C NIO G NOOPN
D VAR(NIO)
Q
CONT ;Open OpenM socket
I $$VERSION^%ZOSV'<5 S %A=$ZUTIL(68,55,1)
S NIO="|TCP|"_SOCK
;p638 If IP contains ".", use IPv4 IP address (may be IPv4-mapped, so convert)
; Else use IPv6 address
I IP["." D
. O NIO:($$FORCEIP4^XLFIPV(IP):SOCK:"-M"::512:512):TO G:'$T NOOPN
E D
. O NIO:("["_IP_"]":SOCK:"-M"::512:512):TO G:'$T NOOPN
U NIO D VAR(NIO)
Q
CGTM ;Open GT.M Socket
S NIO="SCK$"_$P($H,",",2) ;Just needs to be unique for job
O NIO:(CONNECT=IP_":"_SOCK_":TCP":ATTACH="client"):TO:"SOCKET"
I '$T S POP=1 Q
U NIO S NIO("KEY")=$KEY
S NIO("SOCKET")=$P(NIO("KEY"),"|",2)
I $P(NIO("KEY"),"|")'="ESTABLISHED" D LOG("** ="_NIO("KEY")_"= **") W 1/0 ; PROTOCOL ERROR
;U NIO:(SOCKET=NIO("SOCKET"):WIDTH=512:NOWRAP:IOERROR="TRAP":EXCEPT="G GTMERR^%ZISTCP")
U NIO:(SOCKET=NIO("SOCKET"):WIDTH=512:NOWRAP:EXCEPT="G GTMERR^%ZISTCP")
D VAR(NIO) S IOF="#" ;Set buffer flush
Q
VAR(%IO) ;Setup IO variables
S:'$D(IO(0)) IO(0)=$I
S IO=%IO,IO(1,IO)=$G(IP),POP=0
;Set IOF to the normal buffer flush. W @IOF.
S IOT="TCP",IOST="P-TCP",IOST(0)=0
S IOF=$$FLUSHCHR
Q
NOOPN ;Didn't make the conection
S POP=1
Q
OPNERR ;
;D ^%ZTER
S POP=1
D ERRCLR
Q
UCXOPEN(NIO) ;This call only applies to SERVER jobs tied to UCX/VMS
N $ETRAP,%ZISV,%ZISOS S $ETRAP="G OPNERR^%ZISTCP"
S %ZISV=$$VERSION^%ZOSV,%ZISOS=^%ZOSF("OS"),POP=1
I %ZISOS["DSM",%ZISV<7 O NIO:(SHARE):5 D:$T VAR(NIO)
I %ZISOS["DSM",%ZISV'<7 S NIO="SYS$NET" O NIO:(TCPDEV):5 D:$T VAR(NIO)
Q
CLOSE ;Close and reset
N NIO,$ETRAP S $ETRAP="G CLOSEX^%ZISTCP"
S NIO=IO,IO=$S($G(IO(0))]"":IO(0),1:$P)
I NIO]"" C NIO K IO(1,NIO) S IO("CLOSE")=NIO
CLOSEX D HOME^%ZIS
D ERRCLR
Q
ERRCLR ;
S:$ECODE]"" IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$ECODE,$ECODE=""
Q
;
FLUSHCHR() ;Return the value to write @ of to flush the TCP buffer
N OS S OS=$P(^%ZOSF("OS"),"^")
Q $S(OS["GT.M":"#",1:"!")
;
;In ZRULE, set ZISQUIT=1 to quit
LISTEN(SOCK,RTN,ZRULE) ;Listen on socket, run routine, single thread.
N %A,ZISOS,X,NIO,EXIT,IOF,IP
N $ES,$ET S $ET="D OPNERR^%ZISTCP"
S ZISOS=^%ZOSF("OS"),ZRULE=$G(ZRULE)
D GETENV^%ZOSV S U="^",XUENV=Y,XQVOL=$P(Y,U,2)
S POP=1
I $G(^%ZIS(14.5,"LOGON",XQVOL)) Q
LOOP S POP=1 D LVXD:ZISOS["DSM",LONT:ZISOS["OpenM",LGTM:ZISOS["GT.M",LMSM:ZISOS["MSM"
I POP Q ;Quit Server
S EXIT=0,EXIT=$$LAUNCH(NIO,RTN)
I $G(^%ZIS(14.5,"LOGON",XQVOL)) S EXIT=1
I ZISOS["DSM" X "U NIO:DISCONNECT"
E C NIO ;
Q:EXIT ;Quit server, App set IO("C"), Logon inhibit.
G LOOP
LMSM ;MSM
;For multi thread use MSM's MSERVER process.
;This is the listener for TCP connects.
S NIO=56 O NIO::30 Q:'$T S POP=0
U NIO::"TCP" W /SOCKET("",SOCK)
S POP=$$EXIT
Q
LONT ;Open port in Accept mode with standard terminators, standard buffers.
N %ZA,%ZB
S NIO="|TCP|"_SOCK,%A=0
;(adr:sock:term:ibuf:obuf:queue)
O NIO:(:SOCK:"AT"::512:512:3):30 Q:'$T S POP=0
;Wait on read for a connect
U NIO F D Q:%A!POP
. R *NEWCHAR:60 S %ZA=$ZA,%ZB=$ZB S:$T %A=1 Q:%A
. S POP=$$EXIT
I POP C NIO Q
U NIO:(::"-M") ;Work like DSM
Q
;
LVXD ;Open port and listen
;Use UCX for multiple listeners
S NIO=SOCK O NIO:(TCPCHAN):30 Q:'$T S POP=0
U NIO ;Let application wait at the read for a connect.
Q
;
LGTM ;GT.M single thread server
N %A K ^TMP("ZISTCP",$J)
;S $ZINTERRUPT="I $$JOBEXAM^ZU($ZPOSITION)"
S NIO="SCK$"_$S($J>86400:$J,1:84600+$J) ;Construct a dummy, but "unique" devicename for job
D LOG("Open for Listen "_NIO)
;Open the device
O NIO:(ZLISTEN=SOCK_":TCP":ATTACH="listener"):30:"SOCKET"
I '$T D LOG("Can't Open Socket: "_SOCK) Q
U NIO S NIO("ZISTCP",0)=$KEY D LOG("Have port.")
;Start Listening
W /LISTEN(1) S NIO("ZISTCP",1)=$KEY D LOG("Start Listening. "_NIO("ZISTCP",1))
;Wait for connection
S %A=0,POP=0 F D Q:%A!POP
. W /WAIT(30) ;Wait for connect
. I $P($KEY,"|",1)="CONNECT" S NIO("ZISTCP",2)=$KEY,%A=1
. S POP=$$EXIT
. Q
I POP C NIO Q
;
S NIO("SOCK")=$P($G(NIO("ZISTCP",2)),"|",2)
D LOG("Got connection on "_NIO("SOCK"))
;Close the main socket
C NIO:(SOCKET="listener")
;Use the new socket
;U NIO:(SOCKET=NIO("SOCK"):WIDTH=512:NOWRAP:IOERROR="TRAP":EXCEPT="G GTMERR^%ZISTCP")
U NIO:(SOCKET=NIO("SOCK"):WIDTH=512:NOWRAP:EXCEPT="G GTMERR^%ZISTCP")
S POP=0
Q
;
GTMERR ;The use will set this as a place to go on a IO error
S $ECODE=",U911,"
Q
;
EXIT() ;See if time to exit
I $$S^%ZTLOAD Q 1
N ZISQUIT S ZISQUIT=0
I $L(ZRULE) X ZRULE I $G(ZISQUIT) Q 1
Q 0
;
LAUNCH(IO,RTN) ;Run job for this connection.
N NIO,SOCK,EXIT,XQVOL
D VAR(IO)
S ^XUTL("XQ",$J,0)=$$DT^XLFDT
D LOG("Run "_RTN)
D @RTN
D LOG("Return from call, Exit="_$D(IO("C")))
Q $D(IO("C")) ;Use IO("C") to quit server
;
LOG(MSG) ;LOG STATUS
N CNT
S CNT=$G(^TMP("ZISTCP",$J))+1,^TMP("ZISTCP",$J)=CNT,^($J,CNT)=MSG
Q
;
%ZISTCP ;ISC/RWF,ISD/HGW - DEVICE HANDLER TCP/IP CALLS ;07/11/14 11:37
+1 ;;8.0;KERNEL;**36,34,59,69,118,225,275,638**;Jul 10, 1995;Build 16
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
CALL(IP,SOCK,TO) ;Open a socket to the IP address <procedure>
+1 NEW %A,ZISOS,X,NIO
+2 SET ZISOS=^%ZOSF("OS")
SET TO=$GET(TO,30)
+3 NEW $ETRAP
SET $ETRAP="G OPNERR^%ZISTCP"
+4 SET POP=1
+5 ;Lookup the name
IF '$$VALIDATE^XLFIPV(IP)
SET IP=$$ADDRESS^XLFNSLK(IP)
+6 ;Not in the IP format
IF '$$VALIDATE^XLFIPV(IP)
QUIT
+7 IF (SOCK<1)!(SOCK>65535)
QUIT
+8 IF ZISOS["VAX"
GOTO CVXD
IF ZISOS["OpenM"
GOTO CONT
IF ZISOS["GT.M"
GOTO CGTM
IF ZISOS["MSM"
GOTO CMSM
+9 SET POP=1
+10 QUIT
CVXD ;Open VAX DSM Socket
+1 SET NIO=SOCK
+2 OPEN NIO:(TCPCHAN,ADDRESS=IP):TO
IF '$TEST
GOTO NOOPN
+3 USE NIO:NOECHO
DO VAR(NIO)
+4 QUIT
CMSM ;Open MSM Socket
+1 SET NIO=56
OPEN NIO::TO
IF '$TEST
GOTO NOOPN
+2 USE NIO::"TCP"
WRITE /SOCKET(IP,SOCK)
IF $KEY=""
CLOSE NIO
GOTO NOOPN
+3 DO VAR(NIO)
+4 QUIT
CONT ;Open OpenM socket
+1 IF $$VERSION^%ZOSV'<5
SET %A=$ZUTIL(68,55,1)
+2 SET NIO="|TCP|"_SOCK
+3 ;p638 If IP contains ".", use IPv4 IP address (may be IPv4-mapped, so convert)
+4 ; Else use IPv6 address
+5 IF IP["."
Begin DoDot:1
+6 OPEN NIO:($$FORCEIP4^XLFIPV(IP):SOCK:"-M"::512:512):TO
IF '$TEST
GOTO NOOPN
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 OPEN NIO:("["_IP_"]":SOCK:"-M"::512:512):TO
IF '$TEST
GOTO NOOPN
End DoDot:1
+9 USE NIO
DO VAR(NIO)
+10 QUIT
CGTM ;Open GT.M Socket
+1 ;Just needs to be unique for job
SET NIO="SCK$"_$PIECE($HOROLOG,",",2)
+2 OPEN NIO:(CONNECT=IP_":"_SOCK_":TCP":ATTACH="client"):TO:"SOCKET"
+3 IF '$TEST
SET POP=1
QUIT
+4 USE NIO
SET NIO("KEY")=$KEY
+5 SET NIO("SOCKET")=$PIECE(NIO("KEY"),"|",2)
+6 ; PROTOCOL ERROR
IF $PIECE(NIO("KEY"),"|")'="ESTABLISHED"
DO LOG("** ="_NIO("KEY")_"= **")
WRITE 1/0
+7 ;U NIO:(SOCKET=NIO("SOCKET"):WIDTH=512:NOWRAP:IOERROR="TRAP":EXCEPT="G GTMERR^%ZISTCP")
+8 USE NIO:(SOCKET=NIO("SOCKET"):WIDTH=512:NOWRAP:EXCEPT="G GTMERR^%ZISTCP")
+9 ;Set buffer flush
DO VAR(NIO)
SET IOF="#"
+10 QUIT
VAR(%IO) ;Setup IO variables
+1 IF '$DATA(IO(0))
SET IO(0)=$IO
+2 SET IO=%IO
SET IO(1,IO)=$GET(IP)
SET POP=0
+3 ;Set IOF to the normal buffer flush. W @IOF.
+4 SET IOT="TCP"
SET IOST="P-TCP"
SET IOST(0)=0
+5 SET IOF=$$FLUSHCHR
+6 QUIT
NOOPN ;Didn't make the conection
+1 SET POP=1
+2 QUIT
OPNERR ;
+1 ;D ^%ZTER
+2 SET POP=1
+3 DO ERRCLR
+4 QUIT
UCXOPEN(NIO) ;This call only applies to SERVER jobs tied to UCX/VMS
+1 NEW $ETRAP,%ZISV,%ZISOS
SET $ETRAP="G OPNERR^%ZISTCP"
+2 SET %ZISV=$$VERSION^%ZOSV
SET %ZISOS=^%ZOSF("OS")
SET POP=1
+3 IF %ZISOS["DSM"
IF %ZISV<7
OPEN NIO:(SHARE):5
IF $TEST
DO VAR(NIO)
+4 IF %ZISOS["DSM"
IF %ZISV'<7
SET NIO="SYS$NET"
OPEN NIO:(TCPDEV):5
IF $TEST
DO VAR(NIO)
+5 QUIT
CLOSE ;Close and reset
+1 NEW NIO,$ETRAP
SET $ETRAP="G CLOSEX^%ZISTCP"
+2 SET NIO=IO
SET IO=$SELECT($GET(IO(0))]"":IO(0),1:$PRINCIPAL)
+3 IF NIO]""
CLOSE NIO
KILL IO(1,NIO)
SET IO("CLOSE")=NIO
CLOSEX DO HOME^%ZIS
+1 DO ERRCLR
+2 QUIT
ERRCLR ;
+1 IF $ECODE]""
SET IO("LASTERR")=$GET(IO("ERROR"))
SET IO("ERROR")=$ECODE
SET $ECODE=""
+2 QUIT
+3 ;
FLUSHCHR() ;Return the value to write @ of to flush the TCP buffer
+1 NEW OS
SET OS=$PIECE(^%ZOSF("OS"),"^")
+2 QUIT $SELECT(OS["GT.M":"#",1:"!")
+3 ;
+4 ;In ZRULE, set ZISQUIT=1 to quit
LISTEN(SOCK,RTN,ZRULE) ;Listen on socket, run routine, single thread.
+1 NEW %A,ZISOS,X,NIO,EXIT,IOF,IP
+2 NEW $ESTACK,$ETRAP
SET $ETRAP="D OPNERR^%ZISTCP"
+3 SET ZISOS=^%ZOSF("OS")
SET ZRULE=$GET(ZRULE)
+4 DO GETENV^%ZOSV
SET U="^"
SET XUENV=Y
SET XQVOL=$PIECE(Y,U,2)
+5 SET POP=1
+6 IF $GET(^%ZIS(14.5,"LOGON",XQVOL))
QUIT
LOOP SET POP=1
IF ZISOS["DSM"
DO LVXD
IF ZISOS["OpenM"
DO LONT
IF ZISOS["GT.M"
DO LGTM
IF ZISOS["MSM"
DO LMSM
+1 ;Quit Server
IF POP
QUIT
+2 SET EXIT=0
SET EXIT=$$LAUNCH(NIO,RTN)
+3 IF $GET(^%ZIS(14.5,"LOGON",XQVOL))
SET EXIT=1
+4 IF ZISOS["DSM"
XECUTE "U NIO:DISCONNECT"
+5 ;
IF '$TEST
CLOSE NIO
+6 ;Quit server, App set IO("C"), Logon inhibit.
IF EXIT
QUIT
+7 GOTO LOOP
LMSM ;MSM
+1 ;For multi thread use MSM's MSERVER process.
+2 ;This is the listener for TCP connects.
+3 SET NIO=56
OPEN NIO::30
IF '$TEST
QUIT
SET POP=0
+4 USE NIO::"TCP"
WRITE /SOCKET("",SOCK)
+5 SET POP=$$EXIT
+6 QUIT
LONT ;Open port in Accept mode with standard terminators, standard buffers.
+1 NEW %ZA,%ZB
+2 SET NIO="|TCP|"_SOCK
SET %A=0
+3 ;(adr:sock:term:ibuf:obuf:queue)
+4 OPEN NIO:(:SOCK:"AT"::512:512:3):30
IF '$TEST
QUIT
SET POP=0
+5 ;Wait on read for a connect
+6 USE NIO
FOR
Begin DoDot:1
+7 READ *NEWCHAR:60
SET %ZA=$ZA
SET %ZB=$ZB
IF $TEST
SET %A=1
IF %A
QUIT
+8 SET POP=$$EXIT
End DoDot:1
IF %A!POP
QUIT
+9 IF POP
CLOSE NIO
QUIT
+10 ;Work like DSM
USE NIO:(::"-M")
+11 QUIT
+12 ;
LVXD ;Open port and listen
+1 ;Use UCX for multiple listeners
+2 SET NIO=SOCK
OPEN NIO:(TCPCHAN):30
IF '$TEST
QUIT
SET POP=0
+3 ;Let application wait at the read for a connect.
USE NIO
+4 QUIT
+5 ;
LGTM ;GT.M single thread server
+1 NEW %A
KILL ^TMP("ZISTCP",$JOB)
+2 ;S $ZINTERRUPT="I $$JOBEXAM^ZU($ZPOSITION)"
+3 ;Construct a dummy, but "unique" devicename for job
SET NIO="SCK$"_$SELECT($JOB>86400:$JOB,1:84600+$JOB)
+4 DO LOG("Open for Listen "_NIO)
+5 ;Open the device
+6 OPEN NIO:(ZLISTEN=SOCK_":TCP":ATTACH="listener"):30:"SOCKET"
+7 IF '$TEST
DO LOG("Can't Open Socket: "_SOCK)
QUIT
+8 USE NIO
SET NIO("ZISTCP",0)=$KEY
DO LOG("Have port.")
+9 ;Start Listening
+10 WRITE /LISTEN(1)
SET NIO("ZISTCP",1)=$KEY
DO LOG("Start Listening. "_NIO("ZISTCP",1))
+11 ;Wait for connection
+12 SET %A=0
SET POP=0
FOR
Begin DoDot:1
+13 ;Wait for connect
WRITE /WAIT(30)
+14 IF $PIECE($KEY,"|",1)="CONNECT"
SET NIO("ZISTCP",2)=$KEY
SET %A=1
+15 SET POP=$$EXIT
+16 QUIT
End DoDot:1
IF %A!POP
QUIT
+17 IF POP
CLOSE NIO
QUIT
+18 ;
+19 SET NIO("SOCK")=$PIECE($GET(NIO("ZISTCP",2)),"|",2)
+20 DO LOG("Got connection on "_NIO("SOCK"))
+21 ;Close the main socket
+22 CLOSE NIO:(SOCKET="listener")
+23 ;Use the new socket
+24 ;U NIO:(SOCKET=NIO("SOCK"):WIDTH=512:NOWRAP:IOERROR="TRAP":EXCEPT="G GTMERR^%ZISTCP")
+25 USE NIO:(SOCKET=NIO("SOCK"):WIDTH=512:NOWRAP:EXCEPT="G GTMERR^%ZISTCP")
+26 SET POP=0
+27 QUIT
+28 ;
GTMERR ;The use will set this as a place to go on a IO error
+1 SET $ECODE=",U911,"
+2 QUIT
+3 ;
EXIT() ;See if time to exit
+1 IF $$S^%ZTLOAD
QUIT 1
+2 NEW ZISQUIT
SET ZISQUIT=0
+3 IF $LENGTH(ZRULE)
XECUTE ZRULE
IF $GET(ZISQUIT)
QUIT 1
+4 QUIT 0
+5 ;
LAUNCH(IO,RTN) ;Run job for this connection.
+1 NEW NIO,SOCK,EXIT,XQVOL
+2 DO VAR(IO)
+3 SET ^XUTL("XQ",$JOB,0)=$$DT^XLFDT
+4 DO LOG("Run "_RTN)
+5 DO @RTN
+6 DO LOG("Return from call, Exit="_$DATA(IO("C")))
+7 ;Use IO("C") to quit server
QUIT $DATA(IO("C"))
+8 ;
LOG(MSG) ;LOG STATUS
+1 NEW CNT
+2 SET CNT=$GET(^TMP("ZISTCP",$JOB))+1
SET ^TMP("ZISTCP",$JOB)=CNT
SET ^($JOB,CNT)=MSG
+3 QUIT
+4 ;
