source: WorldVistAEHR/trunk/r/ONCOLOGY-ONC/ONCX10A.m@ 1667

Last change on this file since 1667 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 7.0 KB
Line 
1ONCX10A ;HCIOFO/SG - HTTP 1.0 CLIENT (TOOLS) ; 8/11/04 8:26am
2 ;;2.11;ONCOLOGY;**40,41**;Mar 07, 1995
3 ;
4 Q
5 ;
6 ;***** APPENDS RECEIVED PIECE OF DATA TO THE DESTINATION BUFFER
7 ;
8 ; BUF Received data
9 ;
10 ; [NEWLINE] Start a new line after appending the data
11 ;
12 ; The ONC8BUF, ONC8DST, ONC8IS, ONC8MBL, ONC8PTR, and ONC8SL
13 ; variables must be properly initialized before calling this
14 ; procedure (see the $$RECEIVE^ONCX10A for details).
15 ;
16APPEND(BUF,NEWLINE) ;
17 N BASE,L
18 S L=$L(BUF) S:$A(BUF,L)=13 L=L-1
19 ;--- Append the data
20 I L'<ONC8SL D
21 . S ONC8BUF=ONC8BUF_$E(BUF,1,ONC8SL),L=L-ONC8SL
22 . S BASE=1
23 . F D Q:L'>0
24 . . I 'ONC8IS S @ONC8DST@(ONC8PTR)=ONC8BUF
25 . . E S @ONC8DST@(ONC8PTR,ONC8IS)=ONC8BUF
26 . . S BASE=BASE+ONC8SL,ONC8IS=ONC8IS+1,ONC8SL=ONC8MBL
27 . . S ONC8BUF=$E(BUF,BASE,BASE+ONC8SL-1),L=L-ONC8SL
28 . S ONC8SL=-L
29 E S ONC8BUF=ONC8BUF_$E(BUF,1,L),ONC8SL=ONC8SL-L
30 ;--- Flush the buffer and start a new line
31 I $G(NEWLINE) D S ONC8BUF="",ONC8IS=0,ONC8PTR=ONC8PTR+1,ONC8SL=ONC8MBL
32 . I 'ONC8IS S @ONC8DST@(ONC8PTR)=ONC8BUF Q
33 . S @ONC8DST@(ONC8PTR,ONC8IS)=ONC8BUF
34 Q
35 ;
36 ;***** CALCULATES NUMBER OF BYTES IN THE MESSAGE BODY
37 ;
38 ; ONC8DATA Closed root of a variable containing body
39 ; of the message
40 ;
41 ; NLS Length of the line terminator(s)
42 ;
43DATASIZE(ONC8DATA,NLS) ;
44 N SIZE
45 S SIZE=0
46 F S I=$O(@ONC8DATA@(I)) Q:I="" D S SIZE=SIZE+NLS
47 . S SIZE=SIZE+$L($G(@ONC8DATA@(I)))
48 . S J=""
49 . F S J=$O(@ONC8DATA@(I,J)) Q:J="" D
50 . . S SIZE=SIZE+$L($G(@ONC8DATA@(I,J)))
51 Q $S(SIZE>0:SIZE-NLS,1:0)
52 ;
53 ;***** PROCESSES THE HTTP HEADER
54 ;
55 ; .ONC8H Reference to a local array containing
56 ; the raw header data
57 ;
58 ; .ONC8HDR Reference to a local variable where the parsed
59 ; header will be returned
60 ;
61 ; Return values:
62 ; <0 Error Descriptor
63 ; >0 HTTP Status Code^Description
64 ;
65HEADER(ONC8H,ONC8HDR) ;
66 N BUF,I,NAME,TAB,TMP
67 S ONC8HDR=$$NORMSTAT($G(ONC8H(1))),TAB=$C(9)
68 F I=2:1 S BUF=$TR($G(ONC8H(I)),TAB," ") Q:BUF="" D
69 . ;--- Continuation of the previous header line
70 . I $E(BUF,1)=" " D:$G(NAME)'="" Q
71 . . S TMP=$$TRIM^XLFSTR(BUF)
72 . . S:TMP'="" ONC8HDR(NAME)=ONC8HDR(NAME)_" "_TMP
73 . ;--- New header line
74 . S NAME=$$UP^XLFSTR($$TRIM^XLFSTR($P(BUF,":")))
75 . S:NAME'="" ONC8HDR(NAME)=$$TRIM^XLFSTR($P(BUF,":",2,999))
76 Q $P(ONC8HDR," ",2)_U_$P(ONC8HDR," ",3,999)
77 ;
78 ;***** NORMALIZES THE HTTP STATUS LINE
79NORMSTAT(STATUS) ;
80 N I,J1,J2,TMP
81 ;--- Remove leading and trailing spaces
82 S STATUS=$$TRIM^XLFSTR(STATUS)
83 ;--- Replace groups of consecutive spaces with single spaces
84 S J2=1
85 F I=1,2 D Q:'J1
86 . S J1=$F(STATUS," ",J2) Q:'J1
87 . F J2=J1:1 Q:$E(STATUS,J2)'=" "
88 . S $E(STATUS,J1,J2-1)=""
89 ;--- Return normalized status line
90 Q STATUS
91 ;
92 ;***** RECEIVES AN HTTP RESPONSE
93 ;
94 ; TIMEOUT Timeout value (in seconds) for TCPIP input.
95 ;
96 ; [ONC8DATA] Closed root of the variable where the message
97 ; body is returned. See the $$GETURL^ONCX10
98 ; for details.
99 ;
100 ; [.ONC8HDR] Reference to a local variable where the parsed
101 ; headers will be returned. See the $$GETURL^ONCX10
102 ; for details.
103 ;
104RECEIVE(TIMEOUT,ONC8DATA,ONC8HDR) ;
105 ; ONC8BUF Work buffer where the current line is being built
106 ; ONC8DST Closed root of the current destination buffer used
107 ; by the APPEND^ONCX10A
108 ; ONC8H Temporary buffer for the raw HTTP header
109 ; ONC8IS Subscript of the current continuation sub-node in
110 ; the destination buffer (if 0 then the current main
111 ; node is used)
112 ; ONC8MBL Maximum buffer length
113 ; ONC8PTR Subscript of the current node in the dest. buffer
114 ; ONC8SL Number of available bytes in the current (sub)node
115 ;
116 N $ESTACK,$ETRAP,BLCHS,BUF,EXIT,I1,I2,MBL,ONC8BUF,ONC8DST,ONC8H,ONC8IS,ONC8MBL,ONC8PTR,ONC8SL,RTO,STATUS,TMP,X
117 S BLCHS=$C(9,10,12,13)_" ",ONC8MBL=245
118 K:$G(ONC8DATA)'="" @ONC8DATA K ONC8HDR
119 S ONC8BUF="",ONC8IS=0,ONC8PTR=1,ONC8SL=ONC8MBL
120 ;--- Setup the error processing
121 S X="RCVERR^ONCX10A",@^%ZOSF("TRAP"),$ETRAP=""
122 ;--- Receive the header (until the first empty line)
123 U IO
124 S ONC8DST="ONC8H",(EXIT,RTO)=0
125 F R BUF#ONC8MBL:TIMEOUT S RTO='$T D Q:EXIT!RTO
126 . S I1=1
127 . F S I2=$F(BUF,$C(10),I1) Q:'I2 D Q:EXIT
128 . . S TMP=$E(BUF,I1,I2-2) D APPEND(TMP,1) S I1=I2
129 . . S:$TR(TMP,BLCHS)="" EXIT=1
130 . D:'EXIT APPEND($E(BUF,I1,ONC8MBL))
131 ;--- A header must end with an empty line.
132 ;--- Otherwise, there was a timeout.
133 Q:'EXIT $$ERROR^ONCXERR(-7)
134 ;--- Remove ending of the header from the buffer. The buffer
135 ;--- can contain beginning of the message body.
136 S:I1>1 $E(BUF,1,I1-1)=""
137 ;--- Process the header
138 S STATUS=$$HEADER(.ONC8H,.ONC8HDR)
139 ;--- Receive the message body
140 D:$G(ONC8DATA)'=""
141 . N CNTLEN,RDLEN
142 . S RDLEN=ONC8MBL
143 . ;--- Check for Content-Length header
144 . I $D(ONC8HDR("CONTENT-LENGTH")) D Q:CNTLEN'>0
145 . . S CNTLEN=+ONC8HDR("CONTENT-LENGTH")
146 . . S:CNTLEN<ONC8MBL RDLEN=CNTLEN
147 . E S CNTLEN=-1
148 . ;--- Read the content
149 . S ONC8DST=ONC8DATA,RTO=0
150 . F D Q:'CNTLEN!RTO R BUF#RDLEN:TIMEOUT S RTO='$T
151 . . D:CNTLEN>0
152 . . . S CNTLEN=CNTLEN-$L(BUF) S:CNTLEN<0 CNTLEN=0
153 . . . S:CNTLEN<RDLEN RDLEN=CNTLEN
154 . . S I1=1
155 . . F S I2=$F(BUF,$C(10),I1) Q:'I2 D
156 . . . D APPEND($E(BUF,I1,I2-2),1) S I1=I2
157 . . D APPEND($E(BUF,I1,ONC8MBL))
158 ;--- Flush the buffers and process the header (only if necessary)
159RCVERR U $P
160 D APPEND("",1)
161 S:$G(STATUS)="" STATUS=$$HEADER(.ONC8H,.ONC8HDR)
162 Q STATUS
163 ;
164 ;***** SENDS THE HTTP REQUEST
165 ;
166 ; URI Request URI
167 ;
168 ; [ONC8DATA] Closed root of a variable containing body of the
169 ; request message. If this parameter is defined, not
170 ; empty, and the referenced variable is defined then
171 ; the POST request is generated. Otherwise, the GET
172 ; request is sent.
173 ;
174 ; [.ONC8HDR] Reference to a local variable containing header
175 ; values
176 ;
177 ; Return values:
178 ; <0 Error Code^Description
179 ; "GET" Ok
180 ; "POST" Ok
181 ;
182REQUEST(URI,ONC8DATA,ONC8HDR) ;
183 N CRLF,DFLTHDR,I,J,STATUS
184 S CRLF=$C(13,10)
185 ;--- Check for default header(s)
186 S DFLTHDR("CONTENT-LENGTH")=""
187 S DFLTHDR("CONTENT-TYPE")=""
188 S DFLTHDR("USER-AGENT")=""
189 S I=""
190 F S I=$O(ONC8HDR(I)) Q:I="" K DFLTHDR($$UP^XLFSTR(I))
191 S:$D(DFLTHDR("USER-AGENT")) ONC8HDR("User-Agent")="VistA/1.0"
192 ;--- Send the request
193 U IO
194 I $G(ONC8DATA)'="",$D(@ONC8DATA)>1 S STATUS="POST" D
195 . S:$D(DFLTHDR("CONTENT-TYPE")) ONC8HDR("Content-Type")="text/html"
196 . D:$D(DFLTHDR("CONTENT-LENGTH"))
197 . . S ONC8HDR("Content-Length")=$$DATASIZE(ONC8DATA,$L(CRLF))
198 . W "POST "_URI_" HTTP/1.0",CRLF,!
199 . ;--- Header
200 . S I=""
201 . F S I=$O(ONC8HDR(I)) Q:I="" W I_": "_ONC8HDR(I),CRLF,!
202 . ;--- Body
203 . S I=""
204 . F S I=$O(@ONC8DATA@(I)) Q:I="" D
205 . . W CRLF,$G(@ONC8DATA@(I)),!
206 . . S J=""
207 . . F S J=$O(@ONC8DATA@(I,J)) Q:J="" W $G(@ONC8DATA@(I,J)),!
208 E S STATUS="GET" D
209 . W "GET "_URI_" HTTP/1.0",CRLF,!
210 . S I=""
211 . F S I=$O(ONC8HDR(I)) Q:I="" W I_": "_ONC8HDR(I),CRLF,!
212 . W CRLF,!
213 U $P
214 Q STATUS
Note: See TracBrowser for help on using the repository browser.