- 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 Feb 19, 2025@00:03:55 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