%ZMGWSIS ; Service Integration - Child Process ; ; ---------------------------------------------------------------------------- ; | m_apache | ; | Copyright (c) 2004-2009 M/Gateway Developments Ltd, | ; | Surrey UK. | ; | All rights reserved. | ; | | ; | http://www.mgateway.com | ; | | ; | This program is free software: you can redistribute it and/or modify | ; | it under the terms of the GNU Affero General Public License as | ; | published by the Free Software Foundation, either version 3 of the | ; | License, or (at your option) any later version. | ; | | ; | This program is distributed in the hope that it will be useful, | ; | but WITHOUT ANY WARRANTY; without even the implied warranty of | ; | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ; | GNU Affero General Public License for more details. | ; | | ; | You should have received a copy of the GNU Affero General Public License | ; | along with this program. If not, see . | ; ---------------------------------------------------------------------------- ; A0 D VERS Q ;f i=1:1:10000 s x=$$esize(.y,i,62),z=$$dsize(y,$l(y),62) w !,i,?10,y,?20,z q ; V() ; Version and date N V,R,D S V="2.0" S R=6 S D="17 February 2009" Q V_"."_R_"."_D ; VERS ; Version information N V S V=$$V() W !,"M/Gateway Developments Ltd - Service Integration Gateway" W !,"Version: "_$P(V,".",1,2)_"; Revision "_$P(V,".",3)_" ("_$P(V,".",4)_")" W ! Q ; VARS ; Public system variables ; ; The following variables can be modified in accordance with the documentation s extra=$c(1) ; Key marker for oversize data strings s abyref=0 ; Set to 1 to treat all arrays as if they were passed by reference s mqinfo=0 ; Set to 1 to place all MQ error/information messages in %mgwmq("info") ; Otherwise, error messages will be placed in %mgwmq("error") ; and 'information only' messages in %mgwmq("info") ; ; The following variables must not be modified i '($d(global)#10) s global=0 i '($d(oversize)#10) s oversize=0 i '($d(offset)#10) s offset=0 i '($d(version)#10) s version=+$$V() ; #define MGW_TX_DATA 0 ; #define MGW_TX_AKEY 1 ; #define MGW_TX_AREC 2 ; #define MGW_TX_EOD 3 s ddata=0,dakey=1,darec=2,deod=3 q ; esize(esize,size,base) n i,x i base'=10 g esize1 s esize=size q $l(esize) esize1 ; Up to base 62 s esize=$$ebase62(size#base) f i=1:1 s x=(size\(base**i)) q:'x s esize=$$ebase62(x#base)_esize q $l(esize) ; dsize(esize,len,base) n i,x i base'=10 g dsize1 s size=+$e(esize,1,len) q size dsize1 ; Up to base 62 s size=0 f i=len:-1:1 s x=$e(esize,i) s size=size+($$dbase62(x)*(base**(len-i))) q size ; ebase62(n10) ; Encode to single digit (up to) base-62 number i n10'<0,n10<10 q $c(48+n10) i n10'<10,n10<36 q $c(65+(n10-10)) i n10'<36,n10<62 q $c(97+(n10-36)) q "" ; dbase62(nxx) ; Decode single digit (up to) base-62 number n x s x=$a(nxx) i x'<48,x<58 q (x-48) i x'<65,x<91 q ((x-65)+10) i x'<97,x<123 q ((x-97)+36) q "" ; ehead(head,size,byref,type) s slen=$$esize(.esize,size,10) s code=slen+(type*8)+(byref*64) s head=$c(code)_esize s hlen=slen+1 q hlen ; dhead(head,size,byref,type) s code=$a(head,1) s byref=code\64 s type=(code#64)\8 s slen=code#8 s hlen=slen+1 s size=0 i $l(head)'100 q . i y="" s ncnt=ncnt+1 q . s ncnt=0,x=x_y,n=n+$l(y),nmax=len-n . q i ncnt s x="" d HALT ; Client disconnect q x ; rdx(len,clen,rlen) ; Read from MGWSI - Initialize: (rdxsize,rdxptr,rdxrlen)=0,rdxbuf="",maxlen=$$getslen() n result,get,avail ; ;s result="" f get=1:1:len r *x s result=result_$c(x) ;s rlen=rlen+len q result ; s get=len,result="" i 'len q result f d i 'get q . s avail=rdxsize-rdxptr . ;d EVENT("i="_i_";len="_len_";avail="_avail_";get="_get_"=("_rdxbuf_") "_CLEN_" "_RLEN) . i get'>avail s result=result_$e(rdxbuf,rdxptr+1,rdxptr+get),rdxptr=rdxptr+get,get=0 q . s result=rdxbuf,rdxptr=0,get=get-avail . s avail=clen-rdxrlen i 'avail q . i avail>maxlen s avail=maxlen . s rdxbuf=$$rdxx(avail),rdxsize=avail,rdxptr=0,rdxrlen=rdxrlen+avail . ;d EVENT("rdxbuf="_i_"="_rdxbuf) . q s rlen=rlen+len q result ; CHILD(pport,port,conc,uci) ; Child new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":CHILDE" i uci'="" D UCI(uci) i 'conc d . s ^%MGWSI("TCP_PORT",pport,port)=$j . Set dev="server$"_$j,timeout=30 . ; Open TCP server device . Open dev:(ZLISTEN=port_":TCP":attach="server"):timeout:"SOCKET" . Use dev . Write /listen(1) . set %ZNSock="",%ZNFrom="" . S OK=1 F D Q:OK I $D(^%MGWSI("STOP")) S OK=0 Q . . Write /wait(timeout) . . I $KEY'="" S OK=1 Q . . d EVENT^%ZMGWSIS("Write /wait(timeout) expires") . . S OK=0 . . Q . I 'OK C dev H . set %ZNSock=$piece($KEY,"|",2),%ZNFrom=$piece($KEY,"|",3) . ;d EVENT^%ZMGWSIS("Incoming child connection from "_%ZNFrom_" ("_%ZNSock_")") . q ; s nato=0 CHILD2 ; Child request loop d VARS k ^%MGW("MPC",$J),^MGWSI($J) f i=1:1:37 k @("req"_i) k req s argc=1,array=0 i '($d(nato)#10) s nato=0 CHILD3 ; Read Request ;d EVENT("******* GET NEXT REQUEST *******") s maxlen=$$getslen() s (rdxsize,rdxptr,rdxrlen)=0,rdxbuf="" s sn=0,sl=0,ok=1,type=0,offset=0,var="req"_argc,req(argc)=var,(cmnd,pcmnd,buf)="" i 'nato r *x i nato r *x:nato i '$T D HALT ; No-activity timeout i x=0 D HALT ; Client disconnect s buf=$c(x) f r *x q:x=10!(x=0) s buf=buf_$c(x) i x=0 D HALT ; Client disconnect s type=0,byref=0 d REQ1 s @var=buf s cmnd=$p(buf,"^",2) S HLEN=$L(buf),CLEN=0 I cmnd="P" S CLEN=$$dsize($E(buf,HLEN-(5-1),HLEN),5,62) s %ZCS("client")=$E(buf,4) ;d EVENT("request size="_CLEN_" ("_$E(buf,HLEN-(5-1),HLEN)_"); client="_%ZCS("client")_" ;header = "_buf) s RLEN=0 I CLEN D REQ ; ;f i=1:1:argc d EVENT("arg "_i_" = "_$g(@req(i))) ; s req=$g(@req(1)) i req="" G CHILD2 s cmnd=$p(req,"^",2) k res s res="" s res(1)="00000cv"_$C(10) i cmnd="A" D AYT i cmnd="S" D DINT i cmnd="P" D MPHP i cmnd="H" D INFO i cmnd="X" D HALT D END k res s res="" G CHILD2 ; CHILDE ; Error d EVENT($ZS) i $ZS["READ" g HALT G CHILD2 ; HALT ; Halt i 'conc d . ; Close TCP server device . i $l($g(dev)) c dev . s x="" f s x=$o(^%MGWSI("TCP_PORT",x)) q:x="" k ^%MGWSI("TCP_PORT",x,port) . q h ; REQ ; Read request data n dev,get,got REQ0 ; Get next argument s x=$$rdx(1,CLEN,.RLEN),hlen=$$dhead(x,.size,.byref,.type) ;d EVENT("(1) CLEN="_CLEN_";RLEN="_RLEN_";hlen="_hlen_";argc="_argc_";size="_size_";byref="_byref_";type="_type) s slen=hlen-1 s esize=$$rdx(slen,CLEN,.RLEN) s size=$$dsize(esize,slen,10) ;d EVENT("(2) CLEN="_CLEN_";RLEN="_RLEN_";hlen="_hlen_";slen="_slen_";argc="_argc_";size="_size_";byref="_byref_";type="_type) s argc=argc+1 d REQ1 i type=darec d ARRAY G REQZ 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 . s got=got+get . ;d EVENT("(3) Data: CLEN="_CLEN_";RLEN="_RLEN_";size="_size_";get="_get_";sn="_sn_";pcmnd="_pcmnd_";buf="_buf) . i argc=3,pcmnd="h" s @var=buf d MPC q . i 'sn s @var=buf q . i sn s @(var_"(extra,sn)")=buf q . q REQZ ; Argument read i RLENMGWSI - Connection Test") d send("

