Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XUSBSE2

XUSBSE2.m

Go to the documentation of this file.
  1. 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
  1. Q
  1. ;
  1. ; Original version, returns only first line after headers
  1. POST(SERVER,PORT,PAGE,DATA) ;
  1. N RESULTS
  1. Q $$ENTRY1(.RESULTS,SERVER,$G(PORT),$G(PAGE),"POST",$G(DATA))
  1. ;
  1. ; updated, returns entire conversation
  1. POST1(RESULTS,SERVER,PORT,PAGE,DATA) ;
  1. Q $$ENTRY1(.RESULTS,SERVER,$G(PORT),$G(PAGE),"POST",$G(DATA))
  1. ;
  1. GET(SERVER,PORT,PAGE) ;
  1. N RESULTS
  1. Q $$ENTRY1(.RESULTS,SERVER,$G(PORT),$G(PAGE),"GET")
  1. ;
  1. GET1(RESULTS,SERVER,PORT,PAGE) ;
  1. Q $$ENTRY1(.RESULTS,SERVER,$G(PORT),$G(PAGE),"GET")
  1. ;
  1. ENTRY(SERVER,PORT,PAGE,HTTPTYPE,DATA) ;
  1. N RESULTS
  1. S HTTPTYPE=$G(HTTPTYPE,"GET")
  1. Q $$ENTRY1(.RESULTS,SERVER,$G(PORT),$G(PAGE),HTTPTYPE,$G(DATA))
  1. ;
  1. ENTRY1(RESULTS,SERVER,PORT,PAGE,HTTPTYPE,DATA) ;
  1. N DONE,XVALUE,XWBICNT,XWBRBUF,XWBSBUF,XWBTDEV,I
  1. N XWBDEBUG,XWBOS,XWBT,XWBTIME,POP,RESLTCNT,LINEBUF,OVERFLOW
  1. N $ESTACK,$ETRAP S $ETRAP="D TRAP^XUSBSE2"
  1. K RESULTS
  1. S PAGE=$G(PAGE,"/") I PAGE="" S PAGE="/"
  1. S HTTPTYPE=$G(HTTPTYPE,"GET")
  1. S DATA=$G(DATA),PORT=$G(PORT,80)
  1. D SAVDEV^%ZISUTL("XUSBSE") ;S IO(0)=$P
  1. D INIT^XWBTCPM
  1. D OPEN^XWBTCPM2(SERVER,PORT)
  1. I POP Q "DIDN'T OPEN CONNECTION"
  1. S XWBSBUF=""
  1. U XWBTDEV
  1. D WRITE^XWBRW(HTTPTYPE_" "_PAGE_" HTTP/1.0"_$C(13,10))
  1. I HTTPTYPE="POST" D
  1. . D WRITE^XWBRW("Referer: http://"_$$KSP^XUPARAM("WHERE")_$C(13,10))
  1. . D WRITE^XWBRW("Content-Type: application/x-www-form-urlencoded"_$C(13,10))
  1. . D WRITE^XWBRW("Cache-Control: no-cache"_$C(13,10))
  1. . D WRITE^XWBRW("Content-Length: "_$L(DATA)_$C(13,10,13,10))
  1. . D WRITE^XWBRW(DATA)
  1. D WRITE^XWBRW($C(13,10))
  1. D WBF^XWBRW
  1. S XWBRBUF="",DONE=0,XWBICNT=0
  1. S OVERFLOW=""
  1. S XVALUE=$$DREAD($C(13,10)) I $G(RESULTS(1))'[200 S XVALUE=$P($G(RESULTS(1))," ",2,5)
  1. D CLOSE ;I IO="|TCP|80" U IO D ^%ZISC
  1. I LINEBUF'="" S RESLTCNT=RESLTCNT+1,RESULTS(RESLTCNT)=LINEBUF
  1. I $G(RESULTS(1))[200 F I=1:1 I RESULTS(I)="" S XVALUE=$G(RESULTS(I+1)) Q
  1. Q XVALUE
  1. ;
  1. CLOSE ;
  1. D CLOSE^%ZISTCP,GETDEV^%ZISUTL("XUSBSE") I $L(IO) U IO
  1. Q
  1. ;
  1. DREAD(D,TO) ;Delimiter Read
  1. N R,S,DONE,C,L
  1. ; ZEXCEPT: LINEBUF,OVERFLOW,RESLTCNT,RESULTS,XWBRBUF - NEWed and set in ENTRY
  1. ; ZEXCEPT: XWBDEBUG,XWBTDEV,XWBTIME - XWB global variables
  1. N $ES,$ET S $ET="S DONE=1,$EC="""" Q"
  1. S R="",DONE=0,D=$G(D,$C(13)),C=0
  1. S TO=$S($G(TO)>0:TO,$G(XWBTIME(1))>0:XWBTIME(1),1:60)/2+1
  1. U XWBTDEV
  1. F D Q:DONE
  1. . 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)
  1. . ; I (R[D)!(C>TO) S DONE=1 Q
  1. . I C>TO S DONE=1 Q
  1. . R XWBRBUF:2 S:'$T C=C+1 S:$L(XWBRBUF) C=0
  1. . 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)
  1. . S OVERFLOW=LINEBUF
  1. . I $G(XWBDEBUG)>2,$L(XWBRBUF) D LOG^XWBDLOG($E("rd ("_$L(XWBRBUF)_"): "_XWBRBUF,1,255))
  1. . Q
  1. Q R
  1. ;
  1. TRAP ;
  1. I '(($EC["READ")!($EC["WRITE")) D ^%ZTER
  1. D CLOSE,LOG^XWBDLOG("Error: "_$$EC^%ZOSV):$G(XWBDEBUG),UNWIND^%ZTER
  1. Q
  1. ;
  1. EN(ADDRESS) ; test with input address or 127.0.0.1 if none entered
  1. N RESULTS
  1. D EN1(ADDRESS,.RESULTS)
  1. Q
  1. ;
  1. EN1(ADDRESS,RESULTS,NOHEADERS) ;
  1. N VALUE,PAGE,SERVER,PORT
  1. S NOHEADERS=$G(NOHEADERS,1)
  1. S PAGE="/",SERVER=ADDRESS,PORT=80
  1. I SERVER["/" D
  1. . I SERVER["//" S SERVER=$P(SERVER,"//",2)
  1. . I SERVER["/" S PAGE="/"_$P(SERVER,"/",2,99),SERVER=$P(SERVER,"/")
  1. . I SERVER[":" S PORT=$P(SERVER,":",2),SERVER=$P(SERVER,":")
  1. . Q
  1. S VALUE=$$ENTRY1(.RESULTS,SERVER,PORT,PAGE)
  1. D HOME^%ZIS ;I IO="|TCP|80" U IO D ^%ZISC
  1. ; if NOHEADERS selected (default) remove the headers and first blank line
  1. I NOHEADERS D
  1. . N I,J,X
  1. . ; remove header lines and first blank line
  1. . F I=1:1 Q:'$D(RESULTS(I)) S X=(RESULTS(I)="") K:'X RESULTS(I) I X K RESULTS(I) Q
  1. . ; move lines down to start at 1 again
  1. . 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)
  1. . Q
  1. Q
  1. ;