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