MGWSI - Connection Test Successful

") d send("") d send("") d send("") d send("
"_$$getsys()_" Version:"_$ZV_"
UCI:"_$$getuci()_"
") d send("") q ; EVENT(TEXT) ; Log M-Side Event N port,dev,conc,N,EMAX new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":EVENTE" 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 S EMAX=100 ; Maximum log size (No. messages) L +^%MGWSI("LOG") S N=$G(^%MGWSI("LOG")) I N="" S N=0 S N=N+1,^%MGWSI("LOG")=N L -^%MGWSI("LOG") S ^%MGWSI("LOG",N,0)=$$HEAD(),^%MGWSI("LOG",N,1)=$E(TEXT,1,230) F N=N-EMAX:-1 Q:'$D(^%MGWSI("LOG",N)) K ^(N) Q EVENTE ; Error Q ; DDATE(DATE) ; Decode M date new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":DATEE" Q $ZD(DATE,2) DDATEE ; No $ZD Function Q DATE ; DTIME(TIME) ; Decode M Time Q (TIME\3600)_":"_(TIME#3600\60) ; HEAD() ; Format Header record N %UCI new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":HEADE" s %UCI=$$getuci() HEADE ; Error Q $$DDATE(+$H)_" at "_$$DTIME($P($H,",",2))_"~"_$G(%ZCS("PORT"))_"~"_%UCI ; HMACSHA256(string,key,b64,context) ; HMAC-SHA256 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"HMAC-SHA256",string,key,b64,context) ; HMACSHA1(string,key,b64,context) ; HMAC-SHA1 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"HMAC-SHA1",string,key,b64,context) ; HMACSHA(string,key,b64,context) ; HMAC-SHA Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"HMAC-SHA",string,key,b64,context) ; HMACMD5(string,key,b64,context) ; HMAC-MD5 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"HMAC-MD5",string,key,b64,context) ; SHA256(string,b64,context) ; SHA256 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"SHA256",string,"",b64,context) ; SHA1(string,b64,context) ; SHA1 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"SHA1",string,"",b64,context) ; SHA(string,b64,context) ; SHA Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"SHA",string,"",b64,context) ; MD5(string,b64,context) ; MD5 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"MD5",string,"",b64,context) ; B64(string,context) ; BASE64 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"B64",string,"",0,context) ; DB64(string,context) ; DECODE BASE64 Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"D-B64",string,"",0,context) ; TIME(context) ; TIME Q $$CRYPT("127.0.0.1",$s(context:80,1:7040),"TIME","","",0,context) ; ZTS(context) ; ZTS S TIME=$$TIME(context) S ZTS=$P($H,",",1)_","_(($P(TIME,":",1)*60*60)+($P(TIME,":",2)*60)+$P(TIME,":",3)) Q ZTS ; CRYPT(IP,PORT,METHOD,string,key,b64,context) n %mgwmq,response,method s method=METHOD i b64 s method=method_"-B64" s %mgwmq("send")=string s %mgwmq("key")=key i context=0 s response=$$WSMQ(IP,PORT,method,.%mgwmq) i context=1 s response=$$WSX(IP,PORT,method,.%mgwmq) Q $G(%mgwmq("recv")) ; WSMQ(IP,PORT,REQUEST,%mgwmq) ; Message for WebSphere MQ (Parameters passed by reference) Q $$WSMQ1(IP,PORT,REQUEST) ; WSMQ1(IP,PORT,REQUEST) ; Message for WebSphere MQ (Parameters passed by global array - %mgwmq()) N (IP,PORT,REQUEST,%mgwmq) new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":WSMQE" ; ; Close connection to Gateway i REQUEST="CLOSE" d S result=1 G WSMQ1X . i $d(%mgwmq("keepalive","dev")) s DEV=%mgwmq("keepalive","dev") k %mgwmq("keepalive") C DEV . q ; D VARS S CRLF=$C(13,10) S REQUEST=$$ucase(REQUEST) I REQUEST="GET" k %mgwsi("send") S res="" S %mgwmq("error")="" s global=+$g(%mgwmq("global")) ; ; Create TCP connection to Gateway s OK=1 i $d(%mgwmq("keepalive","dev")) s DEV=%mgwmq("keepalive","dev") i '$d(%mgwmq("keepalive","dev")) d . S DEV="client$"_$j,timeout=10 . O DEV:(connect=IP_":"_PORT_":TCP":attach="client"):timeout:"SOCKET" E S %mgwmq("error")="Cannot connect to MGWSI" s OK=0 . q i 'OK S result=0 G WSMQ1X ; S maxlen=$$getslen() S BUFFER="",BSIZE=0,EOF=0 S DEV(0)=$IO U DEV S REQ="WSMQ "_REQUEST_" v1.1"_CRLF D WSMQS 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 S REQ=CRLF D WSMQS i global d . S REQ=$G(^MGWSI($j,1,"send")) I REQ'="" D WSMQS . 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 . 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 . q i 'global d . S REQ=$G(%mgwmq("send")) I REQ'="" D WSMQS . S X="" F S X=$O(%mgwmq("send",extra,X)) Q:X="" S REQ=$G(%mgwmq("send",extra,X)) I REQ'="" D WSMQS . S X="" F S X=$O(%mgwmq("send",X)) Q:X="" I X'=extra S REQ=$G(%mgwmq("send",X)) I REQ'="" D WSMQS . q ;S REQ=$C(deod),EOF=1 D WSMQS S REQ=$C(7),EOF=1 D WSMQS U DEV s size=+$$rdxx(10) S res="",len=0,sn=0,got=0,pre="",plen=0,hdr=1 F d q:got=size . s get=size-got i get>maxlen s get=maxlen . s x=$$rdxx(get) s got=got+get . i got=size,$e(x,get)=$c(deod) s x=$e(x,1,get-1) . i hdr d q . . s lx=$l(x,$c(13)) f i=1:1:lx d q:'hdr . . . s r=$p(x,$c(13),i) . . . i i=lx s pre=r,plen=$l(pre) q . . . i plen s r=pre_r,pre="",plen=0 . . . 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 . . . s nam=$p(r,": ",1),val=$p(r,": ",2,99999) . . . i $e(nam)=$c(10) s nam=$e(nam,2,99999) . . . i nam'="" s %mgwmq(nam)=val . . . q . . q . s to=maxlen-plen . s res=pre_$e(x,1,to),pre=$e(x,to+1,99999),plen=$l(pre) . i global d . . i 'sn s ^MGWSI($j,1,"recv")=res,res="",sn=sn+1 q . . i sn s ^MGWSI($j,1,"recv",extra,sn)=res,res="",sn=sn+1 q . . q . i 'global d . . i 'sn s %mgwmq("recv")=res,res="",sn=sn+1 q . . i sn s %mgwmq("recv",extra,sn)=res,res="",sn=sn+1 q . . q . q s result=1 i global d . i plen,'sn s ^MGWSI($j,1,"recv")=pre,plen=0,sn=sn+1 . i plen,sn s ^MGWSI($j,1,"recv",extra,sn)=pre,plen=0,sn=sn+1 . i $g(^MGWSI($j,1,"r_code"))=2033 s result=0 . i $l($g(^MGWSI($j,1,"error"))) s result=0 . i $g(^MGWSI($j,1,"recv"))[":MGWSI:ERROR:" s result=0 . q i 'global d . i plen,'sn s %mgwmq("recv")=pre,plen=0,sn=sn+1 . i plen,sn s %mgwmq("recv",extra,sn)=pre,plen=0,sn=sn+1 . i $g(%mgwmq("r_code"))=2033 s result=0 . i $l($g(%mgwmq("error"))) s result=0 . i $g(%mgwmq("recv"))[":MGWSI:ERROR:" s result=0 . q U DEV(0) i $g(%mgwmq("keepalive"))=1 S %mgwmq("keepalive","dev")=DEV i $g(%mgwmq("keepalive"))'=1 C DEV WSMQ1X ; Exit point I $G(mqinfo) M %mgwmq("info")=%mgwmq("error") S %mgwmq("error")="" Q result ; WSMQE ; Error (EOF) new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":" i $D(DEV(0)) U DEV(0) i '$D(DEV(0)) U 0 i $g(%mgwmq("keepalive"))=1 S %mgwmq("keepalive","dev")=DEV i $g(%mgwmq("keepalive"))'=1 C DEV I $l($G(%mgwmq("error"))) G WSMQEX S %mgwmq("error")=$ZS G WSMQEX WSMQEX ; Exit point I $G(mqinfo) M %mgwmq("info")=%mgwmq("error") S %mgwmq("error")="" Q 0 ; WSMQS ; Send outgoing header N N,X,LEN WSMQS1 S LEN=$L(REQ) I (BSIZE+LEN)127)!(C?1P) S LEN=$$esize(.N16,A,16) S:LEN=1 N16="0"_N16 S C="%"_N16 S OUT=OUT_C Q . S OUT=OUT_C Q . Q Q OUT ; MPHP ; Request from m_client n port,dev,conc,cmnd,nato s cmnd=$p(req,"^",4) d PHP q ; PHP ; Serve request from m_client n argz,i,m new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":phpe^%ZMGWSIS" s res="" i cmnd="S" d set i cmnd="G" d get i cmnd="K" d kill i cmnd="D" d data i cmnd="O" d order i cmnd="P" d previous i cmnd="M" d mergedb i cmnd="m" d mergephp i cmnd="H" d html i cmnd="y" d htmlm i cmnd="h" d http i cmnd="X" d proc i cmnd="x" d meth i cmnd="W" d web q phpe ; Error d EVENT($$client()_" Error : "_$ZS) k res s res="",res(2)="M Server Error : ["_$g(req(2))_"]"_$tr($ZS,"<>%","[]^")_$g(ref) s res(1)="00000ce"_$C(10) q ; client() ; Get client name s name="m_client" i $g(%ZCS("client"))="z" s name="m_php" i $g(%ZCS("client"))="j" s name="m_jsp" i $g(%ZCS("client"))="a" s name="m_aspx" i $g(%ZCS("client"))="p" s name="m_python" i $g(%ZCS("client"))="r" s name="m_ruby" i $g(%ZCS("client"))="h" s name="m_apache" i $g(%ZCS("client"))="c" s name="m_cgi" i $g(%ZCS("client"))="w" s name="m_websphere_mq" q name ; set ; Global set i argc<3 q s argz=argc-1 s fun=0 d ref x "s "_ref_"="_"req"_argc d res Q ; get ; Global get i argc<2 q s argz=argc s fun=0 d ref x "s res=$g("_ref_")" d res Q ; kill ; Global kill i argc<1 q s argz=argc s fun=0 d ref x "k "_ref d res Q ; data ; Global get i argc<2 q s argz=argc s fun=0 d ref x "s res=$d("_ref_")" d res Q ; order ; Global order i argc<3 q s argz=argc s fun=0 d ref x "s res=$o("_ref_")" d res Q ; previous ; Global reverse order i argc<3 q s argz=argc s fun=0 d ref x "s res=$o("_ref_",-1)" d res Q ; mergedb ; Global Merge from PHP i argc<3 q s a="" f argz=1:1 q:'$d(req(argz)) i $g(req(argz,0))=1 s a=req(argz) q i a="" q s argz=argz-1 s fun=0 d ref i ref["()" s ref=$p(ref,"()",1) i $g(@req(argz+2))["ks" x "k "_ref x "m "_ref_"="_a d res Q ; mergephp ; Global Merge to PHP i argc<3 q s a="" f argz=1:1 q:'$d(req(argz)) i $g(req(argz,0))=1 s a=req(argz) q i a="" q s argz=argz-1 s fun=0 d ref i ref["()" s ref=$p(ref,"()",1) x "m "_a_"="_ref s argz=argz+1 s abyref=1 d res Q ; html ; HTML s res(1)=$c(1,2,1,10)_"0sc"_$C(10) w res(1) i argc<2 q s argz=argc s fun=0 d ref x "n ("_refn_") d "_ref Q ; htmlm ; HTML (COS) Method s res(1)=$c(1,2,1,10)_"0sc"_$C(10) w res(1) i argc<1 q s argz=argc s fun=0 d oref s ref=$tr($p(ref,",",1,2),".","")_","_$p(ref,",",3,999) i argc=1 x "n ("_refn_") s req(-1)=$zobjclassmethod()" i argc>1 x "n ("_refn_") s req(-1)=$zobjclassmethod("_ref_")" s res=$g(req(-1)) Q ; web ; Web request N REQ,x,y,i new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":webe^%ZMGWSIS" s res(1)=$c(1,2,1,10)_"0sc"_$C(10) w res(1) i argc'=4 g webe s argz=argc s fun=1 d ref 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) x "n ("_refn_") d "_ref q webe ; error S REQ="" S REQ=REQ_"HTTP/1.1 200 OK"_$C(13,10) S REQ=REQ_"Content-type: text/plain"_$C(13,10) S REQ=REQ_"Connection: close"_$C(13,10) S REQ=REQ_$C(13,10) S REQ=REQ_"Error calling web function "_$g(ref)_$g(refn)_$C(13,10) S REQ=REQ_$ZS S REQ=REQ_"Web functions contain two arguments"_$C(13,10) W REQ Q ; WEB(CGI,DATA) N REQ,X,Y S REQ="" S REQ=REQ_"HTTP/1.1 200 OK"_$C(13,10) S REQ=REQ_"Content-type: text/plain"_$C(13,10) S REQ=REQ_"Connection: close"_$C(13,10) S REQ=REQ_$C(13,10) W REQ W $G(CGI) S X="" F S X=$O(CGI(X)) Q:X="" W X_"="_$G(CGI(X))_$C(13,10) W $C(13,10) 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) Q ; http ; HTTP new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":httpe" i argc<2 q s x=$$http1(.req2,@req(3)) httpx ; exit k ^%MGW("MPC",$J,"CONTENT") Q httpe ; Error w "m_php/jsp: Error

