ZISTCP.m

%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       ;