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