XUSBSE2 ;FO-OAK/JLI-CONNECT WITH HTTP SERVER AND GET REPLY ;04/29/09 12:47
;;8.0;KERNEL;**404,439,523**;Jul 10, 1995;Build 16
Q
;
; Original version, returns only first line after headers
POST(SERVER,PORT,PAGE,DATA) ;
N RESULTS
Q $$ENTRY1(.RESULTS,SERVER,$G(PORT),$G(PAGE),"POST",$G(DATA))
;
; updated, returns entire conversation
POST1(RESULTS,SERVER,PORT,PAGE,DATA) ;
Q $$ENTRY1(.RESULTS,SERVER,$G(PORT),$G(PAGE),"POST",$G(DATA))
;
GET(SERVER,PORT,PAGE) ;
N RESULTS
Q $$ENTRY1(.RESULTS,SERVER,$G(PORT),$G(PAGE),"GET")
;
GET1(RESULTS,SERVER,PORT,PAGE) ;
Q $$ENTRY1(.RESULTS,SERVER,$G(PORT),$G(PAGE),"GET")
;
ENTRY(SERVER,PORT,PAGE,HTTPTYPE,DATA) ;
N RESULTS
S HTTPTYPE=$G(HTTPTYPE,"GET")
Q $$ENTRY1(.RESULTS,SERVER,$G(PORT),$G(PAGE),HTTPTYPE,$G(DATA))
;
ENTRY1(RESULTS,SERVER,PORT,PAGE,HTTPTYPE,DATA) ;
N DONE,XVALUE,XWBICNT,XWBRBUF,XWBSBUF,XWBTDEV,I
N XWBDEBUG,XWBOS,XWBT,XWBTIME,POP,RESLTCNT,LINEBUF,OVERFLOW
N $ESTACK,$ETRAP S $ETRAP="D TRAP^XUSBSE2"
K RESULTS
S PAGE=$G(PAGE,"/") I PAGE="" S PAGE="/"
S HTTPTYPE=$G(HTTPTYPE,"GET")
S DATA=$G(DATA),PORT=$G(PORT,80)
D SAVDEV^%ZISUTL("XUSBSE") ;S IO(0)=$P
D INIT^XWBTCPM
D OPEN^XWBTCPM2(SERVER,PORT)
I POP Q "DIDN'T OPEN CONNECTION"
S XWBSBUF=""
U XWBTDEV
D WRITE^XWBRW(HTTPTYPE_" "_PAGE_" HTTP/1.0"_$C(13,10))
I HTTPTYPE="POST" D
. D WRITE^XWBRW("Referer: http://"_$$KSP^XUPARAM("WHERE")_$C(13,10))
. D WRITE^XWBRW("Content-Type: application/x-www-form-urlencoded"_$C(13,10))
. D WRITE^XWBRW("Cache-Control: no-cache"_$C(13,10))
. D WRITE^XWBRW("Content-Length: "_$L(DATA)_$C(13,10,13,10))
. D WRITE^XWBRW(DATA)
D WRITE^XWBRW($C(13,10))
D WBF^XWBRW
S XWBRBUF="",DONE=0,XWBICNT=0
S OVERFLOW=""
S XVALUE=$$DREAD($C(13,10)) I $G(RESULTS(1))'[200 S XVALUE=$P($G(RESULTS(1))," ",2,5)
D CLOSE ;I IO="|TCP|80" U IO D ^%ZISC
I LINEBUF'="" S RESLTCNT=RESLTCNT+1,RESULTS(RESLTCNT)=LINEBUF
I $G(RESULTS(1))[200 F I=1:1 I RESULTS(I)="" S XVALUE=$G(RESULTS(I+1)) Q
Q XVALUE
;
CLOSE ;
D CLOSE^%ZISTCP,GETDEV^%ZISUTL("XUSBSE") I $L(IO) U IO
Q
;
DREAD(D,TO) ;Delimiter Read
N R,S,DONE,C,L
; ZEXCEPT: LINEBUF,OVERFLOW,RESLTCNT,RESULTS,XWBRBUF - NEWed and set in ENTRY
; ZEXCEPT: XWBDEBUG,XWBTDEV,XWBTIME - XWB global variables
N $ES,$ET S $ET="S DONE=1,$EC="""" Q"
S R="",DONE=0,D=$G(D,$C(13)),C=0
S TO=$S($G(TO)>0:TO,$G(XWBTIME(1))>0:XWBTIME(1),1:60)/2+1
U XWBTDEV
F D Q:DONE
. S L=$F(XWBRBUF,D),L=$S(L>0:L,1:$L(XWBRBUF)+1),R=R_$E(XWBRBUF,1,L-1),XWBRBUF=$E(XWBRBUF,L,32000)
. ; I (R[D)!(C>TO) S DONE=1 Q
. I C>TO S DONE=1 Q
. R XWBRBUF:2 S:'$T C=C+1 S:$L(XWBRBUF) C=0
. S LINEBUF=OVERFLOW_XWBRBUF F S L=$F(LINEBUF,D) Q:'L S RESLTCNT=$G(RESLTCNT)+1,RESULTS(RESLTCNT)=$E(LINEBUF,1,L-3),LINEBUF=$E(LINEBUF,L,32000)
. S OVERFLOW=LINEBUF
. I $G(XWBDEBUG)>2,$L(XWBRBUF) D LOG^XWBDLOG($E("rd ("_$L(XWBRBUF)_"): "_XWBRBUF,1,255))
. Q
Q R
;
TRAP ;
I '(($EC["READ")!($EC["WRITE")) D ^%ZTER
D CLOSE,LOG^XWBDLOG("Error: "_$$EC^%ZOSV):$G(XWBDEBUG),UNWIND^%ZTER
Q
;
EN(ADDRESS) ; test with input address or 127.0.0.1 if none entered
N RESULTS
D EN1(ADDRESS,.RESULTS)
Q
;
EN1(ADDRESS,RESULTS,NOHEADERS) ;
N VALUE,PAGE,SERVER,PORT
S NOHEADERS=$G(NOHEADERS,1)
S PAGE="/",SERVER=ADDRESS,PORT=80
I SERVER["/" D
. I SERVER["//" S SERVER=$P(SERVER,"//",2)
. I SERVER["/" S PAGE="/"_$P(SERVER,"/",2,99),SERVER=$P(SERVER,"/")
. I SERVER[":" S PORT=$P(SERVER,":",2),SERVER=$P(SERVER,":")
. Q
S VALUE=$$ENTRY1(.RESULTS,SERVER,PORT,PAGE)
D HOME^%ZIS ;I IO="|TCP|80" U IO D ^%ZISC
; if NOHEADERS selected (default) remove the headers and first blank line
I NOHEADERS D
. N I,J,X
. ; remove header lines and first blank line
. F I=1:1 Q:'$D(RESULTS(I)) S X=(RESULTS(I)="") K:'X RESULTS(I) I X K RESULTS(I) Q
. ; move lines down to start at 1 again
. S J=I,I=0 F S J=J+1,I=I+1 Q:'$D(RESULTS(J)) S RESULTS(I)=RESULTS(J) K RESULTS(J)
. Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSBSE2 3965 printed Dec 13, 2024@02:12:08 Page 2
XUSBSE2 ;FO-OAK/JLI-CONNECT WITH HTTP SERVER AND GET REPLY ;04/29/09 12:47
+1 ;;8.0;KERNEL;**404,439,523**;Jul 10, 1995;Build 16
+2 QUIT
+3 ;
+4 ; Original version, returns only first line after headers
POST(SERVER,PORT,PAGE,DATA) ;
+1 NEW RESULTS
+2 QUIT $$ENTRY1(.RESULTS,SERVER,$GET(PORT),$GET(PAGE),"POST",$GET(DATA))
+3 ;
+4 ; updated, returns entire conversation
POST1(RESULTS,SERVER,PORT,PAGE,DATA) ;
+1 QUIT $$ENTRY1(.RESULTS,SERVER,$GET(PORT),$GET(PAGE),"POST",$GET(DATA))
+2 ;
GET(SERVER,PORT,PAGE) ;
+1 NEW RESULTS
+2 QUIT $$ENTRY1(.RESULTS,SERVER,$GET(PORT),$GET(PAGE),"GET")
+3 ;
GET1(RESULTS,SERVER,PORT,PAGE) ;
+1 QUIT $$ENTRY1(.RESULTS,SERVER,$GET(PORT),$GET(PAGE),"GET")
+2 ;
ENTRY(SERVER,PORT,PAGE,HTTPTYPE,DATA) ;
+1 NEW RESULTS
+2 SET HTTPTYPE=$GET(HTTPTYPE,"GET")
+3 QUIT $$ENTRY1(.RESULTS,SERVER,$GET(PORT),$GET(PAGE),HTTPTYPE,$GET(DATA))
+4 ;
ENTRY1(RESULTS,SERVER,PORT,PAGE,HTTPTYPE,DATA) ;
+1 NEW DONE,XVALUE,XWBICNT,XWBRBUF,XWBSBUF,XWBTDEV,I
+2 NEW XWBDEBUG,XWBOS,XWBT,XWBTIME,POP,RESLTCNT,LINEBUF,OVERFLOW
+3 NEW $ESTACK,$ETRAP
SET $ETRAP="D TRAP^XUSBSE2"
+4 KILL RESULTS
+5 SET PAGE=$GET(PAGE,"/")
IF PAGE=""
SET PAGE="/"
+6 SET HTTPTYPE=$GET(HTTPTYPE,"GET")
+7 SET DATA=$GET(DATA)
SET PORT=$GET(PORT,80)
+8 ;S IO(0)=$P
DO SAVDEV^%ZISUTL("XUSBSE")
+9 DO INIT^XWBTCPM
+10 DO OPEN^XWBTCPM2(SERVER,PORT)
+11 IF POP
QUIT "DIDN'T OPEN CONNECTION"
+12 SET XWBSBUF=""
+13 USE XWBTDEV
+14 DO WRITE^XWBRW(HTTPTYPE_" "_PAGE_" HTTP/1.0"_$CHAR(13,10))
+15 IF HTTPTYPE="POST"
Begin DoDot:1
+16 DO WRITE^XWBRW("Referer: http://"_$$KSP^XUPARAM("WHERE")_$CHAR(13,10))
+17 DO WRITE^XWBRW("Content-Type: application/x-www-form-urlencoded"_$CHAR(13,10))
+18 DO WRITE^XWBRW("Cache-Control: no-cache"_$CHAR(13,10))
+19 DO WRITE^XWBRW("Content-Length: "_$LENGTH(DATA)_$CHAR(13,10,13,10))
+20 DO WRITE^XWBRW(DATA)
End DoDot:1
+21 DO WRITE^XWBRW($CHAR(13,10))
+22 DO WBF^XWBRW
+23 SET XWBRBUF=""
SET DONE=0
SET XWBICNT=0
+24 SET OVERFLOW=""
+25 SET XVALUE=$$DREAD($CHAR(13,10))
IF $GET(RESULTS(1))'[200
SET XVALUE=$PIECE($GET(RESULTS(1))," ",2,5)
+26 ;I IO="|TCP|80" U IO D ^%ZISC
DO CLOSE
+27 IF LINEBUF'=""
SET RESLTCNT=RESLTCNT+1
SET RESULTS(RESLTCNT)=LINEBUF
+28 IF $GET(RESULTS(1))[200
FOR I=1:1
IF RESULTS(I)=""
SET XVALUE=$GET(RESULTS(I+1))
QUIT
+29 QUIT XVALUE
+30 ;
CLOSE ;
+1 DO CLOSE^%ZISTCP
DO GETDEV^%ZISUTL("XUSBSE")
IF $LENGTH(IO)
USE IO
+2 QUIT
+3 ;
DREAD(D,TO) ;Delimiter Read
+1 NEW R,S,DONE,C,L
+2 ; ZEXCEPT: LINEBUF,OVERFLOW,RESLTCNT,RESULTS,XWBRBUF - NEWed and set in ENTRY
+3 ; ZEXCEPT: XWBDEBUG,XWBTDEV,XWBTIME - XWB global variables
+4 NEW $ESTACK,$ETRAP
SET $ETRAP="S DONE=1,$EC="""" Q"
+5 SET R=""
SET DONE=0
SET D=$GET(D,$CHAR(13))
SET C=0
+6 SET TO=$SELECT($GET(TO)>0:TO,$GET(XWBTIME(1))>0:XWBTIME(1),1:60)/2+1
+7 USE XWBTDEV
+8 FOR
Begin DoDot:1
+9 SET L=$FIND(XWBRBUF,D)
SET L=$SELECT(L>0:L,1:$LENGTH(XWBRBUF)+1)
SET R=R_$EXTRACT(XWBRBUF,1,L-1)
SET XWBRBUF=$EXTRACT(XWBRBUF,L,32000)
+10 ; I (R[D)!(C>TO) S DONE=1 Q
+11 IF C>TO
SET DONE=1
QUIT
+12 READ XWBRBUF:2
if '$TEST
SET C=C+1
if $LENGTH(XWBRBUF)
SET C=0
+13 SET LINEBUF=OVERFLOW_XWBRBUF
FOR
SET L=$FIND(LINEBUF,D)
if 'L
QUIT
SET RESLTCNT=$GET(RESLTCNT)+1
SET RESULTS(RESLTCNT)=$EXTRACT(LINEBUF,1,L-3)
SET LINEBUF=$EXTRACT(LINEBUF,L,32000)
+14 SET OVERFLOW=LINEBUF
+15 IF $GET(XWBDEBUG)>2
IF $LENGTH(XWBRBUF)
DO LOG^XWBDLOG($EXTRACT("rd ("_$LENGTH(XWBRBUF)_"): "_XWBRBUF,1,255))
+16 QUIT
End DoDot:1
if DONE
QUIT
+17 QUIT R
+18 ;
TRAP ;
+1 IF '(($ECODE["READ")!($ECODE["WRITE"))
DO ^%ZTER
+2 DO CLOSE
if $GET(XWBDEBUG)
DO LOG^XWBDLOG("Error: "_$$EC^%ZOSV)
DO UNWIND^%ZTER
+3 QUIT
+4 ;
EN(ADDRESS) ; test with input address or 127.0.0.1 if none entered
+1 NEW RESULTS
+2 DO EN1(ADDRESS,.RESULTS)
+3 QUIT
+4 ;
EN1(ADDRESS,RESULTS,NOHEADERS) ;
+1 NEW VALUE,PAGE,SERVER,PORT
+2 SET NOHEADERS=$GET(NOHEADERS,1)
+3 SET PAGE="/"
SET SERVER=ADDRESS
SET PORT=80
+4 IF SERVER["/"
Begin DoDot:1
+5 IF SERVER["//"
SET SERVER=$PIECE(SERVER,"//",2)
+6 IF SERVER["/"
SET PAGE="/"_$PIECE(SERVER,"/",2,99)
SET SERVER=$PIECE(SERVER,"/")
+7 IF SERVER[":"
SET PORT=$PIECE(SERVER,":",2)
SET SERVER=$PIECE(SERVER,":")
+8 QUIT
End DoDot:1
+9 SET VALUE=$$ENTRY1(.RESULTS,SERVER,PORT,PAGE)
+10 ;I IO="|TCP|80" U IO D ^%ZISC
DO HOME^%ZIS
+11 ; if NOHEADERS selected (default) remove the headers and first blank line
+12 IF NOHEADERS
Begin DoDot:1
+13 NEW I,J,X
+14 ; remove header lines and first blank line
+15 FOR I=1:1
if '$DATA(RESULTS(I))
QUIT
SET X=(RESULTS(I)="")
if 'X
KILL RESULTS(I)
IF X
KILL RESULTS(I)
QUIT
+16 ; move lines down to start at 1 again
+17 SET J=I
SET I=0
FOR
SET J=J+1
SET I=I+1
if '$DATA(RESULTS(J))
QUIT
SET RESULTS(I)=RESULTS(J)
KILL RESULTS(J)
+18 QUIT
End DoDot:1
+19 QUIT
+20 ;
