- 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 Jan 18, 2025@03:13:19 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 ;