XWBTCPM1 ;ISF/RWF - Support for XWBTCPM ;08/11/15 09:00
;;1.1;RPC BROKER;**35,64**;Mar 28, 1997;Build 12
;Per VA Directive 6402, this routine should not be modified.
Q
ZISTCP(XWBTSKT) ;Start ZISTCPS listener
;
N XWBENV,XWBVOL,Y
D GETENV^%ZOSV S XWBENV=Y,XWBVOL=$P(Y,"^",2)
Q:'$$SEMAPHOR^XWBTCPL(XWBTSKT,"LOCK") ;quit if job is already running
D UPDTREC^XWBTCPL(XWBTSKT,3) ;updt RPC BROKER SITE PARAMETER record as RUNNING
D MARKER^XWBTCP(XWBTSKT,-1) ;Clear marker
;
D LISTEN^%ZISTCPS(XWBTSKT,"NT^XWBTCPM","D STAT^XWBTCPM1("_XWBTSKT_")")
;
S %=$$SEMAPHOR^XWBTCPL(XWBTSKT,"UNLOCK") ; destroy 'running flag'
D UPDTREC^XWBTCPL(XWBTSKT,6) ;updt RPC BROKER SITE PARAMETER record as STOPPED
Q
;
OLD ;Call the old style broker
; Note: The old-style broker, which calls back to the RPC Client on a different port,
; has been deprecated in XWB*1.1*60 and will not be supported in future patches. New
; development should not use this broker, and legacy applications which use this
; interface should be moved to the new-style broker at the earliest opportunity.
;XWBRBUF setup in XWBTCPM
N XWBTCNT
S XWBTCNT=0
D READCONN ;Get the rest of the connect msg
; -- msg should be: action^client IP^client port^token
;p64 - not sure if this works with IPv6, as I have no way to test
I $P(MSG,"^")="TCPconnect" D
. N DZ,%T,NATIP S DZ="",%T=0
. ;Get the peer and use that IP, Allow use thru a NAT box.
. S NATIP=$$GETPEER^%ZOSV S:'$L(NATIP) NATIP=$P(MSG,"^",2)
. I NATIP'=$P(MSG,"^",2) S $P(MSG,"^",2)=NATIP
. I '$$NEWJOB^XWBTCPM D LOG("No New Jobs"),QSND("reject") Q
. ;Keep the current job & Device.
. ;just call the old server code. Uses a extra socket.
. D QSND("accept"),LOG("accept")
. D EN^XWBTCPC($P(MSG,"^",2),$P(MSG,"^",3),$P(DZ,"^"),XWBVER,$P(MSG,"^",4))
Q
;
READCONN ;Read the rest of the connect message
N CON,VL,LEN,MSG2
S CON=$$BREAD(6,XWBTIME) I CON="" S CON="Timeout" D LOG(CON) Q
I $E(CON,6)="|" D
. S VL=$$BREAD(1),VL=$A(VL)
. S XWBVER=$$BREAD(VL)
. S LEN=$$BREAD(5)
. S MSG=$$BREAD(+LEN)
E S X=$E(CON,6),LEN=$E(CON,1,5)-1,MSG2=$$BREAD(LEN),MSG=X_MSG2,XWBVER=0
D LOG("Connect: "_MSG)
Q
;
BREAD(L,TO) ;Buffer read
S XWBTIME(1)=$G(TO,5)
Q $$BREAD^XWBRW(L)
;
QSND(H) ;Quick send
D QSND^XWBRW(H)
Q
LOG(H) ;
D:$G(XWBDEBUG) LOG^XWBDLOG(H)
Q
;
NODE(P) ;Get Listener node, XWBENV must be set first
N X,Y,BV
I '$D(XWBENV) D GETENV^%ZOSV S XWBENV=Y
S BV=$P(XWBENV,"^",4)
S IX1=$O(^%ZIS(14.7,"B",BV,0)) I IX1'>0 Q "Box-Vol 1"
S IX1=$O(^XWB(8994.1,1,7,"B",IX1,0)) I IX1'>0 Q "Box-Vol 2"
S IX2=$O(^XWB(8994.1,1,7,IX1,1,"B",P,0)) I IX2'>0 Q "Port"
S X=$G(^XWB(8994.1,1,7,IX1,1,IX2,0))
Q X
;
STAT(P) ;Check if should stop.
;Called from ZRULE in %ZISTCPS
N X
S X=$$NODE(P)
S ZISQUIT=($P(X,"^",2)>3) ;Status Stop
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXWBTCPM1 2852 printed Oct 16, 2024@18:38:08 Page 2
XWBTCPM1 ;ISF/RWF - Support for XWBTCPM ;08/11/15 09:00
+1 ;;1.1;RPC BROKER;**35,64**;Mar 28, 1997;Build 12
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
ZISTCP(XWBTSKT) ;Start ZISTCPS listener
+1 ;
+2 NEW XWBENV,XWBVOL,Y
+3 DO GETENV^%ZOSV
SET XWBENV=Y
SET XWBVOL=$PIECE(Y,"^",2)
+4 ;quit if job is already running
if '$$SEMAPHOR^XWBTCPL(XWBTSKT,"LOCK")
QUIT
+5 ;updt RPC BROKER SITE PARAMETER record as RUNNING
DO UPDTREC^XWBTCPL(XWBTSKT,3)
+6 ;Clear marker
DO MARKER^XWBTCP(XWBTSKT,-1)
+7 ;
+8 DO LISTEN^%ZISTCPS(XWBTSKT,"NT^XWBTCPM","D STAT^XWBTCPM1("_XWBTSKT_")")
+9 ;
+10 ; destroy 'running flag'
SET %=$$SEMAPHOR^XWBTCPL(XWBTSKT,"UNLOCK")
+11 ;updt RPC BROKER SITE PARAMETER record as STOPPED
DO UPDTREC^XWBTCPL(XWBTSKT,6)
+12 QUIT
+13 ;
OLD ;Call the old style broker
+1 ; Note: The old-style broker, which calls back to the RPC Client on a different port,
+2 ; has been deprecated in XWB*1.1*60 and will not be supported in future patches. New
+3 ; development should not use this broker, and legacy applications which use this
+4 ; interface should be moved to the new-style broker at the earliest opportunity.
+5 ;XWBRBUF setup in XWBTCPM
+6 NEW XWBTCNT
+7 SET XWBTCNT=0
+8 ;Get the rest of the connect msg
DO READCONN
+9 ; -- msg should be: action^client IP^client port^token
+10 ;p64 - not sure if this works with IPv6, as I have no way to test
+11 IF $PIECE(MSG,"^")="TCPconnect"
Begin DoDot:1
+12 NEW DZ,%T,NATIP
SET DZ=""
SET %T=0
+13 ;Get the peer and use that IP, Allow use thru a NAT box.
+14 SET NATIP=$$GETPEER^%ZOSV
if '$LENGTH(NATIP)
SET NATIP=$PIECE(MSG,"^",2)
+15 IF NATIP'=$PIECE(MSG,"^",2)
SET $PIECE(MSG,"^",2)=NATIP
+16 IF '$$NEWJOB^XWBTCPM
DO LOG("No New Jobs")
DO QSND("reject")
QUIT
+17 ;Keep the current job & Device.
+18 ;just call the old server code. Uses a extra socket.
+19 DO QSND("accept")
DO LOG("accept")
+20 DO EN^XWBTCPC($PIECE(MSG,"^",2),$PIECE(MSG,"^",3),$PIECE(DZ,"^"),XWBVER,$PIECE(MSG,"^",4))
End DoDot:1
+21 QUIT
+22 ;
READCONN ;Read the rest of the connect message
+1 NEW CON,VL,LEN,MSG2
+2 SET CON=$$BREAD(6,XWBTIME)
IF CON=""
SET CON="Timeout"
DO LOG(CON)
QUIT
+3 IF $EXTRACT(CON,6)="|"
Begin DoDot:1
+4 SET VL=$$BREAD(1)
SET VL=$ASCII(VL)
+5 SET XWBVER=$$BREAD(VL)
+6 SET LEN=$$BREAD(5)
+7 SET MSG=$$BREAD(+LEN)
End DoDot:1
+8 IF '$TEST
SET X=$EXTRACT(CON,6)
SET LEN=$EXTRACT(CON,1,5)-1
SET MSG2=$$BREAD(LEN)
SET MSG=X_MSG2
SET XWBVER=0
+9 DO LOG("Connect: "_MSG)
+10 QUIT
+11 ;
BREAD(L,TO) ;Buffer read
+1 SET XWBTIME(1)=$GET(TO,5)
+2 QUIT $$BREAD^XWBRW(L)
+3 ;
QSND(H) ;Quick send
+1 DO QSND^XWBRW(H)
+2 QUIT
LOG(H) ;
+1 if $GET(XWBDEBUG)
DO LOG^XWBDLOG(H)
+2 QUIT
+3 ;
NODE(P) ;Get Listener node, XWBENV must be set first
+1 NEW X,Y,BV
+2 IF '$DATA(XWBENV)
DO GETENV^%ZOSV
SET XWBENV=Y
+3 SET BV=$PIECE(XWBENV,"^",4)
+4 SET IX1=$ORDER(^%ZIS(14.7,"B",BV,0))
IF IX1'>0
QUIT "Box-Vol 1"
+5 SET IX1=$ORDER(^XWB(8994.1,1,7,"B",IX1,0))
IF IX1'>0
QUIT "Box-Vol 2"
+6 SET IX2=$ORDER(^XWB(8994.1,1,7,IX1,1,"B",P,0))
IF IX2'>0
QUIT "Port"
+7 SET X=$GET(^XWB(8994.1,1,7,IX1,1,IX2,0))
+8 QUIT X
+9 ;
STAT(P) ;Check if should stop.
+1 ;Called from ZRULE in %ZISTCPS
+2 NEW X
+3 SET X=$$NODE(P)
+4 ;Status Stop
SET ZISQUIT=($PIECE(X,"^",2)>3)
+5 QUIT
