| [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 | ;
|
|---|
| 25 | A0 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 | ;
|
|---|
| 29 | V() ; 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 | ;
|
|---|
| 36 | VERS ; 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 | ;
|
|---|
| 44 | VARS ; 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 | ;
|
|---|
| 65 | esize(esize,size,base)
|
|---|
| 66 | n i,x
|
|---|
| 67 | i base'=10 g esize1
|
|---|
| 68 | s esize=size
|
|---|
| 69 | q $l(esize)
|
|---|
| 70 | esize1 ; 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 | ;
|
|---|
| 75 | dsize(esize,len,base)
|
|---|
| 76 | n i,x
|
|---|
| 77 | i base'=10 g dsize1
|
|---|
| 78 | s size=+$e(esize,1,len)
|
|---|
| 79 | q size
|
|---|
| 80 | dsize1 ; 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 | ;
|
|---|
| 85 | ebase62(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 | ;
|
|---|
| 91 | dbase62(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 | ;
|
|---|
| 99 | ehead(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 | ;
|
|---|
| 106 | dhead(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 | ;
|
|---|
| 115 | rdxx(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 | ;
|
|---|
| 125 | rdx(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 | ;
|
|---|
| 146 | CHILD(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
|
|---|
| 169 | CHILD2 ; 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
|
|---|
| 175 | CHILD3 ; 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 | ;
|
|---|
| 208 | CHILDE ; Error
|
|---|
| 209 | d EVENT($ZS)
|
|---|
| 210 | i $ZS["READ" g HALT
|
|---|
| 211 | G CHILD2
|
|---|
| 212 | ;
|
|---|
| 213 | HALT ; 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 | ;
|
|---|
| 221 | REQ ; Read request data
|
|---|
| 222 | n dev,get,got
|
|---|
| 223 | REQ0 ; 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
|
|---|
| 240 | REQZ ; Argument read
|
|---|
| 241 | i RLEN<CLEN G REQ0
|
|---|
| 242 | s eod=1
|
|---|
| 243 | q
|
|---|
| 244 | ;
|
|---|
| 245 | REQ1 ; 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 | ;
|
|---|
| 266 | MPC ; 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 | ;
|
|---|
| 270 | ARRAY ; Read array
|
|---|
| 271 | n x,kn,val,sn,ext,get,got
|
|---|
| 272 | ;d EVENT("*** array ***")
|
|---|
| 273 | k x,ext s kn=0
|
|---|
| 274 | ARRAY0 ; 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 | ;
|
|---|
| 292 | ARRAY1 ; 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
|
|---|
| 307 | ARRAY1E ;
|
|---|
| 308 | d EVENT("Array: "_$ZS)
|
|---|
| 309 | Q
|
|---|
| 310 | ;
|
|---|
| 311 | END ; 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 | ;
|
|---|
| 327 | FLUSH ; Flush output buffer
|
|---|
| 328 | ;w *-3
|
|---|
| 329 | ;w *1
|
|---|
| 330 | q
|
|---|
| 331 | ;
|
|---|
| 332 | AYT ; 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 | ;
|
|---|
| 341 | DINT ; 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 | ;
|
|---|
| 357 | UCI(UCI) ; Change NameSpace/UCI
|
|---|
| 358 | new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":UCIE"
|
|---|
| 359 | i UCI="" Q
|
|---|
| 360 | s $ZG=UCI
|
|---|
| 361 | Q
|
|---|
| 362 | UCIE ; Error
|
|---|
| 363 | d EVENT("UCI Error: "_UCI_" : "_$ZS)
|
|---|
| 364 | q
|
|---|
| 365 | ;
|
|---|
| 366 | INFO ; 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 | ;
|
|---|
| 378 | EVENT(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
|
|---|
| 390 | EVENTE ; Error
|
|---|
| 391 | Q
|
|---|
| 392 | ;
|
|---|
| 393 | DDATE(DATE) ; Decode M date
|
|---|
| 394 | new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":DATEE"
|
|---|
| 395 | Q $ZD(DATE,2)
|
|---|
| 396 | DDATEE ; No $ZD Function
|
|---|
| 397 | Q DATE
|
|---|
| 398 | ;
|
|---|
| 399 | DTIME(TIME) ; Decode M Time
|
|---|
| 400 | Q (TIME\3600)_":"_(TIME#3600\60)
|
|---|
| 401 | ;
|
|---|
| 402 | HEAD() ; Format Header record
|
|---|
| 403 | N %UCI
|
|---|
| 404 | new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":HEADE"
|
|---|
| 405 | s %UCI=$$getuci()
|
|---|
| 406 | HEADE ; Error
|
|---|
| 407 | Q $$DDATE(+$H)_" at "_$$DTIME($P($H,",",2))_"~"_$G(%ZCS("PORT"))_"~"_%UCI
|
|---|
| 408 | ;
|
|---|
| 409 | HMACSHA256(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 | ;
|
|---|
| 412 | HMACSHA1(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 | ;
|
|---|
| 415 | HMACSHA(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 | ;
|
|---|
| 418 | HMACMD5(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 | ;
|
|---|
| 421 | SHA256(string,b64,context) ; SHA256
|
|---|
| 422 | Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"SHA256",string,"",b64,context)
|
|---|
| 423 | ;
|
|---|
| 424 | SHA1(string,b64,context) ; SHA1
|
|---|
| 425 | Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"SHA1",string,"",b64,context)
|
|---|
| 426 | ;
|
|---|
| 427 | SHA(string,b64,context) ; SHA
|
|---|
| 428 | Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"SHA",string,"",b64,context)
|
|---|
| 429 | ;
|
|---|
| 430 | MD5(string,b64,context) ; MD5
|
|---|
| 431 | Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"MD5",string,"",b64,context)
|
|---|
| 432 | ;
|
|---|
| 433 | B64(string,context) ; BASE64
|
|---|
| 434 | Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"B64",string,"",0,context)
|
|---|
| 435 | ;
|
|---|
| 436 | DB64(string,context) ; DECODE BASE64
|
|---|
| 437 | Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"D-B64",string,"",0,context)
|
|---|
| 438 | ;
|
|---|
| 439 | TIME(context) ; TIME
|
|---|
| 440 | Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"TIME","","",0,context)
|
|---|
| 441 | ;
|
|---|
| 442 | ZTS(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 | ;
|
|---|
| 447 | CRYPT(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 | ;
|
|---|
| 456 | WSMQ(IP,PORT,REQUEST,%mgwmq) ; Message for WebSphere MQ (Parameters passed by reference)
|
|---|
| 457 | Q $$WSMQ1(IP,PORT,REQUEST)
|
|---|
| 458 | ;
|
|---|
| 459 | WSMQ1(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
|
|---|
| 550 | WSMQ1X ; Exit point
|
|---|
| 551 | I $G(mqinfo) M %mgwmq("info")=%mgwmq("error") S %mgwmq("error")=""
|
|---|
| 552 | Q result
|
|---|
| 553 | ;
|
|---|
| 554 | WSMQE ; 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
|
|---|
| 562 | WSMQEX ; Exit point
|
|---|
| 563 | I $G(mqinfo) M %mgwmq("info")=%mgwmq("error") S %mgwmq("error")=""
|
|---|
| 564 | Q 0
|
|---|
| 565 | ;
|
|---|
| 566 | WSMQS ; Send outgoing header
|
|---|
| 567 | N N,X,LEN
|
|---|
| 568 | WSMQS1 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 | ;
|
|---|
| 576 | WSMQSRV(%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
|
|---|
| 593 | WSMQSRVE ; 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 | ;
|
|---|
| 601 | WSX(IP,PORT,REQUEST,%mgwmq) ; Message for Web Server (Parameters passed by reference)
|
|---|
| 602 | Q $$WSX1(IP,PORT,REQUEST)
|
|---|
| 603 | ;
|
|---|
| 604 | WSX1(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)
|
|---|
| 637 | WSXE ; 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
|
|---|
| 642 | WSXEX ; Exit point
|
|---|
| 643 | s %mgwmq("recv")=$g(res)
|
|---|
| 644 | Q 0
|
|---|
| 645 | ;
|
|---|
| 646 | WSXESC(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 | ;
|
|---|
| 656 | MPHP ; Request from m_client
|
|---|
| 657 | n port,dev,conc,cmnd,nato
|
|---|
| 658 | s cmnd=$p(req,"^",4)
|
|---|
| 659 | d PHP
|
|---|
| 660 | q
|
|---|
| 661 | ;
|
|---|
| 662 | PHP ; 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
|
|---|
| 681 | phpe ; 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 | ;
|
|---|
| 687 | client() ; 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 | ;
|
|---|
| 699 | set ; 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 | ;
|
|---|
| 707 | get ; 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 | ;
|
|---|
| 715 | kill ; 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 | ;
|
|---|
| 723 | data ; 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 | ;
|
|---|
| 731 | order ; 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 | ;
|
|---|
| 739 | previous ; 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 | ;
|
|---|
| 747 | mergedb ; 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 | ;
|
|---|
| 759 | mergephp ; 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 | ;
|
|---|
| 772 | html ; 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 | ;
|
|---|
| 780 | htmlm ; 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 | ;
|
|---|
| 791 | web ; 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
|
|---|
| 801 | webe ; 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 | ;
|
|---|
| 813 | WEB(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 | ;
|
|---|
| 827 | http ; HTTP
|
|---|
| 828 | new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":httpe"
|
|---|
| 829 | i argc<2 q
|
|---|
| 830 | s x=$$http1(.req2,@req(3))
|
|---|
| 831 | httpx ; exit
|
|---|
| 832 | k ^%MGW("MPC",$J,"CONTENT")
|
|---|
| 833 | Q
|
|---|
| 834 | httpe ; 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 | ;
|
|---|
| 838 | http1(%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 | ;
|
|---|
| 856 | proc ; 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 | ;
|
|---|
| 866 | meth ; 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 | ;
|
|---|
| 894 | sort(a) ; Sort an array
|
|---|
| 895 | q 1
|
|---|
| 896 | ;
|
|---|
| 897 | ref ; 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 | ;
|
|---|
| 909 | oref ; 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 | ;
|
|---|
| 920 | res ; 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 | ;
|
|---|
| 956 | res1 ; 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 | ;
|
|---|
| 964 | resa ; 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
|
|---|
| 996 | resae ; Error
|
|---|
| 997 | new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":"
|
|---|
| 998 | q
|
|---|
| 999 | ;
|
|---|
| 1000 | resa1 ; 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 | ;
|
|---|
| 1010 | resa2 ; 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 | ;
|
|---|
| 1021 | resa3 ; 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 | ;
|
|---|
| 1027 | send(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 | ;
|
|---|
| 1036 | getsys() ; Get system type
|
|---|
| 1037 | s systype="GTM"
|
|---|
| 1038 | q systype
|
|---|
| 1039 | ;
|
|---|
| 1040 | getuci() ; Get NameSpace/UCI
|
|---|
| 1041 | new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":getucie^%ZMGWSIS"
|
|---|
| 1042 | s %UCI=$ZG
|
|---|
| 1043 | q %UCI
|
|---|
| 1044 | getucie ; Error
|
|---|
| 1045 | q ""
|
|---|
| 1046 | ;
|
|---|
| 1047 | getslen() ; Get maximum string length
|
|---|
| 1048 | s slen=32000
|
|---|
| 1049 | q slen
|
|---|
| 1050 | ;
|
|---|
| 1051 | lcase(string) ; Convert to lower case
|
|---|
| 1052 | q $tr(string,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
|
|---|
| 1053 | ;
|
|---|
| 1054 | ucase(string) ; Convert to upper case
|
|---|
| 1055 | q $tr(string,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
|---|
| 1056 | ;
|
|---|
| 1057 | setio(tblname) ; Set I/O translation
|
|---|
| 1058 | new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":setioe^%ZMGWSIS"
|
|---|
| 1059 | Q ""
|
|---|
| 1060 | setioe ; Error - do nothing
|
|---|
| 1061 | Q ""
|
|---|
| 1062 | ;
|
|---|
| 1063 | zcvt(buffer,tblname) ; Translate buffer
|
|---|
| 1064 | new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":zcvte^%ZMGWSIS"
|
|---|
| 1065 | Q buffer
|
|---|
| 1066 | zcvte ; Error - do nothing
|
|---|
| 1067 | Q buffer
|
|---|
| 1068 | ;
|
|---|
| 1069 | WSMQTEST ; 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 | ;
|
|---|
| 1076 | WSMQTSTX(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 | ;
|
|---|
| 1083 | HTEST ; Return HTML
|
|---|
| 1084 | n systype
|
|---|
| 1085 | s systype=$$getsys()
|
|---|
| 1086 | w "<I>A line of HTML from "_systype_"</I>"
|
|---|
| 1087 | Q
|
|---|
| 1088 | ;
|
|---|
| 1089 | HTEST1(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 | ;
|
|---|
| 1101 | PTEST() ; Return result
|
|---|
| 1102 | n systype
|
|---|
| 1103 | s systype=$$getsys()
|
|---|
| 1104 | q "Result from "_systype_" process: "_$J_"; UCI: "_$$getuci()
|
|---|
| 1105 | Q
|
|---|
| 1106 | ;
|
|---|
| 1107 | PTEST1(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 | ;
|
|---|
| 1112 | PTEST2(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 | ;
|
|---|
