CIANBLIS ;MSC/IND/DKM - MSC RPC Broker ;23-Mar-2011 18:36;PLS
;;1.1;CIA NETWORK COMPONENTS;**001007,001008**;Sep 18, 2007
;;Copyright 2000-2011, Medsphere Systems Corporation
;=================================================================
; Start listener process (primary and secondary)
; CIAPORT = Listener port
; CIAIP = IP address of client
; CIAMODE = Connection type:
; 0: primary listener - dispatches connections
; 1: secondary listener - services individual clients
; 2: secondary listener - concurrent mode
;
EN(CIAPORT,CIAIP,CIAMODE) ;PEP - See above
N CIAVER,CIAOS,CIATDEV,CIAQUIT,CIALN,CIAXUT,CIAUCI,CIARETRY,XWBOS,X,Y,$ET,$ES
D UCI^%ZOSV
S U="^",CIAUCI=$P(Y,","),CIAMODE=+$G(CIAMODE),CIAIP=$G(CIAIP),(CIAQUIT,CIARETRY)=0
D MONSTART^CIANBEVT ; Start background event monitor if not already running
S:'$G(CIAPORT) CIAPORT=9000 ; Default service port
Q:'$$STATE(1) ; Quit if listener already running
S Y=$G(^%ZOSF("OS")),(CIAOS,X)=0
F XWBOS="DSM","MSM","OpenM" S X=X+1 I Y[XWBOS S CIAOS=X Q
D:'CIAOS RAISE(15,Y)
D CLEANUP,STSAVE(0),NULLOPEN,STSAVE(1)
D:CIAMODE=1 LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1) ; Start RUM for Broker Handler
D CHPRN("CIA"_$S($L(CIAIP):$P(CIAIP,".",3,4)_":"_CIAPORT,1:CIAPORT)) ; Change process name
D LISTEN
D:CIAMODE=1 LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2) ; Stop RUM for handler
D:CIAQUIT>0!'CIAMODE STATE(0),STREST(1),^%ZISC,STREST(0),CLEANUP,LOGOUT^XUSRB:$G(DUZ)
I 'CIAMODE,'CIAQUIT J EN^CIANBLIS(CIAPORT) ; Restart primary listener after fatal error
Q
; Entry point for interactive debugging
DEBUG N CIAPORT,CIAIP
W !!,"Debug Mode Support",!!
S CIAIP=$$PMPT("Addr","Enter callback IP address.","127.0.0.1")
Q:U[CIAIP
S CIAPORT=$$PMPT("Port","Enter callback port.")
Q:U[CIAPORT
I $L($T(^%Serenji)),$$ASK^CIAU("Use Serenji Debugger","Y") D Q
.N SRJIP,SRJPORT
.S SRJIP=$$PMPT("Serenji Listener Addr","Enter Serenji listener address",CIAIP)
.Q:U[SRJIP
.S SRJPORT=$$PMPT("Serenji Listener Port","Enter Serenji listener port",4321)
.Q:U[SRJPORT
.D DEBUG^%Serenji("EN^CIANBLIS(CIAPORT,CIAIP,1)",SRJIP,SRJPORT)
W !
D EN(CIAPORT,CIAIP,1)
Q
PMPT(PMPT,HELP,DFLT) ;
N RET
PMPTX W PMPT,": ",$S($D(DFLT):DFLT_"// ",1:"")
R RET:$G(DTIME,30)
E S RET=U
I $D(DFLT),'$L(RET) S RET=DFLT W DFLT
W !
I RET["?" W !,HELP,!! G PMPTX
Q RET
; Entry point for MSERVER process (MSM only)
MSERVER D EN(%("PORT"),%("ADDRESS"),2)
Q
; Entry point for UCX process (DSM only)
USERVER D EN($P(%,":",2),$P(%,":"),2)
Q
; Start primary listener
START(CIAPORT) ;EP
D SSLIS(,CIAPORT,,1),CLEANUP^CIANBUTL
Q
; Stop primary or secondary listener
STOP(CIAPORT,CIAIP) ;EP
D SSLIS(.CIAIP,CIAPORT,,0)
Q
; Start all primary listeners
STARTALL ;PEP - see above
D SSALL(1)
Q
; Stop all primary listeners
STOPALL ;PEP - see above
D SSALL(0)
Q
; Start/stop all registered listeners
SSALL(SS,SL) ;
N IEN,X
S SL=$G(SL,$D(ZTQUEUED)),U="^"
F IEN=0:0 S IEN=$O(^CIANB(19941.22,IEN)) Q:'IEN S X=^(IEN,0) D
.I SS,$P(X,U,3) Q
.W:'SL !,$P(X,U),": "
.D SSLIS(,$P(X,U,2),$P(X,U,4),SS,SL)
Q
; Start/stop primary listener
SSLIS(CIAIP,CIAPORT,CIAUCI,SS,SL) ;
N CIALN,X,P1,P2,$ET
S SL=$G(SL,$D(ZTQUEUED))
S:'SL $ET="D SSERR^CIANBLIS"
S P1=$S(SS:"start",1:"stop"),P2=P1_$S(SS:"ed",1:"ped")
I $$STATE=SS W:'SL "Listener ",$S(SS:"already",1:"not")," running on port ",CIAPORT,!! Q
I 'SS S @$$LOCKNODE=1
E I $L($G(CIAUCI)) D
.J EN^CIANBLIS(CIAPORT)[CIAUCI]
E J EN^CIANBLIS(CIAPORT)
Q:SL
W "Waiting for listener to ",P1,"..."
F X=1:1:5 D
.H 2
.W "."
.S:$$STATE=SS X=99
I X<99 W "Listener failed to ",P1,!
E W "Listener ",P2," on port ",CIAPORT,!
Q
SSERR W:'$G(SL) "Listener failed to ",P1,": ",$$EC^%ZOSV,!
S $ET="D UNWIND^%ZTER"
Q
; Main loop
LISTEN N $ET,$ES
S $ET="D ETRAP1^CIANBLIS",CIARETRY=0,CIAQUIT='$$TCPOPEN
F Q:$$QUIT D
.N $ET,$ES
.S:$$DOACTION($S(CIAMODE=2&(CIAOS'=3):"C",CIAMODE:"DPQRSU",1:"C")) CIARETRY=0
D TCPCLOSE
Q
; Read action and params
; VAC = List of valid action codes
; Returns true if valid inputs
DOACTION(VAC) ;
N NM,SB,RT,VL,PR,CIA,ACT,SEQ,ARG,CIAERR,CIADATA,X
S CIAERR(0)=0
D TCPUSE
S X=$$TCPREAD(8,10)
Q:$E(X,1,5)'="{CIA}" 0
S ARG=0,CIA("EOD")=$A(X,6),SEQ=$E(X,7),ACT=$E(X,8)
F S NM=$$TCPREADL Q:'$L(NM) S PR=NM=+NM,RT=$S(PR:"P"_NM,1:"CIA("""_NM_"""") N:PR&'$D(ARG(NM)) @RT D
.S:PR ARG=$S(NM>ARG:NM,1:ARG),ARG(NM)=""
.S SB=$$TCPREADL,VL=$$TCPREADL
.I $L(SB) S RT=RT_$S(PR:"(",1:",")_SB_")"
.E S:'PR RT=RT_")"
.S @RT=VL
W SEQ
I '$$ERRCHK^CIANBACT(VAC'[ACT,9,ACT) D
.N $ET,$ES
.S $ET="D ETRAP2^CIANBLIS"
.D @("ACT"_ACT_"^CIANBACT")
I CIAERR(0) D
.D SNDERR
E I $D(CIADATA) D
.D REPLY(.CIADATA)
E D SNDEOD
D:'CIAMODE TCPREL
Q 1
; Cleanup environment
CLEANUP K ^TMP("CIANBRPC",$J),^TMP("CIANBLIS",$J),^XUTL("XQ",$J),@$$LOCKNODE
Q
; Returns true if listener should quit
QUIT() S:'CIAQUIT CIAQUIT=+$G(@$$LOCKNODE)
Q CIARETRY>5!CIAQUIT
; Save application state
STSAVE(ST) ;
D SAVE^XUS1
K ^TMP("CIANBLIS",$J,ST)
M ^TMP("CIANBLIS",$J,ST)=^XUTL("XQ",$J)
Q
; Restore application state
STREST(ST) ;
K ^XUTL("XQ",$J)
M ^XUTL("XQ",$J)=^TMP("CIANBLIS",$J,ST)
K IO
D RESETVAR^%ZIS
I ST,$D(IO)#2 D
.N $ET
.S $ET="S $EC="""" D NULLOPEN^CIANBLIS"
.U IO
Q
; Establish null device as default IO device
NULLOPEN N %ZIS,IOP,POP
S %ZIS="0H",IOP="NULL"
D ^%ZIS,RAISE(16):POP
U IO
Q
; Open TCP listener port
; Returns true if successful
TCPOPEN() ;
N POP
S POP=0
I CIAMODE=2 D
.S CIATDEV=$S(CIAOS=1:"SYS$NET",CIAOS=2:56,1:$P)
.I CIAOS=1 O CIATDEV:TCPDEV:5 S POP='$T
I CIAMODE=1 D
.D CALL^%ZISTCP(CIAIP,CIAPORT)
.Q:POP
.S CIATDEV=IO,IO(0)=IO
.D:$T(SHARELIC^%ZOSV)'="" SHARELIC^%ZOSV(1)
I 'CIAMODE D
.I CIAOS=1 D
..S CIATDEV=CIAPORT
..O CIATDEV:TCPCHAN:5
..S POP='$T
.I CIAOS=2 S CIATDEV=56
.I CIAOS=3 D
..S CIATDEV="|TCP|"_CIAPORT
..O CIATDEV:(:CIAPORT:"DS"):5
..S POP='$T
Q 'POP
; Use TCP listener port
TCPUSE I CIAOS=1 U CIATDEV Q
I CIAOS=2 D Q
.I CIAMODE U CIATDEV S:$ZC CIAQUIT=1 Q
.O CIATDEV
.U CIATDEV::"TCP"
.W /SOCKET("",CIAPORT)
I CIAOS=3 U CIATDEV
Q
; Close TCP listener port
TCPCLOSE C:$D(CIATDEV) CIATDEV
Q
; Release TCP port
TCPREL I CIAOS=1 U CIATDEV:DISCONNECT Q
I CIAOS=2 C CIATDEV Q
I CIAOS=3 W *-3,*-2
Q
; Read from listener port
TCPREAD(CNT,TMO) ;
N X,Y
S Y="",TMO=$G(TMO,60)
F Q:CNT'>0 D
.R X#CNT:TMO
.I '$L(X) S Y="",CNT=0 S:CIAMODE=2 CIARETRY=CIARETRY+.5
.E S Y=Y_X,CNT=CNT-$L(X)
Q Y
; Read byte from listener port
TCPREADB() ;
Q $A($$TCPREAD(1))
; Read length-prefixed data from input stream
TCPREADL() ;
N X,L,I,N
S X=$$TCPREADB
Q:X=CIA("EOD") ""
S N=X#16,X=$$TCPREAD(X\16),L=0
F I=1:1:$L(X) S L=L*256+$A(X,I)
Q $$TCPREAD(L*16+N)
; Raise an exception
RAISE(MSG,P1,P2) ;
D GETDLG^CIANBUTL(MSG,.MSG,.P1,.P2)
S $EC=MSG(1)
Q
; Communication error
ETRAP1 N ECSAV
S $ET="D UNWIND^CIANBLIS Q:$Q 0 Q",ECSAV=$EC,CIARETRY=CIARETRY+1
D:CIARETRY=1&(ECSAV'["READ") ^%ZTER
S $EC=ECSAV
Q
; Unwind stack
UNWIND Q:$ES>1
S $EC=""
Q
; Trapped error, send error info to client
ETRAP2 N ECSAV
S $ET="D UNWIND^CIANBLIS Q:$Q 0 Q",ECSAV=$$EC^%ZOSV,CIARETRY=CIARETRY+1
D:CIARETRY=1 ^%ZTER,ERRCHK^CIANBACT(1,1,ECSAV)
S $EC=ECSAV
Q
; Send a reply
REPLY(DATA,ACK) ;
D TCPUSE
W $C(+$G(ACK)),$G(DATA)
D SNDEOD
Q
; Send error information
SNDERR ;
N X
D TCPUSE
W $C(1)
D OUT^CIANBACT("CIAERR",1),SNDEOD
S CIAERR(0)=0
Q
; Send end of data byte if not already sent
SNDEOD I $D(CIA("EOD")) D
.D TCPUSE
.W $C(CIA("EOD")),!
.K CIA("EOD")
Q
; Lock/Unlock listener
; CIAACT: 1 = lock, 0 = unlock, missing = return status
; Returns true if locked, false if not.
STATE(CIAACT) ;
N RES,Y
S Y=$$LOCKNODE
I '$D(CIAACT) D
.L +@Y:0
.S RES='$T
.L:'RES -@Y
E I CIAACT D
.L +@Y:1
.S RES=$T
E D
.L -@Y
.S RES=0
Q:$Q RES
Q
; Get global reference for lock node
LOCKNODE(LN) ;
S:'$D(LN) LN=$NA(^[$G(CIAUCI)]XTMP("CIANBLIS",$G(CIAIP)_":"_CIAPORT_$S($G(CIAMODE)=2:":"_$J,1:"")))
Q:$Q LN
Q
; Change process name to X
CHPRN(X) D SETNM^%ZOSV($E(X,1,15))
Q
CIANBLIS ;MSC/IND/DKM - MSC RPC Broker ;23-Mar-2011 18:36;PLS
+1 ;;1.1;CIA NETWORK COMPONENTS;**001007,001008**;Sep 18, 2007
+2 ;;Copyright 2000-2011, Medsphere Systems Corporation
+3 ;=================================================================
+4 ; Start listener process (primary and secondary)
+5 ; CIAPORT = Listener port
+6 ; CIAIP = IP address of client
+7 ; CIAMODE = Connection type:
+8 ; 0: primary listener - dispatches connections
+9 ; 1: secondary listener - services individual clients
+10 ; 2: secondary listener - concurrent mode
+11 ;
EN(CIAPORT,CIAIP,CIAMODE) ;PEP - See above
+1 NEW CIAVER,CIAOS,CIATDEV,CIAQUIT,CIALN,CIAXUT,CIAUCI,CIARETRY,XWBOS,X,Y,$ETRAP,$ESTACK
+2 DO UCI^%ZOSV
+3 SET U="^"
SET CIAUCI=$PIECE(Y,",")
SET CIAMODE=+$GET(CIAMODE)
SET CIAIP=$GET(CIAIP)
SET (CIAQUIT,CIARETRY)=0
+4 ; Start background event monitor if not already running
DO MONSTART^CIANBEVT
+5 ; Default service port
IF '$GET(CIAPORT)
SET CIAPORT=9000
+6 ; Quit if listener already running
IF '$$STATE(1)
QUIT
+7 SET Y=$GET(^%ZOSF("OS"))
SET (CIAOS,X)=0
+8 FOR XWBOS="DSM","MSM","OpenM"
SET X=X+1
IF Y[XWBOS
SET CIAOS=X
QUIT
+9 IF 'CIAOS
DO RAISE(15,Y)
+10 DO CLEANUP
DO STSAVE(0)
DO NULLOPEN
DO STSAVE(1)
+11 ; Start RUM for Broker Handler
IF CIAMODE=1
DO LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
+12 ; Change process name
DO CHPRN("CIA"_$SELECT($LENGTH(CIAIP):$PIECE(CIAIP,".",3,4)_":"_CIAPORT,1:CIAPORT))
+13 DO LISTEN
+14 ; Stop RUM for handler
IF CIAMODE=1
DO LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2)
+15 IF CIAQUIT>0!'CIAMODE
DO STATE(0)
DO STREST(1)
DO ^%ZISC
DO STREST(0)
DO CLEANUP
IF $GET(DUZ)
DO LOGOUT^XUSRB
+16 ; Restart primary listener after fatal error
IF 'CIAMODE
IF 'CIAQUIT
JOB EN^CIANBLIS(CIAPORT)
+17 QUIT
+18 ; Entry point for interactive debugging
DEBUG NEW CIAPORT,CIAIP
+1 WRITE !!,"Debug Mode Support",!!
+2 SET CIAIP=$$PMPT("Addr","Enter callback IP address.","127.0.0.1")
+3 IF U[CIAIP
QUIT
+4 SET CIAPORT=$$PMPT("Port","Enter callback port.")
+5 IF U[CIAPORT
QUIT
+6 IF $LENGTH($TEXT(^%Serenji))
IF $$ASK^CIAU("Use Serenji Debugger","Y")
Begin DoDot:1
+7 NEW SRJIP,SRJPORT
+8 SET SRJIP=$$PMPT("Serenji Listener Addr","Enter Serenji listener address",CIAIP)
+9 IF U[SRJIP
QUIT
+10 SET SRJPORT=$$PMPT("Serenji Listener Port","Enter Serenji listener port",4321)
+11 IF U[SRJPORT
QUIT
+12 DO DEBUG^%Serenji("EN^CIANBLIS(CIAPORT,CIAIP,1)",SRJIP,SRJPORT)
End DoDot:1
QUIT
+13 WRITE !
+14 DO EN(CIAPORT,CIAIP,1)
+15 QUIT
PMPT(PMPT,HELP,DFLT) ;
+1 NEW RET
PMPTX WRITE PMPT,": ",$SELECT($DATA(DFLT):DFLT_"// ",1:"")
+1 READ RET:$GET(DTIME,30)
+2 IF '$TEST
SET RET=U
+3 IF $DATA(DFLT)
IF '$LENGTH(RET)
SET RET=DFLT
WRITE DFLT
+4 WRITE !
+5 IF RET["?"
WRITE !,HELP,!!
GOTO PMPTX
+6 QUIT RET
+7 ; Entry point for MSERVER process (MSM only)
MSERVER DO EN(%("PORT"),%("ADDRESS"),2)
+1 QUIT
+2 ; Entry point for UCX process (DSM only)
USERVER DO EN($PIECE(%,":",2),$PIECE(%,":"),2)
+1 QUIT
+2 ; Start primary listener
START(CIAPORT) ;EP
+1 DO SSLIS(,CIAPORT,,1)
DO CLEANUP^CIANBUTL
+2 QUIT
+3 ; Stop primary or secondary listener
STOP(CIAPORT,CIAIP) ;EP
+1 DO SSLIS(.CIAIP,CIAPORT,,0)
+2 QUIT
+3 ; Start all primary listeners
STARTALL ;PEP - see above
+1 DO SSALL(1)
+2 QUIT
+3 ; Stop all primary listeners
STOPALL ;PEP - see above
+1 DO SSALL(0)
+2 QUIT
+3 ; Start/stop all registered listeners
SSALL(SS,SL) ;
+1 NEW IEN,X
+2 SET SL=$GET(SL,$DATA(ZTQUEUED))
SET U="^"
+3 FOR IEN=0:0
SET IEN=$ORDER(^CIANB(19941.22,IEN))
IF 'IEN
QUIT
SET X=^(IEN,0)
Begin DoDot:1
+4 IF SS
IF $PIECE(X,U,3)
QUIT
+5 IF 'SL
WRITE !,$PIECE(X,U),": "
+6 DO SSLIS(,$PIECE(X,U,2),$PIECE(X,U,4),SS,SL)
End DoDot:1
+7 QUIT
+8 ; Start/stop primary listener
SSLIS(CIAIP,CIAPORT,CIAUCI,SS,SL) ;
+1 NEW CIALN,X,P1,P2,$ETRAP
+2 SET SL=$GET(SL,$DATA(ZTQUEUED))
+3 IF 'SL
SET $ETRAP="D SSERR^CIANBLIS"
+4 SET P1=$SELECT(SS:"start",1:"stop")
SET P2=P1_$SELECT(SS:"ed",1:"ped")
+5 IF $$STATE=SS
IF 'SL
WRITE "Listener ",$SELECT(SS:"already",1:"not")," running on port ",CIAPORT,!!
QUIT
+6 IF 'SS
SET @$$LOCKNODE=1
+7 IF '$TEST
IF $LENGTH($GET(CIAUCI))
Begin DoDot:1
+8 JOB EN^CIANBLIS(CIAPORT)[CIAUCI]
End DoDot:1
+9 IF '$TEST
JOB EN^CIANBLIS(CIAPORT)
+10 IF SL
QUIT
+11 WRITE "Waiting for listener to ",P1,"..."
+12 FOR X=1:1:5
Begin DoDot:1
+13 HANG 2
+14 WRITE "."
+15 IF $$STATE=SS
SET X=99
End DoDot:1
+16 IF X<99
WRITE "Listener failed to ",P1,!
+17 IF '$TEST
WRITE "Listener ",P2," on port ",CIAPORT,!
+18 QUIT
SSERR IF '$GET(SL)
WRITE "Listener failed to ",P1,": ",$$EC^%ZOSV,!
+1 SET $ETRAP="D UNWIND^%ZTER"
+2 QUIT
+3 ; Main loop
LISTEN NEW $ETRAP,$ESTACK
+1 SET $ETRAP="D ETRAP1^CIANBLIS"
SET CIARETRY=0
SET CIAQUIT='$$TCPOPEN
+2 FOR
IF $$QUIT
QUIT
Begin DoDot:1
+3 NEW $ETRAP,$ESTACK
+4 IF $$DOACTION($SELECT(CIAMODE=2&(CIAOS'=3)
SET CIARETRY=0
End DoDot:1
+5 DO TCPCLOSE
+6 QUIT
+7 ; Read action and params
+8 ; VAC = List of valid action codes
+9 ; Returns true if valid inputs
DOACTION(VAC) ;
+1 NEW NM,SB,RT,VL,PR,CIA,ACT,SEQ,ARG,CIAERR,CIADATA,X
+2 SET CIAERR(0)=0
+3 DO TCPUSE
+4 SET X=$$TCPREAD(8,10)
+5 IF $EXTRACT(X,1,5)'="{CIA}"
QUIT 0
+6 SET ARG=0
SET CIA("EOD")=$ASCII(X,6)
SET SEQ=$EXTRACT(X,7)
SET ACT=$EXTRACT(X,8)
+7 FOR
SET NM=$$TCPREADL
IF '$LENGTH(NM)
QUIT
SET PR=NM=+NM
SET RT=$SELECT(PR:"P"_NM,1:"CIA("""_NM_"""")
IF PR&'$DATA(ARG(NM))
NEW @RT
Begin DoDot:1
+8 IF PR
SET ARG=$SELECT(NM>ARG:NM,1:ARG)
SET ARG(NM)=""
+9 SET SB=$$TCPREADL
SET VL=$$TCPREADL
+10 IF $LENGTH(SB)
SET RT=RT_$SELECT(PR:"(",1:",")_SB_")"
+11 IF '$TEST
IF 'PR
SET RT=RT_")"
+12 SET @RT=VL
End DoDot:1
+13 WRITE SEQ
+14 IF '$$ERRCHK^CIANBACT(VAC'[ACT,9,ACT)
Begin DoDot:1
+15 NEW $ETRAP,$ESTACK
+16 SET $ETRAP="D ETRAP2^CIANBLIS"
+17 DO @("ACT"_ACT_"^CIANBACT")
End DoDot:1
+18 IF CIAERR(0)
Begin DoDot:1
+19 DO SNDERR
End DoDot:1
+20 IF '$TEST
IF $DATA(CIADATA)
Begin DoDot:1
+21 DO REPLY(.CIADATA)
End DoDot:1
+22 IF '$TEST
DO SNDEOD
+23 IF 'CIAMODE
DO TCPREL
+24 QUIT 1
+25 ; Cleanup environment
CLEANUP KILL ^TMP("CIANBRPC",$JOB),^TMP("CIANBLIS",$JOB),^XUTL("XQ",$JOB),@$$LOCKNODE
+1 QUIT
+2 ; Returns true if listener should quit
QUIT() IF 'CIAQUIT
SET CIAQUIT=+$GET(@$$LOCKNODE)
+1 QUIT CIARETRY>5!CIAQUIT
+2 ; Save application state
STSAVE(ST) ;
+1 DO SAVE^XUS1
+2 KILL ^TMP("CIANBLIS",$JOB,ST)
+3 MERGE ^TMP("CIANBLIS",$JOB,ST)=^XUTL("XQ",$JOB)
+4 QUIT
+5 ; Restore application state
STREST(ST) ;
+1 KILL ^XUTL("XQ",$JOB)
+2 MERGE ^XUTL("XQ",$JOB)=^TMP("CIANBLIS",$JOB,ST)
+3 KILL IO
+4 DO RESETVAR^%ZIS
+5 IF ST
IF $DATA(IO)#2
Begin DoDot:1
+6 NEW $ETRAP
+7 SET $ETRAP="S $EC="""" D NULLOPEN^CIANBLIS"
+8 USE IO
End DoDot:1
+9 QUIT
+10 ; Establish null device as default IO device
NULLOPEN NEW %ZIS,IOP,POP
+1 SET %ZIS="0H"
SET IOP="NULL"
+2 DO ^%ZIS
IF POP
DO RAISE(16)
+3 USE IO
+4 QUIT
+5 ; Open TCP listener port
+6 ; Returns true if successful
TCPOPEN() ;
+1 NEW POP
+2 SET POP=0
+3 IF CIAMODE=2
Begin DoDot:1
+4 SET CIATDEV=$SELECT(CIAOS=1:"SYS$NET",CIAOS=2:56,1:$PRINCIPAL)
+5 IF CIAOS=1
OPEN CIATDEV:TCPDEV:5
SET POP='$TEST
End DoDot:1
+6 IF CIAMODE=1
Begin DoDot:1
+7 DO CALL^%ZISTCP(CIAIP,CIAPORT)
+8 IF POP
QUIT
+9 SET CIATDEV=IO
SET IO(0)=IO
+10 IF $TEXT(SHARELIC^%ZOSV)'=""
DO SHARELIC^%ZOSV(1)
End DoDot:1
+11 IF 'CIAMODE
Begin DoDot:1
+12 IF CIAOS=1
Begin DoDot:2
+13 SET CIATDEV=CIAPORT
+14 OPEN CIATDEV:TCPCHAN:5
+15 SET POP='$TEST
End DoDot:2
+16 IF CIAOS=2
SET CIATDEV=56
+17 IF CIAOS=3
Begin DoDot:2
+18 SET CIATDEV="|TCP|"_CIAPORT
+19 OPEN CIATDEV:(:CIAPORT:"DS"):5
+20 SET POP='$TEST
End DoDot:2
End DoDot:1
+21 QUIT 'POP
+22 ; Use TCP listener port
TCPUSE IF CIAOS=1
USE CIATDEV
QUIT
+1 IF CIAOS=2
Begin DoDot:1
+2 IF CIAMODE
USE CIATDEV
IF $ZC
SET CIAQUIT=1
QUIT
+3 OPEN CIATDEV
+4 USE CIATDEV::"TCP"
+5 WRITE /SOCKET("",CIAPORT)
End DoDot:1
QUIT
+6 IF CIAOS=3
USE CIATDEV
+7 QUIT
+8 ; Close TCP listener port
TCPCLOSE IF $DATA(CIATDEV)
CLOSE CIATDEV
+1 QUIT
+2 ; Release TCP port
TCPREL IF CIAOS=1
USE CIATDEV:DISCONNECT
QUIT
+1 IF CIAOS=2
CLOSE CIATDEV
QUIT
+2 IF CIAOS=3
WRITE *-3,*-2
+3 QUIT
+4 ; Read from listener port
TCPREAD(CNT,TMO) ;
+1 NEW X,Y
+2 SET Y=""
SET TMO=$GET(TMO,60)
+3 FOR
IF CNT'>0
QUIT
Begin DoDot:1
+4 READ X#CNT:TMO
+5 IF '$LENGTH(X)
SET Y=""
SET CNT=0
IF CIAMODE=2
SET CIARETRY=CIARETRY+.5
+6 IF '$TEST
SET Y=Y_X
SET CNT=CNT-$LENGTH(X)
End DoDot:1
+7 QUIT Y
+8 ; Read byte from listener port
TCPREADB() ;
+1 QUIT $ASCII($$TCPREAD(1))
+2 ; Read length-prefixed data from input stream
TCPREADL() ;
+1 NEW X,L,I,N
+2 SET X=$$TCPREADB
+3 IF X=CIA("EOD")
QUIT ""
+4 SET N=X#16
SET X=$$TCPREAD(X\16)
SET L=0
+5 FOR I=1:1:$LENGTH(X)
SET L=L*256+$ASCII(X,I)
+6 QUIT $$TCPREAD(L*16+N)
+7 ; Raise an exception
RAISE(MSG,P1,P2) ;
+1 DO GETDLG^CIANBUTL(MSG,.MSG,.P1,.P2)
+2 SET $ECODE=MSG(1)
+3 QUIT
+4 ; Communication error
ETRAP1 NEW ECSAV
+1 SET $ETRAP="D UNWIND^CIANBLIS Q:$Q 0 Q"
SET ECSAV=$ECODE
SET CIARETRY=CIARETRY+1
+2 IF CIARETRY=1&(ECSAV'["READ")
DO ^%ZTER
+3 SET $ECODE=ECSAV
+4 QUIT
+5 ; Unwind stack
UNWIND IF $ESTACK>1
QUIT
+1 SET $ECODE=""
+2 QUIT
+3 ; Trapped error, send error info to client
ETRAP2 NEW ECSAV
+1 SET $ETRAP="D UNWIND^CIANBLIS Q:$Q 0 Q"
SET ECSAV=$$EC^%ZOSV
SET CIARETRY=CIARETRY+1
+2 IF CIARETRY=1
DO ^%ZTER
DO ERRCHK^CIANBACT(1,1,ECSAV)
+3 SET $ECODE=ECSAV
+4 QUIT
+5 ; Send a reply
REPLY(DATA,ACK) ;
+1 DO TCPUSE
+2 WRITE $CHAR(+$GET(ACK)),$GET(DATA)
+3 DO SNDEOD
+4 QUIT
+5 ; Send error information
SNDERR ;
+1 NEW X
+2 DO TCPUSE
+3 WRITE $CHAR(1)
+4 DO OUT^CIANBACT("CIAERR",1)
DO SNDEOD
+5 SET CIAERR(0)=0
+6 QUIT
+7 ; Send end of data byte if not already sent
SNDEOD IF $DATA(CIA("EOD"))
Begin DoDot:1
+1 DO TCPUSE
+2 WRITE $CHAR(CIA("EOD")),!
+3 KILL CIA("EOD")
End DoDot:1
+4 QUIT
+5 ; Lock/Unlock listener
+6 ; CIAACT: 1 = lock, 0 = unlock, missing = return status
+7 ; Returns true if locked, false if not.
STATE(CIAACT) ;
+1 NEW RES,Y
+2 SET Y=$$LOCKNODE
+3 IF '$DATA(CIAACT)
Begin DoDot:1
+4 LOCK +@Y:0
+5 SET RES='$TEST
+6 IF 'RES
LOCK -@Y
End DoDot:1
+7 IF '$TEST
IF CIAACT
Begin DoDot:1
+8 LOCK +@Y:1
+9 SET RES=$TEST
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 LOCK -@Y
+12 SET RES=0
End DoDot:1
+13 IF $QUIT
QUIT RES
+14 QUIT
+15 ; Get global reference for lock node
LOCKNODE(LN) ;
+1 IF '$DATA(LN)
SET LN=$NAME(^[$GET(CIAUCI)]XTMP("CIANBLIS",$GET(CIAIP)_":"_CIAPORT_$SELECT($GET(CIAMODE)=2:":"_$JOB,1:"")))
+2 IF $QUIT
QUIT LN
+3 QUIT
+4 ; Change process name to X
CHPRN(X) DO SETNM^%ZOSV($EXTRACT(X,1,15))
+1 QUIT
