source: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZMGWSIS.m@ 775

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

initial load of WorldVistAEHR

File size: 32.4 KB
RevLine 
[613]1%ZMGWSIS ; Service Integration - Child Process
2 ;
3 ; ----------------------------------------------------------------------------
4 ; | m_apache |
5 ; | Copyright (c) 2004-2009 M/Gateway Developments Ltd, |
6 ; | Surrey UK. |
7 ; | All rights reserved. |
8 ; | |
9 ; | http://www.mgateway.com |
10 ; | |
11 ; | This program is free software: you can redistribute it and/or modify |
12 ; | it under the terms of the GNU Affero General Public License as |
13 ; | published by the Free Software Foundation, either version 3 of the |
14 ; | License, or (at your option) any later version. |
15 ; | |
16 ; | This program is distributed in the hope that it will be useful, |
17 ; | but WITHOUT ANY WARRANTY; without even the implied warranty of |
18 ; | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
19 ; | GNU Affero General Public License for more details. |
20 ; | |
21 ; | You should have received a copy of the GNU Affero General Public License |
22 ; | along with this program. If not, see <http://www.gnu.org/licenses/>. |
23 ; ----------------------------------------------------------------------------
24 ;
25A0 D VERS Q
26 ;f i=1:1:10000 s x=$$esize(.y,i,62),z=$$dsize(y,$l(y),62) w !,i,?10,y,?20,z
27 q
28 ;
29V() ; Version and date
30 N V,R,D
31 S V="2.0"
32 S R=6
33 S D="17 February 2009"
34 Q V_"."_R_"."_D
35 ;
36VERS ; Version information
37 N V
38 S V=$$V()
39 W !,"M/Gateway Developments Ltd - Service Integration Gateway"
40 W !,"Version: "_$P(V,".",1,2)_"; Revision "_$P(V,".",3)_" ("_$P(V,".",4)_")"
41 W !
42 Q
43 ;
44VARS ; Public system variables
45 ;
46 ; The following variables can be modified in accordance with the documentation
47 s extra=$c(1) ; Key marker for oversize data strings
48 s abyref=0 ; Set to 1 to treat all arrays as if they were passed by reference
49 s mqinfo=0 ; Set to 1 to place all MQ error/information messages in %mgwmq("info")
50 ; Otherwise, error messages will be placed in %mgwmq("error")
51 ; and 'information only' messages in %mgwmq("info")
52 ;
53 ; The following variables must not be modified
54 i '($d(global)#10) s global=0
55 i '($d(oversize)#10) s oversize=0
56 i '($d(offset)#10) s offset=0
57 i '($d(version)#10) s version=+$$V()
58 ; #define MGW_TX_DATA 0
59 ; #define MGW_TX_AKEY 1
60 ; #define MGW_TX_AREC 2
61 ; #define MGW_TX_EOD 3
62 s ddata=0,dakey=1,darec=2,deod=3
63 q
64 ;
65esize(esize,size,base)
66 n i,x
67 i base'=10 g esize1
68 s esize=size
69 q $l(esize)
70esize1 ; Up to base 62
71 s esize=$$ebase62(size#base)
72 f i=1:1 s x=(size\(base**i)) q:'x s esize=$$ebase62(x#base)_esize
73 q $l(esize)
74 ;
75dsize(esize,len,base)
76 n i,x
77 i base'=10 g dsize1
78 s size=+$e(esize,1,len)
79 q size
80dsize1 ; Up to base 62
81 s size=0
82 f i=len:-1:1 s x=$e(esize,i) s size=size+($$dbase62(x)*(base**(len-i)))
83 q size
84 ;
85ebase62(n10) ; Encode to single digit (up to) base-62 number
86 i n10'<0,n10<10 q $c(48+n10)
87 i n10'<10,n10<36 q $c(65+(n10-10))
88 i n10'<36,n10<62 q $c(97+(n10-36))
89 q ""
90 ;
91dbase62(nxx) ; Decode single digit (up to) base-62 number
92 n x
93 s x=$a(nxx)
94 i x'<48,x<58 q (x-48)
95 i x'<65,x<91 q ((x-65)+10)
96 i x'<97,x<123 q ((x-97)+36)
97 q ""
98 ;
99ehead(head,size,byref,type)
100 s slen=$$esize(.esize,size,10)
101 s code=slen+(type*8)+(byref*64)
102 s head=$c(code)_esize
103 s hlen=slen+1
104 q hlen
105 ;
106dhead(head,size,byref,type)
107 s code=$a(head,1)
108 s byref=code\64
109 s type=(code#64)\8
110 s slen=code#8
111 s hlen=slen+1
112 s size=0 i $l(head)'<hlen s size=$$dsize($e(head,2,slen+1),slen,10)
113 q hlen
114 ;
115rdxx(len) ; Read 'len' Bytes from MGWSI
116 n x,nmax,n,ncnt
117 i 'len q ""
118 s x="",nmax=len,n=0,ncnt=0 f r y#nmax d q:'nmax i ncnt>100 q
119 . i y="" s ncnt=ncnt+1 q
120 . s ncnt=0,x=x_y,n=n+$l(y),nmax=len-n
121 . q
122 i ncnt s x="" d HALT ; Client disconnect
123 q x
124 ;
125rdx(len,clen,rlen) ; Read from MGWSI - Initialize: (rdxsize,rdxptr,rdxrlen)=0,rdxbuf="",maxlen=$$getslen()
126 n result,get,avail
127 ;
128 ;s result="" f get=1:1:len r *x s result=result_$c(x)
129 ;s rlen=rlen+len q result
130 ;
131 s get=len,result=""
132 i 'len q result
133 f d i 'get q
134 . s avail=rdxsize-rdxptr
135 . ;d EVENT("i="_i_";len="_len_";avail="_avail_";get="_get_"=("_rdxbuf_") "_CLEN_" "_RLEN)
136 . i get'>avail s result=result_$e(rdxbuf,rdxptr+1,rdxptr+get),rdxptr=rdxptr+get,get=0 q
137 . s result=rdxbuf,rdxptr=0,get=get-avail
138 . s avail=clen-rdxrlen i 'avail q
139 . i avail>maxlen s avail=maxlen
140 . s rdxbuf=$$rdxx(avail),rdxsize=avail,rdxptr=0,rdxrlen=rdxrlen+avail
141 . ;d EVENT("rdxbuf="_i_"="_rdxbuf)
142 . q
143 s rlen=rlen+len
144 q result
145 ;
146CHILD(pport,port,conc,uci) ; Child
147 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":CHILDE"
148 i uci'="" D UCI(uci)
149 i 'conc d
150 . s ^%MGWSI("TCP_PORT",pport,port)=$j
151 . Set dev="server$"_$j,timeout=30
152 . ; Open TCP server device
153 . Open dev:(ZLISTEN=port_":TCP":attach="server"):timeout:"SOCKET"
154 . Use dev
155 . Write /listen(1)
156 . set %ZNSock="",%ZNFrom=""
157 . S OK=1 F D Q:OK I $D(^%MGWSI("STOP")) S OK=0 Q
158 . . Write /wait(timeout)
159 . . I $KEY'="" S OK=1 Q
160 . . d EVENT^%ZMGWSIS("Write /wait(timeout) expires")
161 . . S OK=0
162 . . Q
163 . I 'OK C dev H
164 . set %ZNSock=$piece($KEY,"|",2),%ZNFrom=$piece($KEY,"|",3)
165 . ;d EVENT^%ZMGWSIS("Incoming child connection from "_%ZNFrom_" ("_%ZNSock_")")
166 . q
167 ;
168 s nato=0
169CHILD2 ; Child request loop
170 d VARS
171 k ^%MGW("MPC",$J),^MGWSI($J)
172 f i=1:1:37 k @("req"_i)
173 k req s argc=1,array=0
174 i '($d(nato)#10) s nato=0
175CHILD3 ; Read Request
176 ;d EVENT("******* GET NEXT REQUEST *******")
177 s maxlen=$$getslen()
178 s (rdxsize,rdxptr,rdxrlen)=0,rdxbuf=""
179 s sn=0,sl=0,ok=1,type=0,offset=0,var="req"_argc,req(argc)=var,(cmnd,pcmnd,buf)=""
180 i 'nato r *x
181 i nato r *x:nato i '$T D HALT ; No-activity timeout
182 i x=0 D HALT ; Client disconnect
183 s buf=$c(x) f r *x q:x=10!(x=0) s buf=buf_$c(x)
184 i x=0 D HALT ; Client disconnect
185 s type=0,byref=0 d REQ1 s @var=buf
186 s cmnd=$p(buf,"^",2)
187 S HLEN=$L(buf),CLEN=0
188 I cmnd="P" S CLEN=$$dsize($E(buf,HLEN-(5-1),HLEN),5,62)
189 s %ZCS("client")=$E(buf,4)
190 ;d EVENT("request size="_CLEN_" ("_$E(buf,HLEN-(5-1),HLEN)_"); client="_%ZCS("client")_" ;header = "_buf)
191 s RLEN=0
192 I CLEN D REQ
193 ;
194 ;f i=1:1:argc d EVENT("arg "_i_" = "_$g(@req(i)))
195 ;
196 s req=$g(@req(1)) i req="" G CHILD2
197 s cmnd=$p(req,"^",2)
198 k res s res="" s res(1)="00000cv"_$C(10)
199 i cmnd="A" D AYT
200 i cmnd="S" D DINT
201 i cmnd="P" D MPHP
202 i cmnd="H" D INFO
203 i cmnd="X" D HALT
204 D END
205 k res s res=""
206 G CHILD2
207 ;
208CHILDE ; Error
209 d EVENT($ZS)
210 i $ZS["READ" g HALT
211 G CHILD2
212 ;
213HALT ; Halt
214 i 'conc d
215 . ; Close TCP server device
216 . i $l($g(dev)) c dev
217 . s x="" f s x=$o(^%MGWSI("TCP_PORT",x)) q:x="" k ^%MGWSI("TCP_PORT",x,port)
218 . q
219 h
220 ;
221REQ ; Read request data
222 n dev,get,got
223REQ0 ; Get next argument
224 s x=$$rdx(1,CLEN,.RLEN),hlen=$$dhead(x,.size,.byref,.type)
225 ;d EVENT("(1) CLEN="_CLEN_";RLEN="_RLEN_";hlen="_hlen_";argc="_argc_";size="_size_";byref="_byref_";type="_type)
226 s slen=hlen-1
227 s esize=$$rdx(slen,CLEN,.RLEN)
228 s size=$$dsize(esize,slen,10)
229 ;d EVENT("(2) CLEN="_CLEN_";RLEN="_RLEN_";hlen="_hlen_";slen="_slen_";argc="_argc_";size="_size_";byref="_byref_";type="_type)
230 s argc=argc+1
231 d REQ1
232 i type=darec d ARRAY G REQZ
233 s got=0 f sn=0:1 s get=size-got s:get>maxlen get=maxlen s buf=$$rdx(get,CLEN,.RLEN) d i got=size q
234 . s got=got+get
235 . ;d EVENT("(3) Data: CLEN="_CLEN_";RLEN="_RLEN_";size="_size_";get="_get_";sn="_sn_";pcmnd="_pcmnd_";buf="_buf)
236 . i argc=3,pcmnd="h" s @var=buf d MPC q
237 . i 'sn s @var=buf q
238 . i sn s @(var_"(extra,sn)")=buf q
239 . q
240REQZ ; Argument read
241 i RLEN<CLEN G REQ0
242 s eod=1
243 q
244 ;
245REQ1 ; Initialize next argument
246 i argc=1 d
247 . s cmnd=$p(buf,"^",2)
248 . s sysp=$p(buf,"^",3)
249 . s uci=$p(sysp,"#",2) i uci'="" d
250 . . s ucic=$$getuci()
251 . . i ucic'="",uci=ucic q
252 . . D UCI(uci) D EVENT("Correct NameSpace from '"_ucic_"' to '"_uci_"'")
253 . . q
254 . s offset=$p(sysp,"#",3)+0
255 . s global=$p(sysp,"#",7)+0
256 . s pcmnd=$p(buf,"^",4)
257 . q
258 s sn=0,sl=0
259 s var="req"_argc
260 s req(argc)=var
261 s req(argc,0)=type i type=darec s req(argc,0)=1
262 s req(argc,1)=byref
263 i type=1,abyref=1 s req(argc,1)=1
264 q
265 ;
266MPC ; Raw content for HTTP POST: save section of data
267 s sn=sn+1,^%MGW("MPC",$J,"CONTENT",sn)=buf,buf="",sl=0
268 q
269 ;
270ARRAY ; Read array
271 n x,kn,val,sn,ext,get,got
272 ;d EVENT("*** array ***")
273 k x,ext s kn=0
274ARRAY0 ; Read next element (key or data)
275 s sn=0,sl=0
276 s x=$$rdx(1,CLEN,.RLEN),hlen=$$dhead(x,.size,.byref,.type)
277 ;d EVENT("(1) Array CLEN="_CLEN_";RLEN="_RLEN_";hlen="_hlen_";argc="_argc_";size="_size_";byref="_byref_";type="_type)
278 s slen=hlen-1
279 s esize=$$rdx(slen,CLEN,.RLEN)
280 s size=$$dsize(esize,slen,10)
281 ;d EVENT("(2) Array CLEN="_CLEN_";RLEN="_RLEN_";hlen="_hlen_";slen="_slen_";argc="_argc_";size="_size_";byref="_byref_";type="_type)
282 i type=deod q
283 s got=0 f sn=0:1 s get=size-got s:get>maxlen get=maxlen s buf=$$rdx(get,CLEN,.RLEN) d i got=size q
284 . s got=got+get
285 . ;d EVENT("(3) Array Data CLEN="_CLEN_";RLEN="_RLEN_";size="_size_";get="_get_";sn="_sn_";pcmnd="_pcmnd_";buf="_buf)
286 . i argc=3,pcmnd="h" s @var=buf d MPC q
287 . i type=dakey s kn=kn+1,x(kn)=buf
288 . i type=ddata s val=buf D ARRAY1 k x,ext s kn=0
289 . q
290 g ARRAY0
291 ;
292ARRAY1 ; Read array - Set a single node
293 n n,i,ref,com,key
294 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":ARRAY1E"
295 s (key,com)="" f i=1:1:kn q:i=kn&($g(x(i))=" ") s key=key_com_"x("_i_")",com=","
296 i global d
297 . i $l(key) s ref="^MGWSI($j,argc-2,"_key_")",eref="^MGWSI($j,argc-2,"_key_",extra,sn)"
298 . i '$l(key) s ref="^MGWSI($j,argc-2)",eref="^MGWSI($j,argc-2,extra,sn)"
299 . q
300 i 'global d
301 . i $l(key) s ref=req(argc)_"("_key_")",eref=req(argc)_"("_key_",extra,sn)"
302 . i '$l(key) s ref=req(argc),eref=req(argc)_"(extra,sn)"
303 . q
304 i $l(ref) x "s "_ref_"=val"
305 f sn=1:1 q:'$d(ext(sn)) x "s "_eref_"=ext(sn)"
306 Q
307ARRAY1E ;
308 d EVENT("Array: "_$ZS)
309 Q
310 ;
311END ; Terminate Response
312 n len,len62,i,head,x
313 i $e($g(res(1)),6,7)="sc" w $p(res(1),"0",1) D FLUSH q ; Streamed response
314 s len=0
315 f i=1:1 q:'$d(res(i)) s len=len+$l(res(i))
316 s len=len-8
317 s head=$e($g(res(1)),1,8)
318 s x=$$esize(.len62,len,62)
319 f q:$l(len62)'<5 s len62="0"_len62
320 s head=len62_$e(head,6,8) i $l(head)'=8 s head=len62_"cv"_$c(10)
321 s res(1)=head_$e($g(res(1)),9,99999)
322 ; Flush the lot out
323 f i=1:1 q:'$d(res(i)) w res(i)
324 D FLUSH
325 Q
326 ;
327FLUSH ; Flush output buffer
328 ;w *-3
329 ;w *1
330 q
331 ;
332AYT ; Are you there?
333 S req=$g(@req(1))
334 s txt=$p($h,",",2)
335 f q:$l(txt)'<5 s txt="0"_txt
336 s txt="m"_txt
337 f q:$l(txt)'<12 s txt=txt_"0"
338 d send(txt)
339 q
340 ;
341DINT ; Initialise the service link
342 N port,dev,conc,%uci
343 S req=$p($g(@req(1)),"^S^",2,9999)
344 ;"^S^version=%s&timeout=%d&nls=%s&uci=%s"
345 S version=$p($p(req,"version=",2),"&",1)
346 S nato=+$p($p(req,"timeout=",2),"&",1)
347 S %ZCS("NLS_TRANS")=$p($p(req,"nls=",2),"&",1)
348 S %UCI=$p($p(req,"uci=",2),"&",1)
349 I $L(%UCI) D UCI(%UCI)
350 S x=$$setio(%ZCS("NLS_TRANS"))
351 S %UCI=$$getuci()
352 s systype=$$getsys()
353 s txt="pid="_$J_"&uci="_%UCI_"&server_type="_systype_"&version="_$p($$V(),".",1,3)_"&child_port=0"
354 d send(txt)
355 q
356 ;
357UCI(UCI) ; Change NameSpace/UCI
358 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":UCIE"
359 i UCI="" Q
360 s $ZG=UCI
361 Q
362UCIE ; Error
363 d EVENT("UCI Error: "_UCI_" : "_$ZS)
364 q
365 ;
366INFO ; Connection Info
367 n port,dev,conc,nato
368 d send("HTTP/1.1 200 OK"_$Char(13,10)_"Connection: close"_$Char(13,10)_"Content-type: text/html"_$Char(13,10,13,10))
369 d send("<html><head><title>MGWSI - Connection Test</title></head><body bgcolor=#ffffcc>")
370 d send("<h2>MGWSI - Connection Test Successful</h2>")
371 d send("<table border=1>")
372 d send("<tr><td>"_$$getsys()_" Version:</td><td><b>"_$ZV_"<b><tr>")
373 d send("<tr><td>UCI:</td><td><b>"_$$getuci()_"<b><tr>")
374 d send("</table>")
375 d send("</body></html>")
376 q
377 ;
378EVENT(TEXT) ; Log M-Side Event
379 N port,dev,conc,N,EMAX
380 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":EVENTE"
381 F I=1:1 S X=$E(TEXT,I) Q:X="" S Y=$S(X=$C(13):"\r",X=$C(10):"\n",1:"") I Y'="" S $E(TEXT,I)=Y
382 S EMAX=100 ; Maximum log size (No. messages)
383 L +^%MGWSI("LOG")
384 S N=$G(^%MGWSI("LOG")) I N="" S N=0
385 S N=N+1,^%MGWSI("LOG")=N
386 L -^%MGWSI("LOG")
387 S ^%MGWSI("LOG",N,0)=$$HEAD(),^%MGWSI("LOG",N,1)=$E(TEXT,1,230)
388 F N=N-EMAX:-1 Q:'$D(^%MGWSI("LOG",N)) K ^(N)
389 Q
390EVENTE ; Error
391 Q
392 ;
393DDATE(DATE) ; Decode M date
394 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":DATEE"
395 Q $ZD(DATE,2)
396DDATEE ; No $ZD Function
397 Q DATE
398 ;
399DTIME(TIME) ; Decode M Time
400 Q (TIME\3600)_":"_(TIME#3600\60)
401 ;
402HEAD() ; Format Header record
403 N %UCI
404 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":HEADE"
405 s %UCI=$$getuci()
406HEADE ; Error
407 Q $$DDATE(+$H)_" at "_$$DTIME($P($H,",",2))_"~"_$G(%ZCS("PORT"))_"~"_%UCI
408 ;
409HMACSHA256(string,key,b64,context) ; HMAC-SHA256
410 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"HMAC-SHA256",string,key,b64,context)
411 ;
412HMACSHA1(string,key,b64,context) ; HMAC-SHA1
413 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"HMAC-SHA1",string,key,b64,context)
414 ;
415HMACSHA(string,key,b64,context) ; HMAC-SHA
416 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"HMAC-SHA",string,key,b64,context)
417 ;
418HMACMD5(string,key,b64,context) ; HMAC-MD5
419 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"HMAC-MD5",string,key,b64,context)
420 ;
421SHA256(string,b64,context) ; SHA256
422 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"SHA256",string,"",b64,context)
423 ;
424SHA1(string,b64,context) ; SHA1
425 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"SHA1",string,"",b64,context)
426 ;
427SHA(string,b64,context) ; SHA
428 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"SHA",string,"",b64,context)
429 ;
430MD5(string,b64,context) ; MD5
431 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"MD5",string,"",b64,context)
432 ;
433B64(string,context) ; BASE64
434 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"B64",string,"",0,context)
435 ;
436DB64(string,context) ; DECODE BASE64
437 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"D-B64",string,"",0,context)
438 ;
439TIME(context) ; TIME
440 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"TIME","","",0,context)
441 ;
442ZTS(context) ; ZTS
443 S TIME=$$TIME(context)
444 S ZTS=$P($H,",",1)_","_(($P(TIME,":",1)*60*60)+($P(TIME,":",2)*60)+$P(TIME,":",3))
445 Q ZTS
446 ;
447CRYPT(IP,PORT,METHOD,string,key,b64,context)
448 n %mgwmq,response,method
449 s method=METHOD i b64 s method=method_"-B64"
450 s %mgwmq("send")=string
451 s %mgwmq("key")=key
452 i context=0 s response=$$WSMQ(IP,PORT,method,.%mgwmq)
453 i context=1 s response=$$WSX(IP,PORT,method,.%mgwmq)
454 Q $G(%mgwmq("recv"))
455 ;
456WSMQ(IP,PORT,REQUEST,%mgwmq) ; Message for WebSphere MQ (Parameters passed by reference)
457 Q $$WSMQ1(IP,PORT,REQUEST)
458 ;
459WSMQ1(IP,PORT,REQUEST) ; Message for WebSphere MQ (Parameters passed by global array - %mgwmq())
460 N (IP,PORT,REQUEST,%mgwmq)
461 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":WSMQE"
462 ;
463 ; Close connection to Gateway
464 i REQUEST="CLOSE" d S result=1 G WSMQ1X
465 . i $d(%mgwmq("keepalive","dev")) s DEV=%mgwmq("keepalive","dev") k %mgwmq("keepalive") C DEV
466 . q
467 ;
468 D VARS
469 S CRLF=$C(13,10)
470 S REQUEST=$$ucase(REQUEST)
471 I REQUEST="GET" k %mgwsi("send")
472 S res=""
473 S %mgwmq("error")=""
474 s global=+$g(%mgwmq("global"))
475 ;
476 ; Create TCP connection to Gateway
477 s OK=1
478 i $d(%mgwmq("keepalive","dev")) s DEV=%mgwmq("keepalive","dev")
479 i '$d(%mgwmq("keepalive","dev")) d
480 . S DEV="client$"_$j,timeout=10
481 . O DEV:(connect=IP_":"_PORT_":TCP":attach="client"):timeout:"SOCKET" E S %mgwmq("error")="Cannot connect to MGWSI" s OK=0
482 . q
483 i 'OK S result=0 G WSMQ1X
484 ;
485 S maxlen=$$getslen()
486 S BUFFER="",BSIZE=0,EOF=0
487 S DEV(0)=$IO
488 U DEV
489 S REQ="WSMQ "_REQUEST_" v1.1"_CRLF D WSMQS
490 S X="" F S X=$O(%mgwmq(X)) Q:X="" I X'="recv",X'="send" S Y=$G(%mgwmq(X)) I Y'="" S REQ=X_": "_Y_CRLF D WSMQS
491 S REQ=CRLF D WSMQS
492 i global d
493 . S REQ=$G(^MGWSI($j,1,"send")) I REQ'="" D WSMQS
494 . S X="" F S X=$O(^MGWSI($j,1,"send",extra,X)) Q:X="" S REQ=$G(^MGWSI($j,1,"send",extra,X)) I REQ'="" D WSMQS
495 . S X="" F S X=$O(^MGWSI($j,1,"send",X)) Q:X="" I X'=extra S REQ=$G(^MGWSI($j,1,"send",X)) I REQ'="" D WSMQS
496 . q
497 i 'global d
498 . S REQ=$G(%mgwmq("send")) I REQ'="" D WSMQS
499 . S X="" F S X=$O(%mgwmq("send",extra,X)) Q:X="" S REQ=$G(%mgwmq("send",extra,X)) I REQ'="" D WSMQS
500 . S X="" F S X=$O(%mgwmq("send",X)) Q:X="" I X'=extra S REQ=$G(%mgwmq("send",X)) I REQ'="" D WSMQS
501 . q
502 ;S REQ=$C(deod),EOF=1 D WSMQS
503 S REQ=$C(7),EOF=1 D WSMQS
504 U DEV
505 s size=+$$rdxx(10)
506 S res="",len=0,sn=0,got=0,pre="",plen=0,hdr=1 F d q:got=size
507 . s get=size-got i get>maxlen s get=maxlen
508 . s x=$$rdxx(get) s got=got+get
509 . i got=size,$e(x,get)=$c(deod) s x=$e(x,1,get-1)
510 . i hdr d q
511 . . s lx=$l(x,$c(13)) f i=1:1:lx d q:'hdr
512 . . . s r=$p(x,$c(13),i)
513 . . . i i=lx s pre=r,plen=$l(pre) q
514 . . . i plen s r=pre_r,pre="",plen=0
515 . . . i r=$c(10) s hdr=0 s pre=$p(x,$c(13),i+1,99999) s:$e(pre)=$c(10) pre=$e(pre,2,99999) s plen=$l(pre) q
516 . . . s nam=$p(r,": ",1),val=$p(r,": ",2,99999)
517 . . . i $e(nam)=$c(10) s nam=$e(nam,2,99999)
518 . . . i nam'="" s %mgwmq(nam)=val
519 . . . q
520 . . q
521 . s to=maxlen-plen
522 . s res=pre_$e(x,1,to),pre=$e(x,to+1,99999),plen=$l(pre)
523 . i global d
524 . . i 'sn s ^MGWSI($j,1,"recv")=res,res="",sn=sn+1 q
525 . . i sn s ^MGWSI($j,1,"recv",extra,sn)=res,res="",sn=sn+1 q
526 . . q
527 . i 'global d
528 . . i 'sn s %mgwmq("recv")=res,res="",sn=sn+1 q
529 . . i sn s %mgwmq("recv",extra,sn)=res,res="",sn=sn+1 q
530 . . q
531 . q
532 s result=1
533 i global d
534 . i plen,'sn s ^MGWSI($j,1,"recv")=pre,plen=0,sn=sn+1
535 . i plen,sn s ^MGWSI($j,1,"recv",extra,sn)=pre,plen=0,sn=sn+1
536 . i $g(^MGWSI($j,1,"r_code"))=2033 s result=0
537 . i $l($g(^MGWSI($j,1,"error"))) s result=0
538 . i $g(^MGWSI($j,1,"recv"))[":MGWSI:ERROR:" s result=0
539 . q
540 i 'global d
541 . i plen,'sn s %mgwmq("recv")=pre,plen=0,sn=sn+1
542 . i plen,sn s %mgwmq("recv",extra,sn)=pre,plen=0,sn=sn+1
543 . i $g(%mgwmq("r_code"))=2033 s result=0
544 . i $l($g(%mgwmq("error"))) s result=0
545 . i $g(%mgwmq("recv"))[":MGWSI:ERROR:" s result=0
546 . q
547 U DEV(0)
548 i $g(%mgwmq("keepalive"))=1 S %mgwmq("keepalive","dev")=DEV
549 i $g(%mgwmq("keepalive"))'=1 C DEV
550WSMQ1X ; Exit point
551 I $G(mqinfo) M %mgwmq("info")=%mgwmq("error") S %mgwmq("error")=""
552 Q result
553 ;
554WSMQE ; Error (EOF)
555 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":"
556 i $D(DEV(0)) U DEV(0)
557 i '$D(DEV(0)) U 0
558 i $g(%mgwmq("keepalive"))=1 S %mgwmq("keepalive","dev")=DEV
559 i $g(%mgwmq("keepalive"))'=1 C DEV
560 I $l($G(%mgwmq("error"))) G WSMQEX
561 S %mgwmq("error")=$ZS G WSMQEX
562WSMQEX ; Exit point
563 I $G(mqinfo) M %mgwmq("info")=%mgwmq("error") S %mgwmq("error")=""
564 Q 0
565 ;
566WSMQS ; Send outgoing header
567 N N,X,LEN
568WSMQS1 S LEN=$L(REQ)
569 I (BSIZE+LEN)<maxlen S BUFFER=BUFFER_REQ,BSIZE=BSIZE+LEN,REQ="",LEN=0 I 'EOF Q
570 W BUFFER D FLUSH
571 ; S N=1 F S X=$E(BUFFER,N,N+255) Q:X="" W X S N=N+255+1 D FLUSH
572 S BUFFER=REQ,BSIZE=LEN
573 I EOF S REQ="" I BSIZE G WSMQS1
574 Q
575 ;
576WSMQSRV(%mgwmq) ; Server to WebSphere MQ
577 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":WSMQSRVE^%ZMGWSIS"
578 i global d
579 . n x
580 . s x="" f s x=$o(^MGWSI($j,1,x)) q:x="" i x'="recv" s %mgwmq(x)=$g(^MGWSI($j,1,x))
581 . q
582 D @$g(%mgwmq("routine"))
583 k %mgwmq("qm_name")
584 k %mgwmq("q_name")
585 k %mgwmq("recv")
586 i global d
587 . k ^MGWSI($j,1,"qm_name")
588 . k ^MGWSI($j,1,"q_name")
589 . k ^MGWSI($j,1,"recv")
590 . m ^MGWSI($j,1)=%mgwmq
591 . q
592 Q 1
593WSMQSRVE ; Error
594 k %mgwmq("qm_name")
595 k %mgwmq("q_name")
596 k %mgwmq("recv")
597 S %mgwmq("send")="ERROR: "_$ZS
598 S %mgwmq("error")="ERROR: "_$ZS
599 Q 0
600 ;
601WSX(IP,PORT,REQUEST,%mgwmq) ; Message for Web Server (Parameters passed by reference)
602 Q $$WSX1(IP,PORT,REQUEST)
603 ;
604WSX1(IP,PORT,REQUEST) ; Message for Web Server (Parameters passed by global array - %mgwmq())
605 N (IP,PORT,REQUEST,%mgwmq)
606 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":WSXE"
607 D VARS
608 S CRLF=$C(13,10)
609 ;
610 ; Create TCP connection to server
611 s OK=1
612 S DEV="client$"_$j,timeout=10
613 O DEV:(connect=IP_":"_PORT_":TCP":attach="client"):timeout:"SOCKET" E S %mgwmq("error")="Cannot connect to Web Server" s OK=0
614 i 'OK S result=0 G WSXEX
615 ;
616 S maxlen=$$getslen()
617 S DEV(0)=$IO
618 U DEV
619 S REQ=""
620 S REQ=REQ_"POST /mgwsi/sys/system_functions.mgwsi?FUN="_REQUEST_"&KEY="_$$WSXESC($g(%mgwmq("key")))_" HTTP/1.1"_CRLF
621 S REQ=REQ_"Host: "_IP_$s(PORT'=80:":"_PORT,1:"")_CRLF
622 S REQ=REQ_"Content-Type: text/plain"_CRLF
623 S REQ=REQ_"User-Agent: zmgwsi v"_$g(version)_CRLF
624 S REQ=REQ_"Content-Length: "_$L($G(%mgwmq("send")))_CRLF
625 S REQ=REQ_"Connection: close"_CRLF
626 S REQ=REQ_CRLF
627 S REQ=REQ_$G(%mgwmq("send"))
628 ;
629 W REQ D FLUSH
630 ;
631 s res=$$rdxx(60) f q:res[$c(13,10,13,10) s res=res_$$rdxx(1)
632 s head=$p(res,$c(13,10,13,10),1),res=$p(res,$c(13,10,13,10),2,9999)
633 s headn=$$lcase(head)
634 s clen=+$p(headn,"content-length: ",2)
635 s rlen=clen-$l(res)
636 s res=res_$$rdxx(rlen)
637WSXE ; Error (EOF)
638 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":"
639 i $D(DEV(0)) U DEV(0)
640 i '$D(DEV(0)) U 0
641 C DEV
642WSXEX ; Exit point
643 s %mgwmq("recv")=$g(res)
644 Q 0
645 ;
646WSXESC(IN)
647 N OUT,I,A,C,LEN,N16
648 S OUT="",N16=0 F I=1:1:$L(IN) D
649 . S C=$E(IN,I),A=$A(C)
650 . I A=32 S C="+" S OUT=OUT_C Q
651 . I A<32!(A>127)!(C?1P) S LEN=$$esize(.N16,A,16) S:LEN=1 N16="0"_N16 S C="%"_N16 S OUT=OUT_C Q
652 . S OUT=OUT_C Q
653 . Q
654 Q OUT
655 ;
656MPHP ; Request from m_client
657 n port,dev,conc,cmnd,nato
658 s cmnd=$p(req,"^",4)
659 d PHP
660 q
661 ;
662PHP ; Serve request from m_client
663 n argz,i,m
664 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":phpe^%ZMGWSIS"
665 s res=""
666 i cmnd="S" d set
667 i cmnd="G" d get
668 i cmnd="K" d kill
669 i cmnd="D" d data
670 i cmnd="O" d order
671 i cmnd="P" d previous
672 i cmnd="M" d mergedb
673 i cmnd="m" d mergephp
674 i cmnd="H" d html
675 i cmnd="y" d htmlm
676 i cmnd="h" d http
677 i cmnd="X" d proc
678 i cmnd="x" d meth
679 i cmnd="W" d web
680 q
681phpe ; Error
682 d EVENT($$client()_" Error : "_$ZS)
683 k res s res="",res(2)="M Server Error : ["_$g(req(2))_"]"_$tr($ZS,"<>%","[]^")_$g(ref)
684 s res(1)="00000ce"_$C(10)
685 q
686 ;
687client() ; Get client name
688 s name="m_client"
689 i $g(%ZCS("client"))="z" s name="m_php"
690 i $g(%ZCS("client"))="j" s name="m_jsp"
691 i $g(%ZCS("client"))="a" s name="m_aspx"
692 i $g(%ZCS("client"))="p" s name="m_python"
693 i $g(%ZCS("client"))="r" s name="m_ruby"
694 i $g(%ZCS("client"))="h" s name="m_apache"
695 i $g(%ZCS("client"))="c" s name="m_cgi"
696 i $g(%ZCS("client"))="w" s name="m_websphere_mq"
697 q name
698 ;
699set ; Global set
700 i argc<3 q
701 s argz=argc-1
702 s fun=0 d ref
703 x "s "_ref_"="_"req"_argc
704 d res
705 Q
706 ;
707get ; Global get
708 i argc<2 q
709 s argz=argc
710 s fun=0 d ref
711 x "s res=$g("_ref_")"
712 d res
713 Q
714 ;
715kill ; Global kill
716 i argc<1 q
717 s argz=argc
718 s fun=0 d ref
719 x "k "_ref
720 d res
721 Q
722 ;
723data ; Global get
724 i argc<2 q
725 s argz=argc
726 s fun=0 d ref
727 x "s res=$d("_ref_")"
728 d res
729 Q
730 ;
731order ; Global order
732 i argc<3 q
733 s argz=argc
734 s fun=0 d ref
735 x "s res=$o("_ref_")"
736 d res
737 Q
738 ;
739previous ; Global reverse order
740 i argc<3 q
741 s argz=argc
742 s fun=0 d ref
743 x "s res=$o("_ref_",-1)"
744 d res
745 Q
746 ;
747mergedb ; Global Merge from PHP
748 i argc<3 q
749 s a="" f argz=1:1 q:'$d(req(argz)) i $g(req(argz,0))=1 s a=req(argz) q
750 i a="" q
751 s argz=argz-1
752 s fun=0 d ref
753 i ref["()" s ref=$p(ref,"()",1)
754 i $g(@req(argz+2))["ks" x "k "_ref
755 x "m "_ref_"="_a
756 d res
757 Q
758 ;
759mergephp ; Global Merge to PHP
760 i argc<3 q
761 s a="" f argz=1:1 q:'$d(req(argz)) i $g(req(argz,0))=1 s a=req(argz) q
762 i a="" q
763 s argz=argz-1
764 s fun=0 d ref
765 i ref["()" s ref=$p(ref,"()",1)
766 x "m "_a_"="_ref
767 s argz=argz+1
768 s abyref=1
769 d res
770 Q
771 ;
772html ; HTML
773 s res(1)=$c(1,2,1,10)_"0sc"_$C(10) w res(1)
774 i argc<2 q
775 s argz=argc
776 s fun=0 d ref
777 x "n ("_refn_") d "_ref
778 Q
779 ;
780htmlm ; HTML (COS) Method
781 s res(1)=$c(1,2,1,10)_"0sc"_$C(10) w res(1)
782 i argc<1 q
783 s argz=argc
784 s fun=0 d oref
785 s ref=$tr($p(ref,",",1,2),".","")_","_$p(ref,",",3,999)
786 i argc=1 x "n ("_refn_") s req(-1)=$zobjclassmethod()"
787 i argc>1 x "n ("_refn_") s req(-1)=$zobjclassmethod("_ref_")"
788 s res=$g(req(-1))
789 Q
790 ;
791web ; Web request
792 N REQ,x,y,i
793 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":webe^%ZMGWSIS"
794 s res(1)=$c(1,2,1,10)_"0sc"_$C(10) w res(1)
795 i argc'=4 g webe
796 s argz=argc
797 s fun=1 d ref
798 s x="" f s x=$o(req4(x)) q:x="" s y="" f i=1:1 s y=$o(req4(x,y)) q:y="" i y'=i m req4(x,i)=req4(x,y) k req4(x,y)
799 x "n ("_refn_") d "_ref
800 q
801webe ; error
802 S REQ=""
803 S REQ=REQ_"HTTP/1.1 200 OK"_$C(13,10)
804 S REQ=REQ_"Content-type: text/plain"_$C(13,10)
805 S REQ=REQ_"Connection: close"_$C(13,10)
806 S REQ=REQ_$C(13,10)
807 S REQ=REQ_"Error calling web function "_$g(ref)_$g(refn)_$C(13,10)
808 S REQ=REQ_$ZS
809 S REQ=REQ_"Web functions contain two arguments"_$C(13,10)
810 W REQ
811 Q
812 ;
813WEB(CGI,DATA)
814 N REQ,X,Y
815 S REQ=""
816 S REQ=REQ_"HTTP/1.1 200 OK"_$C(13,10)
817 S REQ=REQ_"Content-type: text/plain"_$C(13,10)
818 S REQ=REQ_"Connection: close"_$C(13,10)
819 S REQ=REQ_$C(13,10)
820 W REQ
821 W $G(CGI)
822 S X="" F S X=$O(CGI(X)) Q:X="" W X_"="_$G(CGI(X))_$C(13,10)
823 W $C(13,10)
824 S X="" F S X=$O(DATA(X)) Q:X="" S Y="" F S Y=$O(DATA(X,Y)) Q:Y="" W X_":"_Y_"="_$G(DATA(X,Y))_$C(13,10)
825 Q
826 ;
827http ; HTTP
828 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":httpe"
829 i argc<2 q
830 s x=$$http1(.req2,@req(3))
831httpx ; exit
832 k ^%MGW("MPC",$J,"CONTENT")
833 Q
834httpe ; Error
835 w "<html><head><title>m_php/jsp: Error</title></head><h2>eXtc is not installed on this computer<h2></html>"
836 q
837 ;
838http1(%CGIEVAR,content) ; HTTP
839 n (%CGIEVAR,content)
840 s test=0
841 i test d q 0
842 . w "<br><b>CGI</b>"
843 . s x="" f s x=$o(%CGIEVAR(x)) q:x="" w "<br>"_x_"="_$g(%CGIEVAR(x))
844 . w "<br><b>CONTENT</b>"
845 . s x="" f s x=$o(^%MGW("MPC",$J,"CONTENT",x)) q:x="" w "<br>"_x_"="_$g(^%MGW("MPC",$J,"CONTENT",x))
846 . q
847 i $G(%CGIEVAR("key_eXtcServer"))="true" d QUIT 1
848 . ; break out to eXtc Server here
849 . s namespace=$G(%CGIEVAR("key_namespace"))
850 . s:namespace'="" namespace=$G(^%eXtc("system","phpSettings","namespace",namespace))
851 . s:namespace="" namespace=$G(^%eXtc("system","phpSettings","defaultNamespace"))
852 . s:namespace="" namespace="%CACHELIB"
853 . d PHPServer^%eXMLServer
854 QUIT 0
855 ;
856proc ; M extrinsic function
857 i argc<2 q
858 s argz=argc
859 s fun=1 d ref
860 i argc=2 x "n ("_refn_") s req(-1)=$$"_ref_"()"
861 i argc>2 x "n ("_refn_") s req(-1)=$$"_ref
862 s res=$g(req(-1))
863 d res
864 Q
865 ;
866meth ; M (COS) method
867 ;
868 ; Synopsis:
869 ; s err=$zobjclassmethod(className,methodName,param1,...,paramN)
870 ;
871 ; s className="eXtc.DOMAPI"
872 ; s methodName="openDOM"
873 ; s err=$zobjclassmethod(className,methodName)
874 ;
875 ; ; This is equivalent to ...
876 ; s err=##class(eXtc.DOMAPI).openDOM()
877 ;
878 ; s methodName="getDocumentNode"
879 ; s documentName="eXtcDOM2"
880 ; s err=$zobjclassmethod(className,methodName,documentName)
881 ; ; This is equivalent to ...
882 ; s err=##class(eXtc.DOMAPI).getDocumentNode("eXtcDOM2")
883 ;
884 i argc<1 q
885 s argz=argc
886 s fun=1 d oref
887 s ref=$tr($p(ref,",",1,2),".","")_","_$p(ref,",",3,999)
888 i argc=1 x "n ("_refn_") s req(-1)=$zobjclassmethod()"
889 i argc>1 x "n ("_refn_") s req(-1)=$zobjclassmethod("_ref_")"
890 s res=$g(req(-1))
891 d res
892 Q
893 ;
894sort(a) ; Sort an array
895 q 1
896 ;
897ref ; Global reference
898 n com,i,strt,a1
899 s array=0,refn="res,req,extra,global,oversize"
900 i argc<2 q
901 s a1=$g(@req(2))
902 s strt=2 i a1?1"^"."^" s strt=strt+1
903 s ref=@req(strt) i argc=strt q
904 s ref=ref_"("
905 s com="" f i=strt+1:1:argz s refn=refn_","_req(i),ref=ref_com_$s(fun:".",1:"")_req(i),com=","
906 s ref=ref_")"
907 q
908 ;
909oref ; Object reference
910 n com,i,strt,a1
911 s array=0,refn="req,extra,global,oversize"
912 i argc<2 q
913 s a1=$g(@req(2))
914 s strt=2 i a1?1"^"."^" s strt=strt+1
915 i '$d(req(strt)) q
916 s ref=""
917 s com="" f i=strt:1:argz s refn=refn_","_req(i),ref=ref_com_$s(fun:".",1:"")_req(i),com=","
918 q
919 ;
920res ; Return result
921 n i,a,sn,argc
922 s maxlen=$$getslen()
923 d VARS
924 s anybyref=0 f argc=1:1:argz q:'$d(req(argc)) i $g(req(argc,1)) s anybyref=1 q
925 i 'anybyref d q
926 . d send($g(res))
927 . i oversize f sn=1:1 q:'$d(^MGWSI($j,0,extra,sn)) d send($g(^(sn)))
928 . q
929 s res(1)="00000cc"_$C(10)
930 s size=$l($g(res)),byref=0
931 i oversize f sn=1:1 q:'$d(^MGWSI($j,0,extra,sn)) s size=size+$l(^(sn))
932 s x=$$ehead(.head,size,byref,ddata)
933 d send(head)
934 d send($g(res))
935 i oversize f sn=1:1 q:'$d(^MGWSI($j,0,extra,sn)) d send($g(^(sn)))
936 f argc=1:1:argz q:'$d(req(argc)) d
937 . s byref=$g(req(argc,1))
938 . s array=$g(req(argc,0))
939 . i 'byref s size=0,x=$$ehead(.head,size,byref,ddata) d send(head) q
940 . i 'array d q
941 . . s size=$l($g(@req(argc)))
942 . . f sn=1:1 q:'$d(@(req(argc)_"(extra,sn)")) s size=size+$l($g(@(req(argc)_"(extra,sn)")))
943 . . s x=$$ehead(.head,size,byref,ddata)
944 . . d send(head)
945 . . d send($g(@req(argc)))
946 . . f sn=1:1 q:'$d(@(req(argc)_"(extra,sn)")) d send($g(@(req(argc)_"(extra,sn)")))
947 . . q
948 . s x=$$ehead(.head,0,0,darec)
949 . d send(head)
950 . d resa
951 . s x=$$ehead(.head,0,0,deod)
952 . d send(head)
953 . q
954 q
955 ;
956res1 ; Link to array parser
957 d send($g(req(argc,0))_$g(req(argc,1)))
958 i '$g(req(argc,1)) q
959 i $g(req(argc,0))=0 d send($g(@req(argc))) q
960 s a=req(argc),fkey="" i global s a="^MGWSI",fkey="$j,argc-2"
961 d resa
962 q
963 ;
964resa ; Return array
965 n ref,kn,ok,def,data,txt
966 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":resae"
967 s byref=0
968 s a=req(argc),fkey="" i global s a="^MGWSI",fkey="$j,argc-2"
969 i a="" q
970 i global d
971 . i ($d(@(a_"("_fkey_")"))#10) d
972 . . s txt=" ",x=$$ehead(.head,$l(txt),byref,dakey) d send(head),send(txt)
973 . . s size=0
974 . . s size=size+$l($g(@req(argc)))
975 . . f sn=1:1 q:'$d(@(a_"("_fkey_","_"extra,sn)")) s size=size+$l($g(^(sn)))
976 . . s x=$$ehead(.head,size,byref,ddata) d send(head)
977 . . d send($g(@req(argc)))
978 . . f sn=1:1 q:'$d(@(a_"("_fkey_","_"extra,sn)")) d send($g(^(sn)))
979 . . q
980 . s fkey=fkey_","
981 . q
982 i 'global d
983 . i ($d(@a)#10),$l($g(@a)) d
984 . . s txt=" ",x=$$ehead(.head,$l(txt),byref,dakey) d send(head),send(txt)
985 . . s size=0
986 . . s size=size+$l($g(@a))
987 . . f sn=1:1 q:'$d(@(a_"(extra,sn)")) s size=size+$l($g(@(a_"(extra,sn)")))
988 . . s x=$$ehead(.head,size,byref,ddata) d send(head)
989 . . d send($g(@a))
990 . . f sn=1:1 q:'$d(@(a_"(extra,sn)")) d send($g(@(a_"(extra,sn)")))
991 . . q
992 . q
993 s ok=0,kn=1,x(kn)="",ref="x("_kn_")"
994 f s x(kn)=$o(@(a_"("_fkey_ref_")")) d resa1 i ok q
995 q
996resae ; Error
997 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":"
998 q
999 ;
1000resa1 ; Array node
1001 i x(kn)=extra q
1002 i x(kn)="",kn=1 s ok=1 q
1003 i x(kn)="" s kn=kn-1,ref=$p(ref,",",1,$l(ref,",")-1) q
1004 s def=$d(@(a_"("_fkey_ref_")")) i (def\10) d resa3
1005 s data=$g(@(a_"("_fkey_ref_")"))
1006 i (def#10) d resa2
1007 i (def\10) s kn=kn+1,x(kn)="",ref=ref_","_"x("_kn_")"
1008 q
1009 ;
1010resa2 ; Array node data
1011 n i,spc
1012 f i=1:1:kn s x=$$ehead(.head,$l(x(i)),byref,dakey) d send(head),send(x(i))
1013 i $g(%ZCS("client"))="z",(def\10) s spc=" ",x=$$ehead(.head,$l(spc),byref,dakey) d send(head),send(spc)
1014 s size=$l(data)
1015 f sn=1:1 q:'$d(@(a_"("_fkey_ref_",extra,sn)")) s size=size+$l($g(@(a_"("_fkey_ref_",extra,sn)")))
1016 s x=$$ehead(.head,size,byref,ddata) d send(head)
1017 d send(data)
1018 f sn=1:1 q:'$d(@(a_"("_fkey_ref_",extra,sn)")) d send($g(@(a_"("_fkey_ref_",extra,sn)")))
1019 q
1020 ;
1021resa3 ; Array node data with descendants - test for non-extra data
1022 n y
1023 s y="" f s y=$o(@(a_"("_ref_",y)")) q:y="" i y'=extra q
1024 i y="" s def=1
1025 q
1026 ;
1027send(data) ; Send data
1028 n n
1029 ;D EVENT(data_$g(res(1)))
1030 s n=$o(res(""),-1)
1031 i n="" s n=1
1032 i $l($g(res(n)))+$l(data)>maxlen s n=n+1
1033 s res(n)=$g(res(n))_data
1034 q
1035 ;
1036getsys() ; Get system type
1037 s systype="GTM"
1038 q systype
1039 ;
1040getuci() ; Get NameSpace/UCI
1041 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":getucie^%ZMGWSIS"
1042 s %UCI=$ZG
1043 q %UCI
1044getucie ; Error
1045 q ""
1046 ;
1047getslen() ; Get maximum string length
1048 s slen=32000
1049 q slen
1050 ;
1051lcase(string) ; Convert to lower case
1052 q $tr(string,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
1053 ;
1054ucase(string) ; Convert to upper case
1055 q $tr(string,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
1056 ;
1057setio(tblname) ; Set I/O translation
1058 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":setioe^%ZMGWSIS"
1059 Q ""
1060setioe ; Error - do nothing
1061 Q ""
1062 ;
1063zcvt(buffer,tblname) ; Translate buffer
1064 new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":zcvte^%ZMGWSIS"
1065 Q buffer
1066zcvte ; Error - do nothing
1067 Q buffer
1068 ;
1069WSMQTEST ; Test link to WebSphere MQ
1070 n %mgwmq,response
1071 w !,"Sending Test Message to MGWSI/WebSphere MQ interface..."
1072 S response=$$WSMQ("127.0.0.1",7040,"TEST",.%mgwmq)
1073 W !,"Response: ",response," ",$G(%mgwmq("recv"))
1074 Q
1075 ;
1076WSMQTSTX(IP,PORT) ; Test link to WebSphere MQ: IP address and Port specified
1077 n %mgwmq,response
1078 w !,"Sending Test Message to MGWSI/WebSphere MQ interface..."
1079 S response=$$WSMQ(IP,PORT,"TEST",.%mgwmq)
1080 W !,"Response: ",response," ",$G(%mgwmq("recv"))
1081 Q
1082 ;
1083HTEST ; Return HTML
1084 n systype
1085 s systype=$$getsys()
1086 w "<I>A line of HTML from "_systype_"</I>"
1087 Q
1088 ;
1089HTEST1(P1) ; Return HTML
1090 n x,systype
1091 s systype=$$getsys()
1092 ;W "HTTP/1.1 200 OK",$c(13,10)
1093 ;W "Content-Type: text/html",$c(13,10)
1094 ;W "Connection: close",$c(13,10)
1095 ;W $c(13,10)
1096 w "<I>HTML content returned from "_systype_"</I>"
1097 W "<br><I>The input parameter passed was: <B>"_$g(P1)_"</B></I>"
1098 s x="" f s x=$o(P1(x)) q:x="" W "<br><I>Array element passed: <B>"_x_" = "_$g(P1(x))_"</B></I>"
1099 Q
1100 ;
1101PTEST() ; Return result
1102 n systype
1103 s systype=$$getsys()
1104 q "Result from "_systype_" process: "_$J_"; UCI: "_$$getuci()
1105 Q
1106 ;
1107PTEST1(P1) ; Return result
1108 n systype
1109 s systype=$$getsys()
1110 q "Result from "_systype_" process: "_$J_"; UCI: "_$$getuci()_"; The input parameter passed was: "_P1
1111 ;
1112PTEST2(P1,P2) ; Manipulate an array
1113 n n,x,systype
1114 s systype=$$getsys()
1115 s n=0,x="" f s x=$o(P1(x)) q:x="" s n=n+1
1116 s P1("Key from M - 1")="Value 1"
1117 s P1("Key from M - 2")="Value 2"
1118 s P2="Stratford"
1119 q "Result from "_systype_" process: "_$J_"; UCI: "_$$getuci()_"; "_n_" elements were received in an array, 2 were added by this procedure"
1120 ;
Note: See TracBrowser for help on using the repository browser.