eXtc is not installed on this computer

" q ; http1(%CGIEVAR,content) ; HTTP n (%CGIEVAR,content) s test=0 i test d q 0 . w "
CGI" . s x="" f s x=$o(%CGIEVAR(x)) q:x="" w "
"_x_"="_$g(%CGIEVAR(x)) . w "
CONTENT" . s x="" f s x=$o(^%MGW("MPC",$J,"CONTENT",x)) q:x="" w "
"_x_"="_$g(^%MGW("MPC",$J,"CONTENT",x)) . q i $G(%CGIEVAR("key_eXtcServer"))="true" d QUIT 1 . ; break out to eXtc Server here . s namespace=$G(%CGIEVAR("key_namespace")) . s:namespace'="" namespace=$G(^%eXtc("system","phpSettings","namespace",namespace)) . s:namespace="" namespace=$G(^%eXtc("system","phpSettings","defaultNamespace")) . s:namespace="" namespace="%CACHELIB" . d PHPServer^%eXMLServer QUIT 0 ; proc ; M extrinsic function i argc<2 q s argz=argc s fun=1 d ref i argc=2 x "n ("_refn_") s req(-1)=$$"_ref_"()" i argc>2 x "n ("_refn_") s req(-1)=$$"_ref s res=$g(req(-1)) d res Q ; meth ; M (COS) method ; ; Synopsis: ; s err=$zobjclassmethod(className,methodName,param1,...,paramN) ; ; s className="eXtc.DOMAPI" ; s methodName="openDOM" ; s err=$zobjclassmethod(className,methodName) ; ; ; This is equivalent to ... ; s err=##class(eXtc.DOMAPI).openDOM() ; ; s methodName="getDocumentNode" ; s documentName="eXtcDOM2" ; s err=$zobjclassmethod(className,methodName,documentName) ; ; This is equivalent to ... ; s err=##class(eXtc.DOMAPI).getDocumentNode("eXtcDOM2") ; i argc<1 q s argz=argc s fun=1 d oref s ref=$tr($p(ref,",",1,2),".","")_","_$p(ref,",",3,999) i argc=1 x "n ("_refn_") s req(-1)=$zobjclassmethod()" i argc>1 x "n ("_refn_") s req(-1)=$zobjclassmethod("_ref_")" s res=$g(req(-1)) d res Q ; sort(a) ; Sort an array q 1 ; ref ; Global reference n com,i,strt,a1 s array=0,refn="res,req,extra,global,oversize" i argc<2 q s a1=$g(@req(2)) s strt=2 i a1?1"^"."^" s strt=strt+1 s ref=@req(strt) i argc=strt q s ref=ref_"(" s com="" f i=strt+1:1:argz s refn=refn_","_req(i),ref=ref_com_$s(fun:".",1:"")_req(i),com="," s ref=ref_")" q ; oref ; Object reference n com,i,strt,a1 s array=0,refn="req,extra,global,oversize" i argc<2 q s a1=$g(@req(2)) s strt=2 i a1?1"^"."^" s strt=strt+1 i '$d(req(strt)) q s ref="" s com="" f i=strt:1:argz s refn=refn_","_req(i),ref=ref_com_$s(fun:".",1:"")_req(i),com="," q ; res ; Return result n i,a,sn,argc s maxlen=$$getslen() d VARS s anybyref=0 f argc=1:1:argz q:'$d(req(argc)) i $g(req(argc,1)) s anybyref=1 q i 'anybyref d q . d send($g(res)) . i oversize f sn=1:1 q:'$d(^MGWSI($j,0,extra,sn)) d send($g(^(sn))) . q s res(1)="00000cc"_$C(10) s size=$l($g(res)),byref=0 i oversize f sn=1:1 q:'$d(^MGWSI($j,0,extra,sn)) s size=size+$l(^(sn)) s x=$$ehead(.head,size,byref,ddata) d send(head) d send($g(res)) i oversize f sn=1:1 q:'$d(^MGWSI($j,0,extra,sn)) d send($g(^(sn))) f argc=1:1:argz q:'$d(req(argc)) d . s byref=$g(req(argc,1)) . s array=$g(req(argc,0)) . i 'byref s size=0,x=$$ehead(.head,size,byref,ddata) d send(head) q . i 'array d q . . s size=$l($g(@req(argc))) . . f sn=1:1 q:'$d(@(req(argc)_"(extra,sn)")) s size=size+$l($g(@(req(argc)_"(extra,sn)"))) . . s x=$$ehead(.head,size,byref,ddata) . . d send(head) . . d send($g(@req(argc))) . . f sn=1:1 q:'$d(@(req(argc)_"(extra,sn)")) d send($g(@(req(argc)_"(extra,sn)"))) . . q . s x=$$ehead(.head,0,0,darec) . d send(head) . d resa . s x=$$ehead(.head,0,0,deod) . d send(head) . q q ; res1 ; Link to array parser d send($g(req(argc,0))_$g(req(argc,1))) i '$g(req(argc,1)) q i $g(req(argc,0))=0 d send($g(@req(argc))) q s a=req(argc),fkey="" i global s a="^MGWSI",fkey="$j,argc-2" d resa q ; resa ; Return array n ref,kn,ok,def,data,txt new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":resae" s byref=0 s a=req(argc),fkey="" i global s a="^MGWSI",fkey="$j,argc-2" i a="" q i global d . i ($d(@(a_"("_fkey_")"))#10) d . . s txt=" ",x=$$ehead(.head,$l(txt),byref,dakey) d send(head),send(txt) . . s size=0 . . s size=size+$l($g(@req(argc))) . . f sn=1:1 q:'$d(@(a_"("_fkey_","_"extra,sn)")) s size=size+$l($g(^(sn))) . . s x=$$ehead(.head,size,byref,ddata) d send(head) . . d send($g(@req(argc))) . . f sn=1:1 q:'$d(@(a_"("_fkey_","_"extra,sn)")) d send($g(^(sn))) . . q . s fkey=fkey_"," . q i 'global d . i ($d(@a)#10),$l($g(@a)) d . . s txt=" ",x=$$ehead(.head,$l(txt),byref,dakey) d send(head),send(txt) . . s size=0 . . s size=size+$l($g(@a)) . . f sn=1:1 q:'$d(@(a_"(extra,sn)")) s size=size+$l($g(@(a_"(extra,sn)"))) . . s x=$$ehead(.head,size,byref,ddata) d send(head) . . d send($g(@a)) . . f sn=1:1 q:'$d(@(a_"(extra,sn)")) d send($g(@(a_"(extra,sn)"))) . . q . q s ok=0,kn=1,x(kn)="",ref="x("_kn_")" f s x(kn)=$o(@(a_"("_fkey_ref_")")) d resa1 i ok q q resae ; Error new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":" q ; resa1 ; Array node i x(kn)=extra q i x(kn)="",kn=1 s ok=1 q i x(kn)="" s kn=kn-1,ref=$p(ref,",",1,$l(ref,",")-1) q s def=$d(@(a_"("_fkey_ref_")")) i (def\10) d resa3 s data=$g(@(a_"("_fkey_ref_")")) i (def#10) d resa2 i (def\10) s kn=kn+1,x(kn)="",ref=ref_","_"x("_kn_")" q ; resa2 ; Array node data n i,spc f i=1:1:kn s x=$$ehead(.head,$l(x(i)),byref,dakey) d send(head),send(x(i)) i $g(%ZCS("client"))="z",(def\10) s spc=" ",x=$$ehead(.head,$l(spc),byref,dakey) d send(head),send(spc) s size=$l(data) f sn=1:1 q:'$d(@(a_"("_fkey_ref_",extra,sn)")) s size=size+$l($g(@(a_"("_fkey_ref_",extra,sn)"))) s x=$$ehead(.head,size,byref,ddata) d send(head) d send(data) f sn=1:1 q:'$d(@(a_"("_fkey_ref_",extra,sn)")) d send($g(@(a_"("_fkey_ref_",extra,sn)"))) q ; resa3 ; Array node data with descendants - test for non-extra data n y s y="" f s y=$o(@(a_"("_ref_",y)")) q:y="" i y'=extra q i y="" s def=1 q ; send(data) ; Send data n n ;D EVENT(data_$g(res(1))) s n=$o(res(""),-1) i n="" s n=1 i $l($g(res(n)))+$l(data)>maxlen s n=n+1 s res(n)=$g(res(n))_data q ; getsys() ; Get system type s systype="GTM" q systype ; getuci() ; Get NameSpace/UCI new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":getucie^%ZMGWSIS" s %UCI=$ZG q %UCI getucie ; Error q "" ; getslen() ; Get maximum string length s slen=32000 q slen ; lcase(string) ; Convert to lower case q $tr(string,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") ; ucase(string) ; Convert to upper case q $tr(string,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") ; setio(tblname) ; Set I/O translation new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":setioe^%ZMGWSIS" Q "" setioe ; Error - do nothing Q "" ; zcvt(buffer,tblname) ; Translate buffer new $ZTRAP set $ZTRAP="ZGOTO "_$ZLEVEL_":zcvte^%ZMGWSIS" Q buffer zcvte ; Error - do nothing Q buffer ; WSMQTEST ; Test link to WebSphere MQ n %mgwmq,response w !,"Sending Test Message to MGWSI/WebSphere MQ interface..." S response=$$WSMQ("127.0.0.1",7040,"TEST",.%mgwmq) W !,"Response: ",response," ",$G(%mgwmq("recv")) Q ; WSMQTSTX(IP,PORT) ; Test link to WebSphere MQ: IP address and Port specified n %mgwmq,response w !,"Sending Test Message to MGWSI/WebSphere MQ interface..." S response=$$WSMQ(IP,PORT,"TEST",.%mgwmq) W !,"Response: ",response," ",$G(%mgwmq("recv")) Q ; HTEST ; Return HTML n systype s systype=$$getsys() w "A line of HTML from "_systype_"" Q ; HTEST1(P1) ; Return HTML n x,systype s systype=$$getsys() ;W "HTTP/1.1 200 OK",$c(13,10) ;W "Content-Type: text/html",$c(13,10) ;W "Connection: close",$c(13,10) ;W $c(13,10) w "HTML content returned from "_systype_"" W "
The input parameter passed was: "_$g(P1)_"" s x="" f s x=$o(P1(x)) q:x="" W "
Array element passed: "_x_" = "_$g(P1(x))_"" Q ; PTEST() ; Return result n systype s systype=$$getsys() q "Result from "_systype_" process: "_$J_"; UCI: "_$$getuci() Q ; PTEST1(P1) ; Return result n systype s systype=$$getsys() q "Result from "_systype_" process: "_$J_"; UCI: "_$$getuci()_"; The input parameter passed was: "_P1 ; PTEST2(P1,P2) ; Manipulate an array n n,x,systype s systype=$$getsys() s n=0,x="" f s x=$o(P1(x)) q:x="" s n=n+1 s P1("Key from M - 1")="Value 1" s P1("Key from M - 2")="Value 2" s P2="Stratford" q "Result from "_systype_" process: "_$J_"; UCI: "_$$getuci()_"; "_n_" elements were received in an array, 2 were added by this procedure" ;