XWBTCPC ;ISC-SF/EG/VYD - TCP/IP PROCESS HANDLER ;08/25/2004 14:18
;;1.1;RPC BROKER;**2,5,4,6,9,16,26,35**;Mar 28, 1997
;Based on: XQORTCPH ;SLC/KCM - Service TCP Messages
;Modified by ISC-SF/EG
; 0. No longer supports old style OERR messages
; 1. Makes call to RPC broker
; 2. Result of an rpc call can be a closed form of global
; 3. Can receive a large local array, within limits of job
; partition size.
; 4. Sets default device to NULL device prior to call, restores
; at termination. Prevents garbage from 'talking' calls.
; 5. All reads have a timeout.
; 6. Intro message is sent when first connected.
; 7. Uses callback model to connect to client
;
;
EN(XWBTIP,XWBTSKT,DUZ,XWBVER,XWBCLMAN) ; -- Main entry point
N TYPE,XWBTBUF,XWBTBUF1,XWBTDEV,XWBTLEN,XWBTOS,XWBTRTN,XWBWRAP
N X,XWBL,XWB1,XWB2,Y,XWBTIME,XWBPTYPE,XWBPLEN,XWBNULL,XWBODEV,XWBRBUF
N XWBERROR,XWBSEC ;new error variable available to rpc calls
N IO,IOP,L,XWBAPVER,VL,XWBTHDR,XWBT
;
;Set up the error trap
S U="^",$ETRAP="D ^%ZTER,XUTL^XUSCLEAN H" ;XWB-30
S XWBOS=$$OS
S XWBT("BF")=$S(XWBOS="GT.M":"#",1:"!")
;start RUM for Broker Handler XWB*1.1*5
D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
;
S XWBCLMAN=$G(XWBCLMAN)
I '$D(XWBDEBUG) D ;(*p35)
. S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG")
. D LOGSTART^XWBDLOG("XWBTCPC")
. Q
I XWBDEBUG D LOG("Callback: "_XWBTIP_" :"_XWBTSKT) ;(*p35)
D SETTIME(1) ;Setup for sign-on time-out
;Use Kernel to open the connection back to the client on new port
D CALL^%ZISTCP(XWBTIP,XWBTSKT) Q:POP S XWBTDEV=IO,IO(0)=IO
;Attempt to share the license, Must have TCP port open first.
U XWBTDEV I $T(SHARELIC^%ZOSV)'="" D SHARELIC^%ZOSV(1)
;setup null device "NULL"
S %ZIS="0H",IOP="NULL" D ^%ZIS S XWBNULL=IO I POP S XWBERROR="No NULL device" D ^%ZTER Q
D SAVDEV^%ZISUTL("XWBNULL")
I XWBOS="GTM" S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
;change process name
S X="ip"_$P(XWBTIP,".",3,4)_":"_XWBTSKT
D SETNM^%ZOSV($E(X,1,15)),LOG("ProcName: "_X)
RESTART ;(*p35)
N $ESTACK S $ETRAP="D ETRAP^XWBTCPC"
S U="^",DUZ=0,DUZ(0)="",DTIME=300
U XWBTDEV D MAIN
;Turn off the error trap for the exit
S $ETRAP=""
I $G(DUZ) D LOGOUT^XUSRB
K XWBR,XWBARY
;stop RUM for handler XWB*1.1*5
D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2)
D LOG("DUZ="_$G(DUZ)_" LOGGED OFF")
D USE^%ZISUTL("XWBNULL"),CLOSE^%ZISUTL("XWBNULL")
C XWBTDEV ;Close can get an error
Q
;
MAIN ; -- main message processing loop
N XCNT,XR
F D Q:XWBTBUF="#BYE#"
. S XWBAPVER=0,(XWBSEC,XWBERROR,XWBRBUF)=""
. U XWBTDEV ;Make sure we are reading from the right device
. ; -- read client request
. ;F XCNT=0:0 R XR#1:XWBTIME Q:(XR="{")!(XR="#") I '$T S XCNT=XCNT+1 Q:XCNT>5
. S XR=$$BREAD^XWBRW(1,XWBTIME,1)
. I '$L(XR) D LOG("Timeout"),TIMEOUT S XWBTBUF="#BYE#" Q
. S XWBTHDR=XR_$$BREAD^XWBRW(4) ;(*p35)
. I XWBTHDR["#BYE#" S XWBTBUF="#BYE#" Q ;Clear $C(4)
. S XWBTHDR=XWBTHDR_$$BREAD^XWBRW(6)
. I $G(XWBDEBUG)>1 D LOG("HDR Read:"_XWBTHDR_":")
. S TYPE=($E(XWBTHDR,1,5)="{XWB}") ;check HDR
. I 'TYPE D Q
. . D LOG("Bad Header: "_XWBTHDR) ;(*p35)
. . S XWBTBUF="#BYE#" D QSND^XWBRW(XWBTBUF) ;(*p35)
. . Q
. S XWBTLEN=$E(XWBTHDR,6,10),L=$E(XWBTHDR,11)
. I L="|" D ;(*p35) Save $T
. . S VL=$$BREAD^XWBRW(1),VL=$A(VL)
. . S XWBAPVER=$$BREAD^XWBRW(VL),XWBPLEN=$$BREAD^XWBRW(5) ;(*p35)
. E S XWBTBUF=$$BREAD^XWBRW(4),XWBPLEN=L_XWBTBUF ;(*p35)
. S XWBTBUF=$$BREAD^XWBRW(XWBPLEN) ;(*p35)
. I $P(XWBTBUF,U)="TCPconnect" D Q
. . D QSND^XWBRW("accept") ;Ack (*p35)
. IF TYPE D
. . K XWBR,XWBARY
. . IF XWBTBUF="#BYE#" D QSND^XWBRW("#BYE#") Q ; -- clean disconnect
. . S XWBTLEN=XWBTLEN-15
. . D CALLP^XWBBRK(.XWBR,XWBTBUF)
. . S XWBPTYPE=$S('$D(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
. IF XWBTBUF="#BYE#" D LOG("APP set #BYE#") Q ;(*p35)
. U XWBTDEV
. D SND^XWBRW ;Does SNDERR,SND,WRITE($C(4))
. I $G(XWBSHARE) D KILL1^XUSCLEAN ; CLEAN OUT PARTITION FOR SHARED BROKER
Q ;End Of Main
;
ETRAP ; -- on trapped error, send error info to client
N XWBERC,XWBERR
;Change trapping during trap.
S $ETRAP="D ^%ZTER,BYE^XUSCLEAN,XUTL^XUSCLEAN HALT" ;XWB-30
S XWBERC=$E($$EC^%ZOSV,1,200),XWBERR="M ERROR="_XWBERC_$C(13,10)_"LAST REF="_$$LGR^%ZOSV
S XWBOS=$$OS
;Check for short read, Tell Client to resend.
I $EC["U411" S XWBERROR="U411",XWBSEC="",XWBERR="Data Transfer Error to Server"
D ^%ZTER ;%ZTER clears $ZE and $ECODE
I $G(XWBDEBUG) D LOG("In ETRAP: "_XWBERC) ;(*p35)
I ($G(XWBERC)["READ")!($G(XWBERC)["WRITE")!($G(XWBERC)["SYSTEM-F")!('$D(XWBERC)) D:$G(DUZ) LOGOUT^XUSRB HALT ; XWB-30
U XWBTDEV
L ;Clear locks (*p35)
ETX ;Exit for trap
D ESND^XWBRW($C(24)_XWBERR_$C(4)) ;(p*35)
S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" G RESTART^XWBTCPC",$ECODE=",U99,"
Q
;
STYPE(X,WRAP) ;For backward compatability only
I $D(WRAP) Q $$RTRNFMT^XWBLIB($G(X),WRAP)
Q $$RTRNFMT^XWBLIB(X)
;
SETTIME(%) ;Set the Read timeout 0=RPC, 1=sign-on
; Increased timeout period (%=1) during signon from 90 to 180 for accessibility reasons
S XWBTIME=$S($G(%):180,$G(XWBVER)>1.105:$$BAT^XUPARAM,1:36000),XWBTIME(1)=5 ; (*p35)
I $G(%) S XWBTIME=$S($G(XWBVER)>1.1:90,1:36000)
Q
TIMEOUT ;Do this on MAIN loop timeout
I $G(DUZ)>0 D QSND^XWBRW("#BYE#"_$C(4)) Q
;Sign-on timeout
S XWBR(0)=0,XWBR(1)=1,XWBR(2)="",XWBR(3)="TIME-OUT",XWBPTYPE=2
D SND^XWBRW
Q
;
MSM ;entry point for MSERVER service - used by MSM
N XWBVER,LEN,MSG,X
S XWBVER=0
R LEN#11:3600 IF $E(LEN,1,5)'="{XWB}" D Q ;bad client, abort
. W "RPC broker disconnect!",!
. C 56
. Q
IF $E(LEN,11,11)="|" D
. R X#1:60
. R XWBVER#$A(X):60
. R LEN#5:60
. R MSG#LEN:60
. Q
ELSE S X=$E(LEN,11,11),LEN=$E(LEN,6,10)-1 R MSG#LEN:60 S MSG=X_MSG
IF $P(MSG,"^")="TCPconnect" D
. D QSND^XWBRW("accept")
. C 56
. D EN($P(MSG,"^",2),$P(MSG,"^",3),$P(X,"^"),XWBVER,$P(MSG,"^",4))
IF $P(MSG,"^")="TCPdebug" D
. D QSND^XWBRW("accept")
C 56
Q
OS() ;Return the OS
N % S %=^%ZOSF("OS") ;(*p35)
Q $S(%["DSM":"DSM",%["OpenM":"OpenM",%["GT.M":"GTM",1:"MSM") ;(*p35)
;
LOG(TX) ;DeBug Logging (*p35)
D:$G(XWBDEBUG) LOG^XWBDLOG(TX)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXWBTCPC 6224 printed Dec 13, 2024@02:37:28 Page 2
XWBTCPC ;ISC-SF/EG/VYD - TCP/IP PROCESS HANDLER ;08/25/2004 14:18
+1 ;;1.1;RPC BROKER;**2,5,4,6,9,16,26,35**;Mar 28, 1997
+2 ;Based on: XQORTCPH ;SLC/KCM - Service TCP Messages
+3 ;Modified by ISC-SF/EG
+4 ; 0. No longer supports old style OERR messages
+5 ; 1. Makes call to RPC broker
+6 ; 2. Result of an rpc call can be a closed form of global
+7 ; 3. Can receive a large local array, within limits of job
+8 ; partition size.
+9 ; 4. Sets default device to NULL device prior to call, restores
+10 ; at termination. Prevents garbage from 'talking' calls.
+11 ; 5. All reads have a timeout.
+12 ; 6. Intro message is sent when first connected.
+13 ; 7. Uses callback model to connect to client
+14 ;
+15 ;
EN(XWBTIP,XWBTSKT,DUZ,XWBVER,XWBCLMAN) ; -- Main entry point
+1 NEW TYPE,XWBTBUF,XWBTBUF1,XWBTDEV,XWBTLEN,XWBTOS,XWBTRTN,XWBWRAP
+2 NEW X,XWBL,XWB1,XWB2,Y,XWBTIME,XWBPTYPE,XWBPLEN,XWBNULL,XWBODEV,XWBRBUF
+3 ;new error variable available to rpc calls
NEW XWBERROR,XWBSEC
+4 NEW IO,IOP,L,XWBAPVER,VL,XWBTHDR,XWBT
+5 ;
+6 ;Set up the error trap
+7 ;XWB-30
SET U="^"
SET $ETRAP="D ^%ZTER,XUTL^XUSCLEAN H"
+8 SET XWBOS=$$OS
+9 SET XWBT("BF")=$SELECT(XWBOS="GT.M":"#",1:"!")
+10 ;start RUM for Broker Handler XWB*1.1*5
+11 DO LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
+12 ;
+13 SET XWBCLMAN=$GET(XWBCLMAN)
+14 ;(*p35)
IF '$DATA(XWBDEBUG)
Begin DoDot:1
+15 SET XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG")
+16 DO LOGSTART^XWBDLOG("XWBTCPC")
+17 QUIT
End DoDot:1
+18 ;(*p35)
IF XWBDEBUG
DO LOG("Callback: "_XWBTIP_" :"_XWBTSKT)
+19 ;Setup for sign-on time-out
DO SETTIME(1)
+20 ;Use Kernel to open the connection back to the client on new port
+21 DO CALL^%ZISTCP(XWBTIP,XWBTSKT)
if POP
QUIT
SET XWBTDEV=IO
SET IO(0)=IO
+22 ;Attempt to share the license, Must have TCP port open first.
+23 USE XWBTDEV
IF $TEXT(SHARELIC^%ZOSV)'=""
DO SHARELIC^%ZOSV(1)
+24 ;setup null device "NULL"
+25 SET %ZIS="0H"
SET IOP="NULL"
DO ^%ZIS
SET XWBNULL=IO
IF POP
SET XWBERROR="No NULL device"
DO ^%ZTER
QUIT
+26 DO SAVDEV^%ZISUTL("XWBNULL")
+27 IF XWBOS="GTM"
SET @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
+28 ;change process name
+29 SET X="ip"_$PIECE(XWBTIP,".",3,4)_":"_XWBTSKT
+30 DO SETNM^%ZOSV($EXTRACT(X,1,15))
DO LOG("ProcName: "_X)
RESTART ;(*p35)
+1 NEW $ESTACK
SET $ETRAP="D ETRAP^XWBTCPC"
+2 SET U="^"
SET DUZ=0
SET DUZ(0)=""
SET DTIME=300
+3 USE XWBTDEV
DO MAIN
+4 ;Turn off the error trap for the exit
+5 SET $ETRAP=""
+6 IF $GET(DUZ)
DO LOGOUT^XUSRB
+7 KILL XWBR,XWBARY
+8 ;stop RUM for handler XWB*1.1*5
+9 DO LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2)
+10 DO LOG("DUZ="_$GET(DUZ)_" LOGGED OFF")
+11 DO USE^%ZISUTL("XWBNULL")
DO CLOSE^%ZISUTL("XWBNULL")
+12 ;Close can get an error
CLOSE XWBTDEV
+13 QUIT
+14 ;
MAIN ; -- main message processing loop
+1 NEW XCNT,XR
+2 FOR
Begin DoDot:1
+3 SET XWBAPVER=0
SET (XWBSEC,XWBERROR,XWBRBUF)=""
+4 ;Make sure we are reading from the right device
USE XWBTDEV
+5 ; -- read client request
+6 ;F XCNT=0:0 R XR#1:XWBTIME Q:(XR="{")!(XR="#") I '$T S XCNT=XCNT+1 Q:XCNT>5
+7 SET XR=$$BREAD^XWBRW(1,XWBTIME,1)
+8 IF '$LENGTH(XR)
DO LOG("Timeout")
DO TIMEOUT
SET XWBTBUF="#BYE#"
QUIT
+9 ;(*p35)
SET XWBTHDR=XR_$$BREAD^XWBRW(4)
+10 ;Clear $C(4)
IF XWBTHDR["#BYE#"
SET XWBTBUF="#BYE#"
QUIT
+11 SET XWBTHDR=XWBTHDR_$$BREAD^XWBRW(6)
+12 IF $GET(XWBDEBUG)>1
DO LOG("HDR Read:"_XWBTHDR_":")
+13 ;check HDR
SET TYPE=($EXTRACT(XWBTHDR,1,5)="{XWB}")
+14 IF 'TYPE
Begin DoDot:2
+15 ;(*p35)
DO LOG("Bad Header: "_XWBTHDR)
+16 ;(*p35)
SET XWBTBUF="#BYE#"
DO QSND^XWBRW(XWBTBUF)
+17 QUIT
End DoDot:2
QUIT
+18 SET XWBTLEN=$EXTRACT(XWBTHDR,6,10)
SET L=$EXTRACT(XWBTHDR,11)
+19 ;(*p35) Save $T
IF L="|"
Begin DoDot:2
+20 SET VL=$$BREAD^XWBRW(1)
SET VL=$ASCII(VL)
+21 ;(*p35)
SET XWBAPVER=$$BREAD^XWBRW(VL)
SET XWBPLEN=$$BREAD^XWBRW(5)
End DoDot:2
+22 ;(*p35)
IF '$TEST
SET XWBTBUF=$$BREAD^XWBRW(4)
SET XWBPLEN=L_XWBTBUF
+23 ;(*p35)
SET XWBTBUF=$$BREAD^XWBRW(XWBPLEN)
+24 IF $PIECE(XWBTBUF,U)="TCPconnect"
Begin DoDot:2
+25 ;Ack (*p35)
DO QSND^XWBRW("accept")
End DoDot:2
QUIT
+26 IF TYPE
Begin DoDot:2
+27 KILL XWBR,XWBARY
+28 ; -- clean disconnect
IF XWBTBUF="#BYE#"
DO QSND^XWBRW("#BYE#")
QUIT
+29 SET XWBTLEN=XWBTLEN-15
+30 DO CALLP^XWBBRK(.XWBR,XWBTBUF)
+31 SET XWBPTYPE=$SELECT('$DATA(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
End DoDot:2
+32 ;(*p35)
IF XWBTBUF="#BYE#"
DO LOG("APP set #BYE#")
QUIT
+33 USE XWBTDEV
+34 ;Does SNDERR,SND,WRITE($C(4))
DO SND^XWBRW
+35 ; CLEAN OUT PARTITION FOR SHARED BROKER
IF $GET(XWBSHARE)
DO KILL1^XUSCLEAN
End DoDot:1
if XWBTBUF="#BYE#"
QUIT
+36 ;End Of Main
QUIT
+37 ;
ETRAP ; -- on trapped error, send error info to client
+1 NEW XWBERC,XWBERR
+2 ;Change trapping during trap.
+3 ;XWB-30
SET $ETRAP="D ^%ZTER,BYE^XUSCLEAN,XUTL^XUSCLEAN HALT"
+4 SET XWBERC=$EXTRACT($$EC^%ZOSV,1,200)
SET XWBERR="M ERROR="_XWBERC_$CHAR(13,10)_"LAST REF="_$$LGR^%ZOSV
+5 SET XWBOS=$$OS
+6 ;Check for short read, Tell Client to resend.
+7 IF $ECODE["U411"
SET XWBERROR="U411"
SET XWBSEC=""
SET XWBERR="Data Transfer Error to Server"
+8 ;%ZTER clears $ZE and $ECODE
DO ^%ZTER
+9 ;(*p35)
IF $GET(XWBDEBUG)
DO LOG("In ETRAP: "_XWBERC)
+10 ; XWB-30
IF ($GET(XWBERC)["READ")!($GET(XWBERC)["WRITE")!($GET(XWBERC)["SYSTEM-F")!('$DATA(XWBERC))
if $GET(DUZ)
DO LOGOUT^XUSRB
HALT
+11 USE XWBTDEV
+12 ;Clear locks (*p35)
LOCK
ETX ;Exit for trap
+1 ;(p*35)
DO ESND^XWBRW($CHAR(24)_XWBERR_$CHAR(4))
+2 SET $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" G RESTART^XWBTCPC"
SET $ECODE=",U99,"
+3 QUIT
+4 ;
STYPE(X,WRAP) ;For backward compatability only
+1 IF $DATA(WRAP)
QUIT $$RTRNFMT^XWBLIB($GET(X),WRAP)
+2 QUIT $$RTRNFMT^XWBLIB(X)
+3 ;
SETTIME(%) ;Set the Read timeout 0=RPC, 1=sign-on
+1 ; Increased timeout period (%=1) during signon from 90 to 180 for accessibility reasons
+2 ; (*p35)
SET XWBTIME=$SELECT($GET(%):180,$GET(XWBVER)>1.105:$$BAT^XUPARAM,1:36000)
SET XWBTIME(1)=5
+3 IF $GET(%)
SET XWBTIME=$SELECT($GET(XWBVER)>1.1:90,1:36000)
+4 QUIT
TIMEOUT ;Do this on MAIN loop timeout
+1 IF $GET(DUZ)>0
DO QSND^XWBRW("#BYE#"_$CHAR(4))
QUIT
+2 ;Sign-on timeout
+3 SET XWBR(0)=0
SET XWBR(1)=1
SET XWBR(2)=""
SET XWBR(3)="TIME-OUT"
SET XWBPTYPE=2
+4 DO SND^XWBRW
+5 QUIT
+6 ;
MSM ;entry point for MSERVER service - used by MSM
+1 NEW XWBVER,LEN,MSG,X
+2 SET XWBVER=0
+3 ;bad client, abort
READ LEN#11:3600
IF $EXTRACT(LEN,1,5)'="{XWB}"
Begin DoDot:1
+4 WRITE "RPC broker disconnect!",!
+5 CLOSE 56
+6 QUIT
End DoDot:1
QUIT
+7 IF $EXTRACT(LEN,11,11)="|"
Begin DoDot:1
+8 READ X#1:60
+9 READ XWBVER#$ASCII(X):60
+10 READ LEN#5:60
+11 READ MSG#LEN:60
+12 QUIT
End DoDot:1
+13 IF '$TEST
SET X=$EXTRACT(LEN,11,11)
SET LEN=$EXTRACT(LEN,6,10)-1
READ MSG#LEN:60
SET MSG=X_MSG
+14 IF $PIECE(MSG,"^")="TCPconnect"
Begin DoDot:1
+15 DO QSND^XWBRW("accept")
+16 CLOSE 56
+17 DO EN($PIECE(MSG,"^",2),$PIECE(MSG,"^",3),$PIECE(X,"^"),XWBVER,$PIECE(MSG,"^",4))
End DoDot:1
+18 IF $PIECE(MSG,"^")="TCPdebug"
Begin DoDot:1
+19 DO QSND^XWBRW("accept")
End DoDot:1
+20 CLOSE 56
+21 QUIT
OS() ;Return the OS
+1 ;(*p35)
NEW %
SET %=^%ZOSF("OS")
+2 ;(*p35)
QUIT $SELECT(%["DSM":"DSM",%["OpenM":"OpenM",%["GT.M":"GTM",1:"MSM")
+3 ;
LOG(TX) ;DeBug Logging (*p35)
+1 if $GET(XWBDEBUG)
DO LOG^XWBDLOG(TX)
+2 QUIT
