- XWBTCPM ;ISF/RWF - BROKER TCP/IP PROCESS HANDLER ;05/27/15 14:40
- ;;1.1;RPC BROKER;**35,43,49,53,64**;Mar 28, 1997;Build 12
- ;Per VA Directive 6402, this routine should not be modified.
- ;
- ;Changed to be started by TCPIP service or %ZISTCPS
- ;
- DSM ;DSM called from ucx, % passed in with device.
- D ESET
- ;Open the device
- S XWBTDEV=% X "O XWBTDEV:(TCPDEV):60" ;Special UCX/DSM open
- ;Go find the connection type
- U XWBTDEV
- G CONNTYPE
- ;
- CACHEVMS ;Cache'/VMS tcpip entry point, called from XWBTCP_START.COM file
- D ESET
- S XWBTDEV=$S($ZV["VMS":"SYS$NET",1:$P) ;Support for both VMS/TCPIP and Linux/xinetd
- ; **Cache'/VMS specific code**
- O XWBTDEV::5
- X "U XWBTDEV:(::""-M"")" ;Packet mode like DSM
- G CONNTYPE
- ;
- NT ;entry from ZISTCPS
- ;JOB LISTEN^%ZISTCPS("port","NT^XWBTCPM","stop code")
- D ESET
- S XWBTDEV=IO
- G CONNTYPE
- ;
- GTMUCX(%) ;From ucx ZFOO
- ;If called from LISTEN^%ZISTCP(PORT,"GTM^XWBTCPM") S XWBTDEV=IO
- D ESET
- ;GTM specific code
- S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
- S XWBTDEV=% X "O %:(RECORDSIZE=512)"
- G CONNTYPE
- ;
- GTMLNX ;From Linux xinetd script
- D ESET
- ;GTM specific code
- S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
- S XWBTDEV=$P X "U XWBTDEV:(nowrap:nodelimiter:ioerror=""TRAP"")"
- S %="",@("%=$ZTRNLNM(""REMOTE_HOST"")") S:$L(%) IO("GTM-IP")=%
- G CONNTYPE
- ;
- ESET ;Set inital error trap
- S U="^",$ETRAP="D ^%ZTER H" ;Set up the error trap
- S X="",@("$ZT=X") ;Clear old trap
- Q
- ;Find the type of connection and jump to the processing routine.
- CONNTYPE ;
- N XWBDEBUG,XWBAPVER,XWBCLMAN,XWBENVL,XWBLOG,XWBOS,XWBPTYPE
- N XWBTBUF,XWBTIP,XWBTSKT,XWBVER,XWBWRAP,XWBSHARE,XWBT
- N SOCK,TYPE
- D INIT
- S XWB=$$BREAD^XWBRW(5,XWBTIME)
- D LOG("MSG format is "_XWB_" type "_$S(XWB="[XWB]":"NEW",XWB="{XWB}":"OLD",XWB="<?xml":"M2M",XWB="~BSE~":"BSE",XWB="~EAC~":"EAC",XWB="~SVR~":"SVR",1:"Unk")) ; XWB*1.1*XX
- I XWB["<?xml" G M2M
- I XWB["[XWB]" G NEW
- I XWB["{XWB}" G OLD^XWBTCPM1 ;Deprecated in XWB*1.1*60, to be removed when no longer being used
- I $L($T(OTH^XWBTCPM2)) D OTH^XWBTCPM2 ;See if a special code.
- I '$L($T(OTH^XWBTCPM2)) D LOG("Prefix not known: "_XWB) ; XWB*1.1*XX
- Q
- ;
- NEWJOB() ;Check if OK to start a new job, Return 1 if OK, 0 if not OK.
- N X,Y,J,XWBVOL
- D GETENV^%ZOSV S XWBVOL=$P(Y,"^",2)
- S X=$O(^XTV(8989.3,1,4,"B",XWBVOL,0)),J=$S(X>0:^XTV(8989.3,1,4,X,0),1:"ROU^y^1")
- I $G(^%ZIS(14.5,"LOGON",XWBVOL)) Q 0 ;Check INHIBIT LOGONS?
- I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(J,U,3),($P(J,U,3)'>Y) Q 0
- Q 1
- ;
- M2M ;M2M Broker
- S XWBRBUF=XWB_XWBRBUF,(IO,IO(0))=XWBTDEV G SPAWN^XWBVLL
- Q
- ;
- NEW ;New broker
- S U="^",DUZ=0,DUZ(0)="",XWBVER=1.108
- D SETTIME(1) ;Setup for sign-on timeout
- U XWBTDEV D
- . N XWB,ERR,NATIP,I
- . S ERR=$$PRSP^XWBPRS
- . S ERR=$$PRSM^XWBPRS
- . S MSG=$G(XWB(4,"CMD")) ;Build connect msg.
- . S I="" F S I=$O(XWB(5,"P",I)) Q:I="" S MSG=MSG_U_XWB(5,"P",I)
- . ;Get the peer and save that IP.
- . S NATIP=$$GETPEER^%ZOSV S:'$L(NATIP) NATIP=$P(MSG,"^",2)
- . I NATIP'=$P(MSG,"^",2) S $P(MSG,"^",2)=NATIP
- . Q
- S X=$$NEWJOB() D:'X LOG("No New Connects")
- I ($P(MSG,U)'="TCPConnect")!('X) D QSND^XWBRW("reject"),LOG("reject: "_MSG) Q
- D QSND^XWBRW("accept"),LOG("accept") ;Ack
- S IO("IP")=$P(MSG,U,2),XWBTSKT=$P(MSG,U,3),XWBCLMAN=$P(MSG,U,4)
- S XWBTIP=$G(IO("IP"))
- ;start RUM for Broker Handler XWB*1.1*5
- D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
- ;GTM
- I $G(XWBT("PCNT")) D
- . S X=$NA(^XUTL("XUSYS",$J,1)) L +@X:0
- . D COUNT^XUSCNT(1),SETLOCK^XUSCNT(X)
- ;We don't use a callback
- K XWB,CON,LEN,MSG ;Clean up
- ;Attempt to share license, Must have TCP port open first.
- U XWBTDEV ;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 LOG(XWBERROR),EXIT Q
- D SAVDEV^%ZISUTL("XWBNULL")
- ;change process name
- D CHPRN("ip"_$P(XWBTIP,".",3,4)_":"_XWBTDEV)
- ;
- RESTART ;The error trap returns to here
- N $ESTACK S $ETRAP="D ETRAP^XWBTCPM(0)"
- S DT=$$DT^XLFDT,DTIME=30
- U XWBTDEV D MAIN
- D LOG("Exit: "_XWBTBUF)
- ;Turn off the error trap for the exit
- S $ETRAP=""
- D EXIT ;Logout
- K XWBR,XWBARY
- ;stop RUM for handler XWB*1.1*5
- D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2)
- D USE^%ZISUTL("XWBNULL"),CLOSE^%ZISUTL("XWBNULL")
- ;Close in the calling script
- K SOCK,TYPE,XWBSND,XWBTYPE,XWBRBUF
- Q
- ;
- MAIN ; -- main message processing loop. debug at MAIN+1
- F D Q:XWBTBUF="#BYE#"
- . ;Setup
- . S XWBAPVER=0,XWBTBUF="",XWBTCMD="",XWBRBUF=""
- . K XWBR,XWBARY,XWBPRT
- . ; -- read client request
- . S XR=$$BREAD^XWBRW(1,XWBTIME,1)
- . I '$L(XR) D LOG("Timeout: "_XWBTIME) S XWBTBUF="#BYE#" Q
- . S XR=XR_$$BREAD^XWBRW(4)
- . I XR="#BYE#" D Q ;Check for exit
- . . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF="#BYE#"
- . . Q
- . S TYPE=(XR="[XWB]") ;check HDR
- . I 'TYPE D LOG("Bad Header: "_XR) Q
- . D CALLP^XWBPRS(.XWBR,$G(XWBDEBUG)) ;Read the NEW Msg parameters and call RPC
- . IF XWBTCMD="#BYE#" D Q
- . . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF=XWBTCMD
- . . Q
- . U XWBTDEV
- . S XWBPTYPE=$S('$D(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
- . ;I $G(XWBPRT) D RETURN^XWBPRS2 Q ;New msg return
- . I '$G(XWBPRT) D SND^XWBRW ;Return data,flush buffer
- Q ;End Of Main
- ;
- ;
- ETRAP(EXIT) ; -- on trapped error, send error info to client
- N XWBERC,XWBERR
- ;Change trapping during trap.
- S $ETRAP="D ^%ZTER,ETRAP^XWBTCPM(1)"
- S XWBERC=$E($$EC^%ZOSV,1,200),XWBERR="M ERROR="_XWBERC_$C(13,10)_"LAST REF="_$$LGR^%ZOSV
- I $EC["U411" S XWBERROR="U411",XWBSEC="",XWBERR="Data Transfer Error to Server"
- D ^%ZTER ;%ZTER clears $ZE and $ZCODE
- D LOG("In ETRAP: "_XWBERC) ;Log
- I (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F")!(XWBERC["IOEOF") D EXIT X "HALT "
- U XWBTDEV
- I $G(XWBT("PCNT")) L +^XUTL("XUSYS",$J,0):99
- E L ;Clear Locks
- ;
- D ESND^XWBRW($C(24)_XWBERR_$C(4))
- I EXIT D EXIT X "HALT "
- S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" D CLEANP^XWBTCPM G RESTART^XWBTCPM",$ECODE=",U99,"
- Q
- ;
- CLEANP ;Clean up the partion
- N XWBTDEV,XWBNULL D KILL^XUSCLEAN
- Q
- ;
- STYPE(X,WRAP) ;For backward compatability only
- I $D(WRAP) Q $$RTRNFMT^XWBLIB($G(X),WRAP)
- Q $$RTRNFMT^XWBLIB(X)
- ;
- BREAD(L,T) ;read tcp buffer, L is length
- Q $$BREAD^XWBRW(L,$G(T))
- ;
- CHPRN(N) ;change process name
- ;Change process name to N
- D SETNM^%ZOSV($E(N,1,15))
- Q
- ;
- 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.1:$$BAT^XUPARAM,1:36000),XWBTIME(1)=5 ; (*p35)
- Q
- TIMEOUT ;Do this on MAIN loop timeout
- I $G(DUZ)>0 D QSND^XWBRW("#BYE#") Q
- ;Sign-on timeout
- S XWBR(0)=0,XWBR(1)=1,XWBR(2)="",XWBR(3)="TIME-OUT",XWBPTYPE=2
- D SND^XWBRW
- Q
- ;
- OS() ;Return the OS
- Q $S(^%ZOSF("OS")["OpenM":"OpenM",^%ZOSF("OS")["GT.M":"GT.M",^("OS")["DSM":"DSM",1:"UNK")
- ;
- INIT ;Setup
- S U="^",XWBTIME=10,XWBOS=$$OS,XWBDEBUG=0,XWBRBUF=""
- S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG")
- S XWBT("BF")=$S(XWBOS="GT.M":"#",1:"!")
- S XWBT("PCNT")=0 I XWBOS="GT.M",$L($T(^XUSCNT)) S XWBT("PCNT")=1
- D LOGSTART^XWBDLOG("XWBTCPM")
- Q
- ;
- DEBUG ;Entry point for debug, Build a server to get the connect
- ;Cache sample;ZB SERV+1^XWBTCPM:"L+" ZB ETRAP+1^XWBTCPM:"B"
- W !,"Before running this entry point set your debugger to stop at"
- W !,"the place you want to debug. Some spots to use:"
- W !,"'SERV+1^XWBTCPM', 'MAIN+1^XWBTCPM' or 'CAPI+1^XWBPRS.'",!
- W !,"or location of your choice.",!
- W !,"IP Socket to Listen on: " R SOCK:300,! Q:'$T!(SOCK["^")
- ;Use %ZISTCP to do a single server
- D LISTEN^%ZISTCP(SOCK,"SERV^XWBTCPM")
- U $P W !,"Done"
- Q
- SERV ;Callback from the server
- S XWBTDEV=IO,XWBTIME(1)=3600 D INIT
- S XWBDEBUG=1,MSG=$$BREAD^XWBRW(5,60) ;R MSG#5
- D NEW
- S IO("C")=1 ;Cause the Listenr to stop
- Q
- ;
- EXIT ;Close out
- I $G(DUZ) D LOGOUT^XUSRB
- I $G(XWBT("PCNT")) D COUNT^XUSCNT(-1)
- Q
- ;
- LOG(MSG) ;Record Debug Info
- D:$G(XWBDEBUG) LOG^XWBDLOG(MSG)
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXWBTCPM 8017 printed Jan 18, 2025@03:38:37 Page 2
- XWBTCPM ;ISF/RWF - BROKER TCP/IP PROCESS HANDLER ;05/27/15 14:40
- +1 ;;1.1;RPC BROKER;**35,43,49,53,64**;Mar 28, 1997;Build 12
- +2 ;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;Changed to be started by TCPIP service or %ZISTCPS
- +5 ;
- DSM ;DSM called from ucx, % passed in with device.
- +1 DO ESET
- +2 ;Open the device
- +3 ;Special UCX/DSM open
- SET XWBTDEV=%
- XECUTE "O XWBTDEV:(TCPDEV):60"
- +4 ;Go find the connection type
- +5 USE XWBTDEV
- +6 GOTO CONNTYPE
- +7 ;
- CACHEVMS ;Cache'/VMS tcpip entry point, called from XWBTCP_START.COM file
- +1 DO ESET
- +2 ;Support for both VMS/TCPIP and Linux/xinetd
- SET XWBTDEV=$SELECT($ZV["VMS":"SYS$NET",1:$PRINCIPAL)
- +3 ; **Cache'/VMS specific code**
- +4 OPEN XWBTDEV::5
- +5 ;Packet mode like DSM
- XECUTE "U XWBTDEV:(::""-M"")"
- +6 GOTO CONNTYPE
- +7 ;
- NT ;entry from ZISTCPS
- +1 ;JOB LISTEN^%ZISTCPS("port","NT^XWBTCPM","stop code")
- +2 DO ESET
- +3 SET XWBTDEV=IO
- +4 GOTO CONNTYPE
- +5 ;
- GTMUCX(%) ;From ucx ZFOO
- +1 ;If called from LISTEN^%ZISTCP(PORT,"GTM^XWBTCPM") S XWBTDEV=IO
- +2 DO ESET
- +3 ;GTM specific code
- +4 SET @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
- +5 SET XWBTDEV=%
- XECUTE "O %:(RECORDSIZE=512)"
- +6 GOTO CONNTYPE
- +7 ;
- GTMLNX ;From Linux xinetd script
- +1 DO ESET
- +2 ;GTM specific code
- +3 SET @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
- +4 SET XWBTDEV=$PRINCIPAL
- XECUTE "U XWBTDEV:(nowrap:nodelimiter:ioerror=""TRAP"")"
- +5 SET %=""
- SET @("%=$ZTRNLNM(""REMOTE_HOST"")")
- if $LENGTH(%)
- SET IO("GTM-IP")=%
- +6 GOTO CONNTYPE
- +7 ;
- ESET ;Set inital error trap
- +1 ;Set up the error trap
- SET U="^"
- SET $ETRAP="D ^%ZTER H"
- +2 ;Clear old trap
- SET X=""
- SET @("$ZT=X")
- +3 QUIT
- +4 ;Find the type of connection and jump to the processing routine.
- CONNTYPE ;
- +1 NEW XWBDEBUG,XWBAPVER,XWBCLMAN,XWBENVL,XWBLOG,XWBOS,XWBPTYPE
- +2 NEW XWBTBUF,XWBTIP,XWBTSKT,XWBVER,XWBWRAP,XWBSHARE,XWBT
- +3 NEW SOCK,TYPE
- +4 DO INIT
- +5 SET XWB=$$BREAD^XWBRW(5,XWBTIME)
- +6 ; XWB*1.1*XX
- DO LOG("MSG format is "_XWB_" type "_$SELECT(XWB="[XWB]":"NEW",XWB="{XWB}":"OLD",XWB="<?xml":"M2M",XWB="~BSE~":"BSE",XWB="~EAC~":"EAC",XWB="~SVR~":"SVR",1:"Unk"))
- +7 IF XWB["<?xml"
- GOTO M2M
- +8 IF XWB["[XWB]"
- GOTO NEW
- +9 ;Deprecated in XWB*1.1*60, to be removed when no longer being used
- IF XWB["{XWB}"
- GOTO OLD^XWBTCPM1
- +10 ;See if a special code.
- IF $LENGTH($TEXT(OTH^XWBTCPM2))
- DO OTH^XWBTCPM2
- +11 ; XWB*1.1*XX
- IF '$LENGTH($TEXT(OTH^XWBTCPM2))
- DO LOG("Prefix not known: "_XWB)
- +12 QUIT
- +13 ;
- NEWJOB() ;Check if OK to start a new job, Return 1 if OK, 0 if not OK.
- +1 NEW X,Y,J,XWBVOL
- +2 DO GETENV^%ZOSV
- SET XWBVOL=$PIECE(Y,"^",2)
- +3 SET X=$ORDER(^XTV(8989.3,1,4,"B",XWBVOL,0))
- SET J=$SELECT(X>0:^XTV(8989.3,1,4,X,0),1:"ROU^y^1")
- +4 ;Check INHIBIT LOGONS?
- IF $GET(^%ZIS(14.5,"LOGON",XWBVOL))
- QUIT 0
- +5 IF $DATA(^%ZOSF("ACTJ"))
- XECUTE ^("ACTJ")
- IF $PIECE(J,U,3)
- IF ($PIECE(J,U,3)'>Y)
- QUIT 0
- +6 QUIT 1
- +7 ;
- M2M ;M2M Broker
- +1 SET XWBRBUF=XWB_XWBRBUF
- SET (IO,IO(0))=XWBTDEV
- GOTO SPAWN^XWBVLL
- +2 QUIT
- +3 ;
- NEW ;New broker
- +1 SET U="^"
- SET DUZ=0
- SET DUZ(0)=""
- SET XWBVER=1.108
- +2 ;Setup for sign-on timeout
- DO SETTIME(1)
- +3 USE XWBTDEV
- Begin DoDot:1
- +4 NEW XWB,ERR,NATIP,I
- +5 SET ERR=$$PRSP^XWBPRS
- +6 SET ERR=$$PRSM^XWBPRS
- +7 ;Build connect msg.
- SET MSG=$GET(XWB(4,"CMD"))
- +8 SET I=""
- FOR
- SET I=$ORDER(XWB(5,"P",I))
- if I=""
- QUIT
- SET MSG=MSG_U_XWB(5,"P",I)
- +9 ;Get the peer and save that IP.
- +10 SET NATIP=$$GETPEER^%ZOSV
- if '$LENGTH(NATIP)
- SET NATIP=$PIECE(MSG,"^",2)
- +11 IF NATIP'=$PIECE(MSG,"^",2)
- SET $PIECE(MSG,"^",2)=NATIP
- +12 QUIT
- End DoDot:1
- +13 SET X=$$NEWJOB()
- if 'X
- DO LOG("No New Connects")
- +14 IF ($PIECE(MSG,U)'="TCPConnect")!('X)
- DO QSND^XWBRW("reject")
- DO LOG("reject: "_MSG)
- QUIT
- +15 ;Ack
- DO QSND^XWBRW("accept")
- DO LOG("accept")
- +16 SET IO("IP")=$PIECE(MSG,U,2)
- SET XWBTSKT=$PIECE(MSG,U,3)
- SET XWBCLMAN=$PIECE(MSG,U,4)
- +17 SET XWBTIP=$GET(IO("IP"))
- +18 ;start RUM for Broker Handler XWB*1.1*5
- +19 DO LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
- +20 ;GTM
- +21 IF $GET(XWBT("PCNT"))
- Begin DoDot:1
- +22 SET X=$NAME(^XUTL("XUSYS",$JOB,1))
- LOCK +@X:0
- +23 DO COUNT^XUSCNT(1)
- DO SETLOCK^XUSCNT(X)
- End DoDot:1
- +24 ;We don't use a callback
- +25 ;Clean up
- KILL XWB,CON,LEN,MSG
- +26 ;Attempt to share license, Must have TCP port open first.
- +27 ;D SHARELIC^%ZOSV(1)
- USE XWBTDEV
- +28 ;setup null device "NULL"
- +29 SET %ZIS="0H"
- SET IOP="NULL"
- DO ^%ZIS
- SET XWBNULL=IO
- IF POP
- SET XWBERROR="No NULL device"
- DO LOG(XWBERROR)
- DO EXIT
- QUIT
- +30 DO SAVDEV^%ZISUTL("XWBNULL")
- +31 ;change process name
- +32 DO CHPRN("ip"_$PIECE(XWBTIP,".",3,4)_":"_XWBTDEV)
- +33 ;
- RESTART ;The error trap returns to here
- +1 NEW $ESTACK
- SET $ETRAP="D ETRAP^XWBTCPM(0)"
- +2 SET DT=$$DT^XLFDT
- SET DTIME=30
- +3 USE XWBTDEV
- DO MAIN
- +4 DO LOG("Exit: "_XWBTBUF)
- +5 ;Turn off the error trap for the exit
- +6 SET $ETRAP=""
- +7 ;Logout
- DO EXIT
- +8 KILL XWBR,XWBARY
- +9 ;stop RUM for handler XWB*1.1*5
- +10 DO LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2)
- +11 DO USE^%ZISUTL("XWBNULL")
- DO CLOSE^%ZISUTL("XWBNULL")
- +12 ;Close in the calling script
- +13 KILL SOCK,TYPE,XWBSND,XWBTYPE,XWBRBUF
- +14 QUIT
- +15 ;
- MAIN ; -- main message processing loop. debug at MAIN+1
- +1 FOR
- Begin DoDot:1
- +2 ;Setup
- +3 SET XWBAPVER=0
- SET XWBTBUF=""
- SET XWBTCMD=""
- SET XWBRBUF=""
- +4 KILL XWBR,XWBARY,XWBPRT
- +5 ; -- read client request
- +6 SET XR=$$BREAD^XWBRW(1,XWBTIME,1)
- +7 IF '$LENGTH(XR)
- DO LOG("Timeout: "_XWBTIME)
- SET XWBTBUF="#BYE#"
- QUIT
- +8 SET XR=XR_$$BREAD^XWBRW(4)
- +9 ;Check for exit
- IF XR="#BYE#"
- Begin DoDot:2
- +10 DO QSND^XWBRW("#BYE#")
- DO LOG("BYE CMD")
- SET XWBTBUF="#BYE#"
- +11 QUIT
- End DoDot:2
- QUIT
- +12 ;check HDR
- SET TYPE=(XR="[XWB]")
- +13 IF 'TYPE
- DO LOG("Bad Header: "_XR)
- QUIT
- +14 ;Read the NEW Msg parameters and call RPC
- DO CALLP^XWBPRS(.XWBR,$GET(XWBDEBUG))
- +15 IF XWBTCMD="#BYE#"
- Begin DoDot:2
- +16 DO QSND^XWBRW("#BYE#")
- DO LOG("BYE CMD")
- SET XWBTBUF=XWBTCMD
- +17 QUIT
- End DoDot:2
- QUIT
- +18 USE XWBTDEV
- +19 SET XWBPTYPE=$SELECT('$DATA(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
- +20 ;I $G(XWBPRT) D RETURN^XWBPRS2 Q ;New msg return
- +21 ;Return data,flush buffer
- IF '$GET(XWBPRT)
- DO SND^XWBRW
- End DoDot:1
- if XWBTBUF="#BYE#"
- QUIT
- +22 ;End Of Main
- QUIT
- +23 ;
- +24 ;
- ETRAP(EXIT) ; -- on trapped error, send error info to client
- +1 NEW XWBERC,XWBERR
- +2 ;Change trapping during trap.
- +3 SET $ETRAP="D ^%ZTER,ETRAP^XWBTCPM(1)"
- +4 SET XWBERC=$EXTRACT($$EC^%ZOSV,1,200)
- SET XWBERR="M ERROR="_XWBERC_$CHAR(13,10)_"LAST REF="_$$LGR^%ZOSV
- +5 IF $ECODE["U411"
- SET XWBERROR="U411"
- SET XWBSEC=""
- SET XWBERR="Data Transfer Error to Server"
- +6 ;%ZTER clears $ZE and $ZCODE
- DO ^%ZTER
- +7 ;Log
- DO LOG("In ETRAP: "_XWBERC)
- +8 IF (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F")!(XWBERC["IOEOF")
- DO EXIT
- XECUTE "HALT "
- +9 USE XWBTDEV
- +10 IF $GET(XWBT("PCNT"))
- LOCK +^XUTL("XUSYS",$JOB,0):99
- +11 ;Clear Locks
- IF '$TEST
- LOCK
- +12 ;
- +13 DO ESND^XWBRW($CHAR(24)_XWBERR_$CHAR(4))
- +14 IF EXIT
- DO EXIT
- XECUTE "HALT "
- +15 SET $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" D CLEANP^XWBTCPM G RESTART^XWBTCPM"
- SET $ECODE=",U99,"
- +16 QUIT
- +17 ;
- CLEANP ;Clean up the partion
- +1 NEW XWBTDEV,XWBNULL
- DO KILL^XUSCLEAN
- +2 QUIT
- +3 ;
- STYPE(X,WRAP) ;For backward compatability only
- +1 IF $DATA(WRAP)
- QUIT $$RTRNFMT^XWBLIB($GET(X),WRAP)
- +2 QUIT $$RTRNFMT^XWBLIB(X)
- +3 ;
- BREAD(L,T) ;read tcp buffer, L is length
- +1 QUIT $$BREAD^XWBRW(L,$GET(T))
- +2 ;
- CHPRN(N) ;change process name
- +1 ;Change process name to N
- +2 DO SETNM^%ZOSV($EXTRACT(N,1,15))
- +3 QUIT
- +4 ;
- 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.1:$$BAT^XUPARAM,1:36000)
- SET XWBTIME(1)=5
- +3 QUIT
- TIMEOUT ;Do this on MAIN loop timeout
- +1 IF $GET(DUZ)>0
- DO QSND^XWBRW("#BYE#")
- 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 ;
- OS() ;Return the OS
- +1 QUIT $SELECT(^%ZOSF("OS")["OpenM":"OpenM",^%ZOSF("OS")["GT.M":"GT.M",^("OS")["DSM":"DSM",1:"UNK")
- +2 ;
- INIT ;Setup
- +1 SET U="^"
- SET XWBTIME=10
- SET XWBOS=$$OS
- SET XWBDEBUG=0
- SET XWBRBUF=""
- +2 SET XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG")
- +3 SET XWBT("BF")=$SELECT(XWBOS="GT.M":"#",1:"!")
- +4 SET XWBT("PCNT")=0
- IF XWBOS="GT.M"
- IF $LENGTH($TEXT(^XUSCNT))
- SET XWBT("PCNT")=1
- +5 DO LOGSTART^XWBDLOG("XWBTCPM")
- +6 QUIT
- +7 ;
- DEBUG ;Entry point for debug, Build a server to get the connect
- +1 ;Cache sample;ZB SERV+1^XWBTCPM:"L+" ZB ETRAP+1^XWBTCPM:"B"
- +2 WRITE !,"Before running this entry point set your debugger to stop at"
- +3 WRITE !,"the place you want to debug. Some spots to use:"
- +4 WRITE !,"'SERV+1^XWBTCPM', 'MAIN+1^XWBTCPM' or 'CAPI+1^XWBPRS.'",!
- +5 WRITE !,"or location of your choice.",!
- +6 WRITE !,"IP Socket to Listen on: "
- READ SOCK:300,!
- if '$TEST!(SOCK["^")
- QUIT
- +7 ;Use %ZISTCP to do a single server
- +8 DO LISTEN^%ZISTCP(SOCK,"SERV^XWBTCPM")
- +9 USE $PRINCIPAL
- WRITE !,"Done"
- +10 QUIT
- SERV ;Callback from the server
- +1 SET XWBTDEV=IO
- SET XWBTIME(1)=3600
- DO INIT
- +2 ;R MSG#5
- SET XWBDEBUG=1
- SET MSG=$$BREAD^XWBRW(5,60)
- +3 DO NEW
- +4 ;Cause the Listenr to stop
- SET IO("C")=1
- +5 QUIT
- +6 ;
- EXIT ;Close out
- +1 IF $GET(DUZ)
- DO LOGOUT^XUSRB
- +2 IF $GET(XWBT("PCNT"))
- DO COUNT^XUSCNT(-1)
- +3 QUIT
- +4 ;
- LOG(MSG) ;Record Debug Info
- +1 if $GET(XWBDEBUG)
- DO LOG^XWBDLOG(MSG)
- +2 QUIT
- +3 ;