| [613] | 1 | XWBTCPM ;ISF/RWF - BROKER TCP/IP PROCESS HANDLER ;8/29/07 22:11
|
|---|
| 2 | ;;1.1;RPC BROKER;**35,43,49**;Mar 28, 1997;Build 6
|
|---|
| 3 | ;Based on: XWBTCPC & XWBTCPL, Modified by ISF/RWF
|
|---|
| 4 | ;Changed to be started by UCX or %ZISTCPS
|
|---|
| 5 | ;
|
|---|
| 6 | DSM ;DSM called from ucx, % passed in with device.
|
|---|
| 7 | D ESET
|
|---|
| 8 | ;Open the device
|
|---|
| 9 | S XWBTDEV=% X "O XWBTDEV:(TCPDEV):60" ;Special UCX/DSM open
|
|---|
| 10 | ;Go find the connection type
|
|---|
| 11 | U XWBTDEV
|
|---|
| 12 | G CONNTYPE
|
|---|
| 13 | ;
|
|---|
| 14 | CACHEVMS ;Cache'/VMS tcpip entry point, called from XWBTCP_START.COM file
|
|---|
| 15 | D ESET
|
|---|
| 16 | S XWBTDEV="SYS$NET"
|
|---|
| 17 | ; **Cache'/VMS specific code**
|
|---|
| 18 | O XWBTDEV::5
|
|---|
| 19 | X "U XWBTDEV:(::""-M"")" ;Packet mode like DSM
|
|---|
| 20 | G CONNTYPE
|
|---|
| 21 | ;
|
|---|
| 22 | NT ;entry from ZISTCPS
|
|---|
| 23 | ;JOB LISTEN^%ZISTCPS("port","NT^XWBTCPM","stop code")
|
|---|
| 24 | D ESET
|
|---|
| 25 | S XWBTDEV=IO
|
|---|
| 26 | G CONNTYPE
|
|---|
| 27 | ;
|
|---|
| 28 | GTMUCX(%) ;From ucx ZFOO
|
|---|
| 29 | ;If called from LISTEN^%ZISTCP(PORT,"GTM^XWBTCPM") S XWBTDEV=IO
|
|---|
| 30 | D ESET
|
|---|
| 31 | ;GTM specific code
|
|---|
| 32 | S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
|
|---|
| 33 | S XWBTDEV=% X "O %:(RECORDSIZE=512)"
|
|---|
| 34 | G CONNTYPE
|
|---|
| 35 | ;
|
|---|
| 36 | GTMLNX ;From Linux xinetd script
|
|---|
| 37 | D ESET
|
|---|
| 38 | ;GTM specific code
|
|---|
| 39 | S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
|
|---|
| 40 | S XWBTDEV=$P X "U XWBTDEV:(nowrap:nodelimiter:ioerror=""TRAP"")"
|
|---|
| 41 | S %="",@("%=$ZTRNLNM(""REMOTE_HOST"")") S:$L(%) IO("GTM-IP")=%
|
|---|
| 42 | G CONNTYPE
|
|---|
| 43 | ;
|
|---|
| 44 | ESET ;Set inital error trap
|
|---|
| 45 | S U="^",$ETRAP="D ^%ZTER H" ;Set up the error trap
|
|---|
| 46 | S X="",@^%ZOSF("TRAP") ;Clear old trap
|
|---|
| 47 | Q
|
|---|
| 48 | ;Find the type of connection and jump to the processing routine.
|
|---|
| 49 | CONNTYPE ;
|
|---|
| 50 | N XWBDEBUG,XWBAPVER,XWBCLMAN,XWBENVL,XWBLOG,XWBOS,XWBPTYPE
|
|---|
| 51 | N XWBTBUF,XWBTIP,XWBTSKT,XWBVER,XWBWRAP,XWBSHARE,XWBT
|
|---|
| 52 | N SOCK,TYPE
|
|---|
| 53 | D INIT
|
|---|
| 54 | S XWB=$$BREAD^XWBRW(5,XWBTIME)
|
|---|
| 55 | D LOG("MSG format is "_XWB_" type "_$S(XWB="[XWB]":"NEW",XWB="{XWB}":"OLD",XWB="<?xml":"M2M",1:"Unk"))
|
|---|
| 56 | I XWB["[XWB]" G NEW
|
|---|
| 57 | I XWB["{XWB}" G OLD^XWBTCPM1
|
|---|
| 58 | I XWB["<?xml" G M2M
|
|---|
| 59 | I $L($T(OTH^XWBTCPM2)) D OTH^XWBTCPM2 ;See if a special code.
|
|---|
| 60 | D LOG("Prefix not known: "_XWB)
|
|---|
| 61 | Q
|
|---|
| 62 | ;
|
|---|
| 63 | NEWJOB() ;Check if OK to start a new job, Return 1 if OK, 0 if not OK.
|
|---|
| 64 | N X,Y,J,XWBVOL
|
|---|
| 65 | D GETENV^%ZOSV S XWBVOL=$P(Y,"^",2)
|
|---|
| 66 | 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")
|
|---|
| 67 | I $G(^%ZIS(14.5,"LOGON",XWBVOL)) Q 0 ;Check INHIBIT LOGONS?
|
|---|
| 68 | I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(J,U,3),($P(J,U,3)'>Y) Q 0
|
|---|
| 69 | Q 1
|
|---|
| 70 | ;
|
|---|
| 71 | M2M ;M2M Broker
|
|---|
| 72 | S XWBRBUF=XWB_XWBRBUF,(IO,IO(0))=XWBTDEV G SPAWN^XWBVLL
|
|---|
| 73 | Q
|
|---|
| 74 | ;
|
|---|
| 75 | NEW ;New broker
|
|---|
| 76 | S U="^",DUZ=0,DUZ(0)="",XWBVER=1.108
|
|---|
| 77 | D SETTIME(1) ;Setup for sign-on timeout
|
|---|
| 78 | U XWBTDEV D
|
|---|
| 79 | . N XWB,ERR,NATIP,I
|
|---|
| 80 | . S ERR=$$PRSP^XWBPRS
|
|---|
| 81 | . S ERR=$$PRSM^XWBPRS
|
|---|
| 82 | . S MSG=$G(XWB(4,"CMD")) ;Build connect msg.
|
|---|
| 83 | . S I="" F S I=$O(XWB(5,"P",I)) Q:I="" S MSG=MSG_U_XWB(5,"P",I)
|
|---|
| 84 | . ;Get the peer and save that IP.
|
|---|
| 85 | . S NATIP=$$GETPEER^%ZOSV S:'$L(NATIP) NATIP=$P(MSG,"^",2)
|
|---|
| 86 | . I NATIP'=$P(MSG,"^",2) S $P(MSG,"^",2)=NATIP
|
|---|
| 87 | . Q
|
|---|
| 88 | S X=$$NEWJOB() D:'X LOG("No New Connects")
|
|---|
| 89 | I ($P(MSG,U)'="TCPConnect")!('X) D QSND^XWBRW("reject"),LOG("reject: "_MSG) Q
|
|---|
| 90 | D QSND^XWBRW("accept"),LOG("accept") ;Ack
|
|---|
| 91 | S IO("IP")=$P(MSG,U,2),XWBTSKT=$P(MSG,U,3),XWBCLMAN=$P(MSG,U,4)
|
|---|
| 92 | S XWBTIP=$G(IO("IP"))
|
|---|
| 93 | ;start RUM for Broker Handler XWB*1.1*5
|
|---|
| 94 | D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
|
|---|
| 95 | ;GTM
|
|---|
| 96 | I $G(XWBT("PCNT")) D
|
|---|
| 97 | . S X=$NA(^XUTL("XUSYS",$J,1)) L +@X:0
|
|---|
| 98 | . D COUNT^XUSCNT(1),SETLOCK^XUSCNT(X)
|
|---|
| 99 | ;We don't use a callback
|
|---|
| 100 | K XWB,CON,LEN,MSG ;Clean up
|
|---|
| 101 | ;Attempt to share license, Must have TCP port open first.
|
|---|
| 102 | U XWBTDEV ;D SHARELIC^%ZOSV(1)
|
|---|
| 103 | ;setup null device "NULL"
|
|---|
| 104 | S %ZIS="0H",IOP="NULL" D ^%ZIS S XWBNULL=IO I POP S XWBERROR="No NULL device" D ^%ZTER,EXIT Q
|
|---|
| 105 | D SAVDEV^%ZISUTL("XWBNULL")
|
|---|
| 106 | ;change process name
|
|---|
| 107 | D CHPRN("ip"_$P(XWBTIP,".",3,4)_":"_XWBTDEV)
|
|---|
| 108 | ;
|
|---|
| 109 | RESTART ;The error trap returns to here
|
|---|
| 110 | N $ESTACK S $ETRAP="D ETRAP^XWBTCPM"
|
|---|
| 111 | S DT=$$DT^XLFDT,DTIME=30
|
|---|
| 112 | U XWBTDEV D MAIN
|
|---|
| 113 | D LOG("Exit: "_XWBTBUF)
|
|---|
| 114 | ;Turn off the error trap for the exit
|
|---|
| 115 | S $ETRAP=""
|
|---|
| 116 | D EXIT ;Logout
|
|---|
| 117 | K XWBR,XWBARY
|
|---|
| 118 | ;stop RUM for handler XWB*1.1*5
|
|---|
| 119 | D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2)
|
|---|
| 120 | D USE^%ZISUTL("XWBNULL"),CLOSE^%ZISUTL("XWBNULL")
|
|---|
| 121 | ;Close in the calling script
|
|---|
| 122 | K SOCK,TYPE,XWBSND,XWBTYPE,XWBRBUF
|
|---|
| 123 | Q
|
|---|
| 124 | ;
|
|---|
| 125 | MAIN ; -- main message processing loop. debug at MAIN+1
|
|---|
| 126 | F D Q:XWBTBUF="#BYE#"
|
|---|
| 127 | . ;Setup
|
|---|
| 128 | . S XWBAPVER=0,XWBTBUF="",XWBTCMD="",XWBRBUF=""
|
|---|
| 129 | . K XWBR,XWBARY,XWBPRT
|
|---|
| 130 | . ; -- read client request
|
|---|
| 131 | . S XR=$$BREAD^XWBRW(1,XWBTIME,1)
|
|---|
| 132 | . I '$L(XR) D LOG("Timeout: "_XWBTIME) S XWBTBUF="#BYE#" Q
|
|---|
| 133 | . S XR=XR_$$BREAD^XWBRW(4)
|
|---|
| 134 | . I XR="#BYE#" D Q ;Check for exit
|
|---|
| 135 | . . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF="#BYE#"
|
|---|
| 136 | . . Q
|
|---|
| 137 | . S TYPE=(XR="[XWB]") ;check HDR
|
|---|
| 138 | . I 'TYPE D LOG("Bad Header: "_XR) Q
|
|---|
| 139 | . D CALLP^XWBPRS(.XWBR,$G(XWBDEBUG)) ;Read the NEW Msg parameters and call RPC
|
|---|
| 140 | . IF XWBTCMD="#BYE#" D Q
|
|---|
| 141 | . . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF=XWBTCMD
|
|---|
| 142 | . . Q
|
|---|
| 143 | . U XWBTDEV
|
|---|
| 144 | . S XWBPTYPE=$S('$D(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
|
|---|
| 145 | . ;I $G(XWBPRT) D RETURN^XWBPRS2 Q ;New msg return
|
|---|
| 146 | . I '$G(XWBPRT) D SND^XWBRW ;Return data,flush buffer
|
|---|
| 147 | Q ;End Of Main
|
|---|
| 148 | ;
|
|---|
| 149 | ;
|
|---|
| 150 | ETRAP ; -- on trapped error, send error info to client
|
|---|
| 151 | N XWBERC,XWBERR
|
|---|
| 152 | ;Change trapping during trap.
|
|---|
| 153 | S $ETRAP="D ^%ZTER,EXIT^XWBTCPM HALT"
|
|---|
| 154 | S XWBERC=$E($$EC^%ZOSV,1,200),XWBERR="M ERROR="_XWBERC_$C(13,10)_"LAST REF="_$$LGR^%ZOSV
|
|---|
| 155 | I $EC["U411" S XWBERROR="U411",XWBSEC="",XWBERR="Data Transfer Error to Server"
|
|---|
| 156 | D ^%ZTER ;%ZTER clears $ZE and $ZCODE
|
|---|
| 157 | D LOG("In ETRAP: "_XWBERC) ;Log
|
|---|
| 158 | I (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F")!(XWBERC["IOEOF") D EXIT HALT
|
|---|
| 159 | U XWBTDEV
|
|---|
| 160 | I $G(XWBT("PCNT")) L ^XUTL("XUSYS",$J,0)
|
|---|
| 161 | E L ;Clear Locks
|
|---|
| 162 | ;I XWBOS'="DSM" D
|
|---|
| 163 | S XWBPTYPE=1 ;So SNDERR won't check XWBR
|
|---|
| 164 | ;D SNDERR^XWBRW,WRITE^XWBRW($C(24)_XWBERR_$C(4))
|
|---|
| 165 | D ESND^XWBRW($C(24)_XWBERR_$C(4))
|
|---|
| 166 | S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" D CLEANP^XWBTCPM G RESTART^XWBTCPM",$ECODE=",U99,"
|
|---|
| 167 | Q
|
|---|
| 168 | ;
|
|---|
| 169 | CLEANP ;Clean up the partion
|
|---|
| 170 | N XWBTDEV,XWBNULL D KILL^XUSCLEAN
|
|---|
| 171 | Q
|
|---|
| 172 | ;
|
|---|
| 173 | STYPE(X,WRAP) ;For backward compatability only
|
|---|
| 174 | I $D(WRAP) Q $$RTRNFMT^XWBLIB($G(X),WRAP)
|
|---|
| 175 | Q $$RTRNFMT^XWBLIB(X)
|
|---|
| 176 | ;
|
|---|
| 177 | BREAD(L,T) ;read tcp buffer, L is length
|
|---|
| 178 | Q $$BREAD^XWBRW(L,$G(T))
|
|---|
| 179 | ;
|
|---|
| 180 | CHPRN(N) ;change process name
|
|---|
| 181 | ;Change process name to N
|
|---|
| 182 | D SETNM^%ZOSV($E(N,1,15))
|
|---|
| 183 | Q
|
|---|
| 184 | ;
|
|---|
| 185 | SETTIME(%) ;Set the Read timeout 0=RPC, 1=sign-on
|
|---|
| 186 | S XWBTIME=$S($G(%):90,$G(XWBVER)>1.105:$$BAT^XUPARAM,1:36000),XWBTIME(1)=2
|
|---|
| 187 | I $G(%) S XWBTIME=$S($G(XWBVER)>1.1:90,1:36000)
|
|---|
| 188 | Q
|
|---|
| 189 | TIMEOUT ;Do this on MAIN loop timeout
|
|---|
| 190 | I $G(DUZ)>0 D QSND^XWBRW("#BYE#") Q
|
|---|
| 191 | ;Sign-on timeout
|
|---|
| 192 | S XWBR(0)=0,XWBR(1)=1,XWBR(2)="",XWBR(3)="TIME-OUT",XWBPTYPE=2
|
|---|
| 193 | D SND^XWBRW
|
|---|
| 194 | Q
|
|---|
| 195 | ;
|
|---|
| 196 | OS() ;Return the OS
|
|---|
| 197 | Q $S(^%ZOSF("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["OpenM":"OpenM",1:"MSM")
|
|---|
| 198 | ;
|
|---|
| 199 | INIT ;Setup
|
|---|
| 200 | S U="^",XWBTIME=10,XWBOS=$$OS,XWBDEBUG=0,XWBRBUF=""
|
|---|
| 201 | S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG")
|
|---|
| 202 | S XWBT("BF")=$S(XWBOS="GT.M":"#",1:"!")
|
|---|
| 203 | S XWBT("PCNT")=0 I XWBOS="GT.M",$L($T(^XUSCNT)) S XWBT("PCNT")=1
|
|---|
| 204 | D LOGSTART^XWBDLOG("XWBTCPM")
|
|---|
| 205 | Q
|
|---|
| 206 | ;
|
|---|
| 207 | DEBUG ;Entry point for debug, Build a server to get the connect
|
|---|
| 208 | ;DSM sample;ZDEBUG ON S $ZB(1)="SERV+1^XWBTCPM:1",$ZB="ETRAP+1^XWBTCPM:1"
|
|---|
| 209 | W !,"Before running this entry point set your debugger to stop at"
|
|---|
| 210 | W !,"the place you want to debug. Some spots to use:"
|
|---|
| 211 | W !,"'SERV+1^XWBTCPM', 'MAIN+1^XWBTCPM' or 'CAPI+1^XWBPRS.'",!
|
|---|
| 212 | W !,"or location of your choice.",!
|
|---|
| 213 | W !,"IP Socket to Listen on: " R SOCK:300 Q:'$T!(SOCK["^")
|
|---|
| 214 | ;Use %ZISTCP to do a single server
|
|---|
| 215 | D LISTEN^%ZISTCP(SOCK,"SERV^XWBTCPM")
|
|---|
| 216 | U $P W !,"Done"
|
|---|
| 217 | Q
|
|---|
| 218 | SERV ;Callback from the server
|
|---|
| 219 | S XWBTDEV=IO,XWBTIME(1)=3600 D INIT
|
|---|
| 220 | S XWBDEBUG=1,MSG=$$BREAD^XWBRW(5,60) ;R MSG#5
|
|---|
| 221 | D NEW
|
|---|
| 222 | S IO("C")=1 ;Cause the Listenr to stop
|
|---|
| 223 | Q
|
|---|
| 224 | ;
|
|---|
| 225 | EXIT ;Close out
|
|---|
| 226 | I $G(DUZ) D LOGOUT^XUSRB
|
|---|
| 227 | I $G(XWBT("PCNT")) D COUNT^XUSCNT(-1)
|
|---|
| 228 | Q
|
|---|
| 229 | ;
|
|---|
| 230 | LOG(MSG) ;Record Debug Info
|
|---|
| 231 | D:$G(XWBDEBUG) LOG^XWBDLOG(MSG)
|
|---|
| 232 | Q
|
|---|
| 233 | ;
|
|---|
