%ZISTCPS ;ISF/RWF - DEVICE HANDLER TCP/IP SERVER CALLS ;06/20/2005 09:11
;;8.0;KERNEL;**78,118,127,225,275,388**;Jul 10, 1995
Q
;
CLOSE ;Close and reset
G CLOSE^%ZISTCP
Q
;
;In ZRULE, set ZISQUIT=1 to quit
LISTEN(SOCK,RTN,ZRULE) ;Listen on socket, start routine
N %A,ZISOS,X,NIO,EXIT
N $ES,$ET S $ETRAP="D OPNERR^%ZISTCPS"
S ZISOS=^%ZOSF("OS"),ZRULE=$G(ZRULE)
S POP=1
D GETENV^%ZOSV S U="^",XUENV=Y,XQVOL=$P(Y,U,2)
S POP=1 D LONT:ZISOS["OpenM",LGTM:ZISOS["GT.M"
I 'POP C NIO ;Close port
Q
;
;
LONT ;Open port in Accept mode with standard terminators.
N %ZA,NEWCHAR
S NIO="|TCP|"_SOCK,EXIT=0
;(adr:sock:term:ibuf:obuf:queue)
O NIO:(:SOCK:"AT"::512:512:10):30 Q:'$T S POP=0 U NIO
;Wait on read for a connect
LONT2 F U NIO R *NEWCHAR:30 S EXIT=$$EXIT Q:$T!EXIT
I EXIT C NIO Q
;JOB params (:Concurrent Server bit:principal input:principal output)
J CHILDONT^%ZISTCPS(NIO,RTN):(:16::):10 S %ZA=$ZA
I %ZA\8196#2=1 W *-2 ;Job failed to clear bit
G LONT2
;
CHILDONT(IO,RTN) ;Child process for OpenM
S $ETRAP="D ^%ZTER L HALT",IO=$ZU(53)
U IO:(::"-M") ;Work like DSM
S NEWJOB=$$NEWOK
I 'NEWJOB W "421 Service temporarily down.",$C(13,10),!
I NEWJOB K NEWJOB D VAR,@RTN
HALT
;
VAR ;Setup IO variables
S IO(0)=IO,IO(1,IO)="",POP=0
S IOT="TCP",IOST="P-TCP",IOST(0)=0
S IOF=$$FLUSHCHR^%ZISTCP
S ^XUTL("XQ",$J,0)=$$DT^XLFDT
Q
NEWOK() ;Is it OK to start a new process
I $G(^%ZIS(14.5,"LOGON",^%ZOSF("VOL"))) Q 0
I $$AVJ^%ZOSV()<3 Q 0
Q 1
OPNERR ;
S POP=1,EXIT=1,IO("ERROR")=$ECODE,$ECODE=""
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
;
LGTM ;GT.M multi 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
LG2 S %A=0,EXIT=0 F D Q:%A!EXIT
. W /WAIT(30) ;Wait for connect
. I $P($KEY,"|",1)="CONNECT" S NIO("ZISTCP",2)=$KEY,%A=1
. S EXIT=$$EXIT
. Q
I EXIT C NIO Q
;
S NIO("SOCK")=$P($G(NIO("ZISTCP",2)),"|",2)
D LOG("Got connection on "_NIO("SOCK"))
I '$$NEWOK D G LG2
. U NIO:(SOCKET=NIO("SOCK")) W "421 Service temporarily down.",$C(13,10),#
. C NIO:(SOCKET=NIO("SOCK")) K NIO("ZISTCP",2)
. Q
;Close the main socket
C NIO:(SOCKET="listener")
;Start a new listener
J LISTEN^%ZISTCPS(SOCK,RTN,ZRULE)
;Use the new socket
;U NIO:(SOCKET=NIO("SOCK"):WIDTH=512:NOWRAP:IOERROR="TRAP")
U NIO:(SOCKET=NIO("SOCK"):WIDTH=512:NOWRAP)
;Run the job
D GTMLNCH(NIO,RTN)
S POP=0
Q
;
GTMLNCH(IO,RTN) ;Run gt.m job for this conncetion.
N NIO,SOCK,ZISOS,EXIT,XQVOL,$ETRAP
S U="^",$ETRAP="D ^%ZTER L HALT"
S IO(0)=IO,IO(1,IO)=""
D VAR,@RTN
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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HZISTCPS 3260 printed Mar 13, 2025@21:20:11 Page 2
%ZISTCPS ;ISF/RWF - DEVICE HANDLER TCP/IP SERVER CALLS ;06/20/2005 09:11
+1 ;;8.0;KERNEL;**78,118,127,225,275,388**;Jul 10, 1995
+2 QUIT
+3 ;
CLOSE ;Close and reset
+1 GOTO CLOSE^%ZISTCP
+2 QUIT
+3 ;
+4 ;In ZRULE, set ZISQUIT=1 to quit
LISTEN(SOCK,RTN,ZRULE) ;Listen on socket, start routine
+1 NEW %A,ZISOS,X,NIO,EXIT
+2 NEW $ESTACK,$ETRAP
SET $ETRAP="D OPNERR^%ZISTCPS"
+3 SET ZISOS=^%ZOSF("OS")
SET ZRULE=$GET(ZRULE)
+4 SET POP=1
+5 DO GETENV^%ZOSV
SET U="^"
SET XUENV=Y
SET XQVOL=$PIECE(Y,U,2)
+6 SET POP=1
if ZISOS["OpenM"
DO LONT
if ZISOS["GT.M"
DO LGTM
+7 ;Close port
IF 'POP
CLOSE NIO
+8 QUIT
+9 ;
+10 ;
LONT ;Open port in Accept mode with standard terminators.
+1 NEW %ZA,NEWCHAR
+2 SET NIO="|TCP|"_SOCK
SET EXIT=0
+3 ;(adr:sock:term:ibuf:obuf:queue)
+4 OPEN NIO:(:SOCK:"AT"::512:512:10):30
if '$TEST
QUIT
SET POP=0
USE NIO
+5 ;Wait on read for a connect
LONT2 FOR
USE NIO
READ *NEWCHAR:30
SET EXIT=$$EXIT
if $TEST!EXIT
QUIT
+1 IF EXIT
CLOSE NIO
QUIT
+2 ;JOB params (:Concurrent Server bit:principal input:principal output)
+3 JOB CHILDONT^%ZISTCPS(NIO,RTN):(:16::):10
SET %ZA=$ZA
+4 ;Job failed to clear bit
IF %ZA\8196#2=1
WRITE *-2
+5 GOTO LONT2
+6 ;
CHILDONT(IO,RTN) ;Child process for OpenM
+1 SET $ETRAP="D ^%ZTER L HALT"
SET IO=$ZU(53)
+2 ;Work like DSM
USE IO:(::"-M")
+3 SET NEWJOB=$$NEWOK
+4 IF 'NEWJOB
WRITE "421 Service temporarily down.",$CHAR(13,10),!
+5 IF NEWJOB
KILL NEWJOB
DO VAR
DO @RTN
+6 HALT
+7 ;
VAR ;Setup IO variables
+1 SET IO(0)=IO
SET IO(1,IO)=""
SET POP=0
+2 SET IOT="TCP"
SET IOST="P-TCP"
SET IOST(0)=0
+3 SET IOF=$$FLUSHCHR^%ZISTCP
+4 SET ^XUTL("XQ",$JOB,0)=$$DT^XLFDT
+5 QUIT
NEWOK() ;Is it OK to start a new process
+1 IF $GET(^%ZIS(14.5,"LOGON",^%ZOSF("VOL")))
QUIT 0
+2 IF $$AVJ^%ZOSV()<3
QUIT 0
+3 QUIT 1
OPNERR ;
+1 SET POP=1
SET EXIT=1
SET IO("ERROR")=$ECODE
SET $ECODE=""
+2 QUIT
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 ;
LGTM ;GT.M multi thread server
+1 NEW %A
KILL ^TMP("ZISTCP",$JOB)
+2 SET $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
LG2 SET %A=0
SET EXIT=0
FOR
Begin DoDot:1
+1 ;Wait for connect
WRITE /WAIT(30)
+2 IF $PIECE($KEY,"|",1)="CONNECT"
SET NIO("ZISTCP",2)=$KEY
SET %A=1
+3 SET EXIT=$$EXIT
+4 QUIT
End DoDot:1
if %A!EXIT
QUIT
+5 IF EXIT
CLOSE NIO
QUIT
+6 ;
+7 SET NIO("SOCK")=$PIECE($GET(NIO("ZISTCP",2)),"|",2)
+8 DO LOG("Got connection on "_NIO("SOCK"))
+9 IF '$$NEWOK
Begin DoDot:1
+10 USE NIO:(SOCKET=NIO("SOCK"))
WRITE "421 Service temporarily down.",$CHAR(13,10),#
+11 CLOSE NIO:(SOCKET=NIO("SOCK"))
KILL NIO("ZISTCP",2)
+12 QUIT
End DoDot:1
GOTO LG2
+13 ;Close the main socket
+14 CLOSE NIO:(SOCKET="listener")
+15 ;Start a new listener
+16 JOB LISTEN^%ZISTCPS(SOCK,RTN,ZRULE)
+17 ;Use the new socket
+18 ;U NIO:(SOCKET=NIO("SOCK"):WIDTH=512:NOWRAP:IOERROR="TRAP")
+19 USE NIO:(SOCKET=NIO("SOCK"):WIDTH=512:NOWRAP)
+20 ;Run the job
+21 DO GTMLNCH(NIO,RTN)
+22 SET POP=0
+23 QUIT
+24 ;
GTMLNCH(IO,RTN) ;Run gt.m job for this conncetion.
+1 NEW NIO,SOCK,ZISOS,EXIT,XQVOL,$ETRAP
+2 SET U="^"
SET $ETRAP="D ^%ZTER L HALT"
+3 SET IO(0)=IO
SET IO(1,IO)=""
+4 DO VAR
DO @RTN
+5 ;Use IO("C") to quit server
QUIT $DATA(IO("C"))
+6 ;
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 ;
