source: FOIAVistA/trunk/r/RPC_BROKER-XWB/XWBTCPM.m@ 765

Last change on this file since 765 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

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