source: WorldVistAEHR/trunk/r/RPC_BROKER-XWB/XWBTCPC.m@ 691

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

initial load of WorldVistAEHR

File size: 5.9 KB
Line 
1XWBTCPC ;ISC-SF/EG/VYD - TCP/IP PROCESS HANDLER ;08/25/2004 14:18
2 ;;1.1;RPC BROKER;**2,5,4,6,9,16,26,35**;Mar 28, 1997
3 ;Based on: XQORTCPH ;SLC/KCM - Service TCP Messages
4 ;Modified by ISC-SF/EG
5 ; 0. No longer supports old style OERR messages
6 ; 1. Makes call to RPC broker
7 ; 2. Result of an rpc call can be a closed form of global
8 ; 3. Can receive a large local array, within limits of job
9 ; partition size.
10 ; 4. Sets default device to NULL device prior to call, restores
11 ; at termination. Prevents garbage from 'talking' calls.
12 ; 5. All reads have a timeout.
13 ; 6. Intro message is sent when first connected.
14 ; 7. Uses callback model to connect to client
15 ;
16 ;
17EN(XWBTIP,XWBTSKT,DUZ,XWBVER,XWBCLMAN) ; -- Main entry point
18 N TYPE,XWBTBUF,XWBTBUF1,XWBTDEV,XWBTLEN,XWBTOS,XWBTRTN,XWBWRAP
19 N X,XWBL,XWB1,XWB2,Y,XWBTIME,XWBPTYPE,XWBPLEN,XWBNULL,XWBODEV,XWBRBUF
20 N XWBERROR,XWBSEC ;new error variable available to rpc calls
21 N IO,IOP,L,XWBAPVER,VL,XWBTHDR,XWBT
22 ;
23 ;Set up the error trap
24 S U="^",$ETRAP="D ^%ZTER,XUTL^XUSCLEAN H" ;XWB-30
25 S XWBOS=$$OS
26 S XWBT("BF")=$S(XWBOS="GT.M":"#",1:"!")
27 ;start RUM for Broker Handler XWB*1.1*5
28 D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
29 ;
30 S XWBCLMAN=$G(XWBCLMAN)
31 I '$D(XWBDEBUG) D ;(*p35)
32 . S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG")
33 . D LOGSTART^XWBDLOG("XWBTCPC")
34 . Q
35 I XWBDEBUG D LOG("Callback: "_XWBTIP_" :"_XWBTSKT) ;(*p35)
36 D SETTIME(1) ;Setup for sign-on time-out
37 ;Use Kernel to open the connection back to the client on new port
38 D CALL^%ZISTCP(XWBTIP,XWBTSKT) Q:POP S XWBTDEV=IO,IO(0)=IO
39 ;Attempt to share the license, Must have TCP port open first.
40 U XWBTDEV I $T(SHARELIC^%ZOSV)'="" D SHARELIC^%ZOSV(1)
41 ;setup null device "NULL"
42 S %ZIS="0H",IOP="NULL" D ^%ZIS S XWBNULL=IO I POP S XWBERROR="No NULL device" D ^%ZTER Q
43 D SAVDEV^%ZISUTL("XWBNULL")
44 I XWBOS="GTM" S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
45 ;change process name
46 S X="ip"_$P(XWBTIP,".",3,4)_":"_XWBTSKT
47 D SETNM^%ZOSV($E(X,1,15)),LOG("ProcName: "_X)
48RESTART ;(*p35)
49 N $ESTACK S $ETRAP="D ETRAP^XWBTCPC"
50 S U="^",DUZ=0,DUZ(0)="",DTIME=300
51 U XWBTDEV D MAIN
52 ;Turn off the error trap for the exit
53 S $ETRAP=""
54 I $G(DUZ) D LOGOUT^XUSRB
55 K XWBR,XWBARY
56 ;stop RUM for handler XWB*1.1*5
57 D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2)
58 D LOG("DUZ="_$G(DUZ)_" LOGGED OFF")
59 D USE^%ZISUTL("XWBNULL"),CLOSE^%ZISUTL("XWBNULL")
60 C XWBTDEV ;Close can get an error
61 Q
62 ;
63MAIN ; -- main message processing loop
64 N XCNT,XR
65 F D Q:XWBTBUF="#BYE#"
66 . S XWBAPVER=0,(XWBSEC,XWBERROR,XWBRBUF)=""
67 . U XWBTDEV ;Make sure we are reading from the right device
68 . ; -- read client request
69 . ;F XCNT=0:0 R XR#1:XWBTIME Q:(XR="{")!(XR="#") I '$T S XCNT=XCNT+1 Q:XCNT>5
70 . S XR=$$BREAD^XWBRW(1,XWBTIME,1)
71 . I '$L(XR) D LOG("Timeout"),TIMEOUT S XWBTBUF="#BYE#" Q
72 . S XWBTHDR=XR_$$BREAD^XWBRW(4) ;(*p35)
73 . I XWBTHDR["#BYE#" S XWBTBUF="#BYE#" Q ;Clear $C(4)
74 . S XWBTHDR=XWBTHDR_$$BREAD^XWBRW(6)
75 . I $G(XWBDEBUG)>1 D LOG("HDR Read:"_XWBTHDR_":")
76 . S TYPE=($E(XWBTHDR,1,5)="{XWB}") ;check HDR
77 . I 'TYPE D Q
78 . . D LOG("Bad Header: "_XWBTHDR) ;(*p35)
79 . . S XWBTBUF="#BYE#" D QSND^XWBRW(XWBTBUF) ;(*p35)
80 . . Q
81 . S XWBTLEN=$E(XWBTHDR,6,10),L=$E(XWBTHDR,11)
82 . I L="|" D ;(*p35) Save $T
83 . . S VL=$$BREAD^XWBRW(1),VL=$A(VL)
84 . . S XWBAPVER=$$BREAD^XWBRW(VL),XWBPLEN=$$BREAD^XWBRW(5) ;(*p35)
85 . E S XWBTBUF=$$BREAD^XWBRW(4),XWBPLEN=L_XWBTBUF ;(*p35)
86 . S XWBTBUF=$$BREAD^XWBRW(XWBPLEN) ;(*p35)
87 . I $P(XWBTBUF,U)="TCPconnect" D Q
88 . . D QSND^XWBRW("accept") ;Ack (*p35)
89 . IF TYPE D
90 . . K XWBR,XWBARY
91 . . IF XWBTBUF="#BYE#" D QSND^XWBRW("#BYE#") Q ; -- clean disconnect
92 . . S XWBTLEN=XWBTLEN-15
93 . . D CALLP^XWBBRK(.XWBR,XWBTBUF)
94 . . S XWBPTYPE=$S('$D(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
95 . IF XWBTBUF="#BYE#" D LOG("APP set #BYE#") Q ;(*p35)
96 . U XWBTDEV
97 . D SND^XWBRW ;Does SNDERR,SND,WRITE($C(4))
98 . I $G(XWBSHARE) D KILL1^XUSCLEAN ; CLEAN OUT PARTITION FOR SHARED BROKER
99 Q ;End Of Main
100 ;
101ETRAP ; -- on trapped error, send error info to client
102 N XWBERC,XWBERR
103 ;Change trapping during trap.
104 S $ETRAP="D ^%ZTER,BYE^XUSCLEAN,XUTL^XUSCLEAN HALT" ;XWB-30
105 S XWBERC=$E($$EC^%ZOSV,1,200),XWBERR="M ERROR="_XWBERC_$C(13,10)_"LAST REF="_$$LGR^%ZOSV
106 S XWBOS=$$OS
107 ;Check for short read, Tell Client to resend.
108 I $EC["U411" S XWBERROR="U411",XWBSEC="",XWBERR="Data Transfer Error to Server"
109 D ^%ZTER ;%ZTER clears $ZE and $ECODE
110 I $G(XWBDEBUG) D LOG("In ETRAP: "_XWBERC) ;(*p35)
111 I ($G(XWBERC)["READ")!($G(XWBERC)["WRITE")!($G(XWBERC)["SYSTEM-F")!('$D(XWBERC)) D:$G(DUZ) LOGOUT^XUSRB HALT ; XWB-30
112 U XWBTDEV
113 L ;Clear locks (*p35)
114ETX ;Exit for trap
115 D ESND^XWBRW($C(24)_XWBERR_$C(4)) ;(p*35)
116 S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" G RESTART^XWBTCPC",$ECODE=",U99,"
117 Q
118 ;
119STYPE(X,WRAP) ;For backward compatability only
120 I $D(WRAP) Q $$RTRNFMT^XWBLIB($G(X),WRAP)
121 Q $$RTRNFMT^XWBLIB(X)
122 ;
123SETTIME(%) ;Set the Read timeout 0=RPC, 1=sign-on
124 ; Increased timeout period (%=1) during signon from 90 to 180 for accessibility reasons
125 S XWBTIME=$S($G(%):180,$G(XWBVER)>1.105:$$BAT^XUPARAM,1:36000),XWBTIME(1)=5 ; (*p35)
126 I $G(%) S XWBTIME=$S($G(XWBVER)>1.1:90,1:36000)
127 Q
128TIMEOUT ;Do this on MAIN loop timeout
129 I $G(DUZ)>0 D QSND^XWBRW("#BYE#"_$C(4)) Q
130 ;Sign-on timeout
131 S XWBR(0)=0,XWBR(1)=1,XWBR(2)="",XWBR(3)="TIME-OUT",XWBPTYPE=2
132 D SND^XWBRW
133 Q
134 ;
135MSM ;entry point for MSERVER service - used by MSM
136 N XWBVER,LEN,MSG,X
137 S XWBVER=0
138 R LEN#11:3600 IF $E(LEN,1,5)'="{XWB}" D Q ;bad client, abort
139 . W "RPC broker disconnect!",!
140 . C 56
141 . Q
142 IF $E(LEN,11,11)="|" D
143 . R X#1:60
144 . R XWBVER#$A(X):60
145 . R LEN#5:60
146 . R MSG#LEN:60
147 . Q
148 ELSE S X=$E(LEN,11,11),LEN=$E(LEN,6,10)-1 R MSG#LEN:60 S MSG=X_MSG
149 IF $P(MSG,"^")="TCPconnect" D
150 . D QSND^XWBRW("accept")
151 . C 56
152 . D EN($P(MSG,"^",2),$P(MSG,"^",3),$P(X,"^"),XWBVER,$P(MSG,"^",4))
153 IF $P(MSG,"^")="TCPdebug" D
154 . D QSND^XWBRW("accept")
155 C 56
156 Q
157OS() ;Return the OS
158 N % S %=^%ZOSF("OS") ;(*p35)
159 Q $S(%["DSM":"DSM",%["OpenM":"OpenM",%["GT.M":"GTM",1:"MSM") ;(*p35)
160 ;
161LOG(TX) ;DeBug Logging (*p35)
162 D:$G(XWBDEBUG) LOG^XWBDLOG(TX)
163 Q
Note: See TracBrowser for help on using the repository browser.