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

XTHC10A.m

Go to the documentation of this file. 
  1. XTHC10A ;HCIOFO/SG - HTTP 1.0 CLIENT (TOOLS) ;12/07/09  16:05
  1.  ;;7.3;TOOLKIT;**123**;Apr 25, 1995;Build 5
  1.  ;
  1.  Q
  1.  ;
  1.  ;+++++ APPENDS RECEIVED PIECE OF DATA TO THE DESTINATION BUFFER
  1.  ;
  1.  ; BUF           Received data
  1.  ;
  1.  ; [NEWLINE]     Start a new line after appending the data
  1.  ;
  1.  ; The XT8BUF, XT8DST, XT8IS, XT8MBL, XT8PTR, and XT8SL
  1.  ; variables must be properly initialized before calling this
  1.  ; procedure (see the $$RECEIVE^XTHC10A for details).
  1.  ;
  1. APPEND(BUF,NEWLINE) ;
  1.  N BASE,L
  1.  S L=$L(BUF)  S:$A(BUF,L)=13 L=L-1
  1.  ;--- Append the data
  1.  I L'<XT8SL  D
  1.  . S XT8BUF=XT8BUF_$E(BUF,1,XT8SL),L=L-XT8SL
  1.  . S BASE=1
  1.  . F  D  Q:L'>0
  1.  . . I 'XT8IS  S @XT8DST@(XT8PTR)=XT8BUF
  1.  . . E  S @XT8DST@(XT8PTR,XT8IS)=XT8BUF
  1.  . . S BASE=BASE+XT8SL,XT8IS=XT8IS+1,XT8SL=XT8MBL
  1.  . . S XT8BUF=$E(BUF,BASE,BASE+XT8SL-1),L=L-XT8SL
  1.  . S XT8SL=-L
  1.  E  S XT8BUF=XT8BUF_$E(BUF,1,L),XT8SL=XT8SL-L
  1.  ;--- Flush the buffer and start a new line
  1.  I $G(NEWLINE)  D  S XT8BUF="",XT8IS=0,XT8PTR=XT8PTR+1,XT8SL=XT8MBL
  1.  . I 'XT8IS  S @XT8DST@(XT8PTR)=XT8BUF  Q
  1.  . S @XT8DST@(XT8PTR,XT8IS)=XT8BUF
  1.  Q
  1.  ;
  1.  ;+++++ CALCULATES NUMBER OF BYTES IN THE MESSAGE BODY
  1.  ;
  1.  ; XT8DATA       Closed root of a variable containing body
  1.  ;               of the message
  1.  ;
  1.  ; NLS           Length of the line terminator(s)
  1.  ;
  1. DATASIZE(XT8DATA,NLS) ;
  1.  N I,J,SIZE
  1.  S SIZE=0,I=""
  1.  F  S I=$O(@XT8DATA@(I))  Q:I=""  D  S SIZE=SIZE+NLS
  1.  . S SIZE=SIZE+$L($G(@XT8DATA@(I)))
  1.  . S J=""
  1.  . F  S J=$O(@XT8DATA@(I,J))  Q:J=""  D
  1.  . . S SIZE=SIZE+$L($G(@XT8DATA@(I,J)))
  1.  Q $S(SIZE>0:SIZE-NLS,1:0)
  1.  ;
  1.  ;+++++ PROCESSES THE HTTP HEADER
  1.  ;
  1.  ; .XT8H         Reference to a local array containing
  1.  ;               the raw header data
  1.  ;
  1.  ; .XT8HDR       Reference to a local variable where the parsed
  1.  ;               header will be returned
  1.  ;
  1.  ; Return values:
  1.  ;           <0  Error Descriptor (see the $$ERROR^XTERROR)
  1.  ;           >0  HTTP Status Code^Description
  1.  ;
  1.  N BUF,I,NAME,TAB,TMP
  1.  S XT8HDR=$$NORMSTAT($G(XT8H(1))),TAB=$C(9)
  1.  F I=2:1  S BUF=$TR($G(XT8H(I)),TAB," ")  Q:BUF=""  D
  1.  . ;--- Continuation of the previous header line
  1.  . I $E(BUF,1)=" "  D:$G(NAME)'=""  Q
  1.  . . S TMP=$$TRIM^XLFSTR(BUF)
  1.  . . S:TMP'="" XT8HDR(NAME)=XT8HDR(NAME)_" "_TMP
  1.  . ;--- New header line
  1.  . S NAME=$$UP^XLFSTR($$TRIM^XLFSTR($P(BUF,":")))
  1.  . S:NAME'="" XT8HDR(NAME)=$$TRIM^XLFSTR($P(BUF,":",2,999))
  1.  Q $P(XT8HDR," ",2)_U_$P(XT8HDR," ",3,999)
  1.  ;
  1.  ;+++++ NORMALIZES THE HTTP STATUS LINE
  1. NORMSTAT(STATUS) ;
  1.  N I,J1,J2,TMP
  1.  ;--- Remove leading and trailing spaces
  1.  S STATUS=$$TRIM^XLFSTR(STATUS)
  1.  ;--- Replace groups of consecutive spaces with single spaces
  1.  S J2=1
  1.  F I=1,2  D  Q:'J1
  1.  . S J1=$F(STATUS," ",J2)  Q:'J1
  1.  . F J2=J1:1  Q:$E(STATUS,J2)'=" "
  1.  . S $E(STATUS,J1,J2-1)=""
  1.  ;--- Return normalized status line
  1.  Q STATUS
  1.  ;
  1.  ;+++++ RECEIVES AN HTTP RESPONSE
  1.  ;
  1.  ; TIMEOUT       Timeout value (in seconds) for TCP/IP input.
  1.  ;
  1.  ; [XT8DATA]     Closed root of the variable where the message
  1.  ;               body is returned. See the $$GETURL^XTHC10
  1.  ;               for details.
  1.  ;
  1.  ; [.XT8HDR]     Reference to a local variable where the parsed
  1.  ;               headers will be returned. See the $$GETURL^XTHC10
  1.  ;               for details.
  1.  ;
  1. RECEIVE(TIMEOUT,XT8DATA,XT8HDR) ;
  1.  ;
  1.  ; XT8BUF        Work buffer where the current line is being built
  1.  ;
  1.  ; XT8DST        Closed root of the current destination buffer used
  1.  ;               by the APPEND^XTHC10A
  1.  ;
  1.  ; XT8H          Temporary buffer for the raw HTTP header
  1.  ;
  1.  ; XT8IS         Subscript of the current continuation sub-node in
  1.  ;               the destination buffer (if 0 then the current main
  1.  ;               node is used)
  1.  ;
  1.  ; XT8MBL        Maximum buffer length
  1.  ;
  1.  ; XT8PTR        Subscript of the current node in the dest. buffer
  1.  ;
  1.  ; XT8SL         Number of available bytes in the current (sub)node
  1.  ;
  1.  N $ESTACK,$ETRAP,BLCHS,BUF,EXIT,I1,I2,MBL,RTO,STATUS,TMP,X,XT8BUF,XT8DST,XT8H,XT8IS,XT8MBL,XT8PTR,XT8SL
  1.  S BLCHS=$C(9,10,12,13)_" ",XT8MBL=245
  1.  K:$G(XT8DATA)'="" @XT8DATA  K XT8HDR
  1.  S XT8BUF="",XT8IS=0,XT8PTR=1,XT8SL=XT8MBL
  1.  ;
  1.  ;=== Setup the error processing
  1.  ;S X="RCVERR^XTHC10A",@^%ZOSF("TRAP"),$ETRAP=""
  1.  S $ET="D RCVERR^XTHC10A"
  1.  ;
  1.  ;=== Receive the header (until the first empty line)
  1.  U IO
  1.  S XT8DST="XT8H",(EXIT,RTO)=0
  1.  ;F  R BUF#XT8MBL:TIMEOUT  S RTO='$T  D  Q:EXIT!RTO
  1.  F  R BUF#XT8MBL:TIMEOUT  S RTO='$T  D  Q:EXIT!RTO
  1.  . S I1=1
  1.  . F  S I2=$F(BUF,$C(10),I1)  Q:'I2  D  Q:EXIT
  1.  . . S TMP=$E(BUF,I1,I2-2)  D APPEND(TMP,1)  S I1=I2
  1.  . . S:$TR(TMP,BLCHS)="" EXIT=1
  1.  . D:'EXIT APPEND($E(BUF,I1,XT8MBL))
  1.  ;--- A header must end with an empty line.
  1.  ;--- Otherwise, there was a timeout.
  1.  Q:'EXIT $$ERROR^XTHC10(-7)
  1.  ;--- Remove ending of the header from the buffer. The buffer
  1.  ;--- can contain beginning of the message body.
  1.  S:I1>1 $E(BUF,1,I1-1)=""
  1.  ;--- Process the header
  1.  S STATUS=$$HEADER(.XT8H,.XT8HDR)
  1.  ;
  1.  ;=== Receive the message body
  1.  D:$G(XT8DATA)'=""
  1.  . N CNTLEN,RDLEN
  1.  . S RDLEN=XT8MBL
  1.  . ;--- Check for Content-Length header
  1.  . I $D(XT8HDR("CONTENT-LENGTH"))  D  Q:CNTLEN'>0
  1.  . . S CNTLEN=+XT8HDR("CONTENT-LENGTH")
  1.  . . S:CNTLEN<XT8MBL RDLEN=CNTLEN
  1.  . E  S CNTLEN=-1
  1.  . ;--- Read the content
  1.  . S XT8DST=XT8DATA,RTO=0
  1.  . F  D  Q:'CNTLEN!RTO  R BUF#RDLEN:TIMEOUT  S RTO='$T
  1.  . . D:CNTLEN>0
  1.  . . . S CNTLEN=CNTLEN-$L(BUF)  S:CNTLEN<0 CNTLEN=0
  1.  . . . S:CNTLEN<RDLEN RDLEN=CNTLEN
  1.  . . S I1=1
  1.  . . F  S I2=$F(BUF,$C(10),I1)  Q:'I2  D
  1.  . . . D APPEND($E(BUF,I1,I2-2),1)  S I1=I2
  1.  . . D APPEND($E(BUF,I1,XT8MBL))
  1.  ;
  1.  ;=== Flush the buffers and process the header (only if necessary)
  1. RCVERR U IO(0)
  1.  D APPEND("",1)
  1.  S:$G(STATUS)="" STATUS=$$HEADER(.XT8H,.XT8HDR)
  1.  I $L($EC) S $ECODE="" S $ETRAP="D UNW^%ZTER Q:$QUIT STATUS Q  " S $ECODE=",U1,"
  1.  Q STATUS
  1.  ;
  1.  ;
  1.  ;+++++ SENDS THE HTTP REQUEST
  1.  ;
  1.  ; URI           Request URI
  1.  ;
  1.  ; [XT8DATA]     Closed root of a variable containing body of the
  1.  ;               request message. If this parameter is defined, not
  1.  ;               empty, and the referenced variable is defined then
  1.  ;               the POST request is generated. Otherwise, the GET
  1.  ;               request is sent.
  1.  ;
  1.  ; [.XT8HDR]     Reference to a local variable containing header
  1.  ;               values
  1.  ;
  1.  ; Return values:
  1.  ;           <0  Error Code^Description
  1.  ;        "GET"  Ok
  1.  ;       "POST"  Ok
  1.  ;
  1. REQUEST(URI,XT8DATA,XT8HDR) ;
  1.  N CRLF,DFLTHDR,I,J,STATUS
  1.  S CRLF=$C(13,10)
  1.  ;
  1.  ;=== Check for default header(s)
  1.  S DFLTHDR("CONTENT-LENGTH")=""
  1.  S DFLTHDR("CONTENT-TYPE")=""
  1.  S DFLTHDR("USER-AGENT")=""
  1.  S I=""
  1.  F  S I=$O(XT8HDR(I))  Q:I=""  K DFLTHDR($$UP^XLFSTR(I))
  1.  S:$D(DFLTHDR("USER-AGENT")) XT8HDR("User-Agent")="VistA/1.0"
  1.  ;
  1.  ;=== Send the request
  1.  U IO
  1.  I $G(XT8DATA)'="",$D(@XT8DATA)>1  S STATUS="POST"  D
  1.  . S:$D(DFLTHDR("CONTENT-TYPE")) XT8HDR("Content-Type")="text/html"
  1.  . D:$D(DFLTHDR("CONTENT-LENGTH"))
  1.  . . S XT8HDR("Content-Length")=$$DATASIZE(XT8DATA,$L(CRLF))
  1.  . W "POST "_URI_" HTTP/1.0",CRLF,!
  1.  . ;--- Header
  1.  . S I=""
  1.  . F  S I=$O(XT8HDR(I))  Q:I=""  W I_": "_XT8HDR(I),CRLF,!
  1.  . ;--- Body
  1.  . S I=""
  1.  . F  S I=$O(@XT8DATA@(I))  Q:I=""  D
  1.  . . W CRLF,$G(@XT8DATA@(I)),!
  1.  . . S J=""
  1.  . . F  S J=$O(@XT8DATA@(I,J))  Q:J=""  W $G(@XT8DATA@(I,J)),!
  1.  E  S STATUS="GET"  D
  1.  . W "GET "_URI_" HTTP/1.0",CRLF,!
  1.  . S I=""
  1.  . F  S I=$O(XT8HDR(I))  Q:I=""  W I_": "_XT8HDR(I),CRLF,!
  1.  . W CRLF,!
  1.  ;U $P
  1.  Q STATUS