1: #! /usr/local/bin/gforth031
2:
3: \ make our directory the search directory
4: \ sourcefilename extractpath fpath only-path
5:
6: decimal
7:
8: require ./../wordlibs/unixlib.fs
9: require ./netlib.fs
10: \ require jflib/tools/fieldscan.fs
11:
12: : usage
13: ." httpclient.fs [ -p port ] [ -t timeout ] [ -s ] [ -r ] [ -b filename ] [ -e filename ]" cr
14: ." -h host resource-name" cr
15: ." Options:" cr
16: ." -p N Set portnumber to N (default is 80)" cr
17: ." -t N Set timeout to N (default is no timeout)" cr
18: ." -b name Save body (data) of response to file named name" cr
19: ." -e name Save header of response to file name" cr
20: ." -h host set host to host (dault is localhost)" cr
21: ." -r make an report" cr
22: ." -s silent operation, don't view requested data" cr
23: bye
24: ;
25:
26: Create hostname ," localhost" 300 chars allot
27: Variable port 80 port !
28: Variable timeout 0 timeout !
29: Variable silent-flag silent-flag off
30: Variable result-flag result-flag off
31:
32: Create crlf 13 c, 10 c, 13 c, 10 c,
33: Create wbuffer 300 chars allot
34: Create rbuffer 1000 chars allot
35:
36: Variable Headerbytes 0 Headerbytes !
37: Variable Databytes 0 Databytes !
38: Variable StatusCode
39: Create Protocol 100 chars allot
40: Create ReasonPhrase 100 chars allot
41: 0 Value header-fd
42: 0 Value data-fd
43:
44: : .args
45: argc @ 0 DO
46: ." arg " i . ." : " i arg type cr
47: LOOP ;
48:
49: 0 Value optind
50:
51: : end? ( -- flag)
52: optind argc @ u>= ;
53:
54: : arg? ( -- adr len )
55: \G get next argument
56: end? ABORT" too few arguments!"
57: optind arg
58: 1 optind + to optind ;
59:
60: : scanarg
61: 2 to optind
62: end? IF usage THEN
63: BEGIN end? 0=
64: WHILE optind arg
65: IF c@ [char] - =
66: IF
67: optind arg
68: 1 optind + to optind
69: forth-wordlist search-wordlist
70: 0= ABORT" wrong option!"
71: execute -1
72: ELSE false
73: THEN
74: ELSE true
75: THEN
76: WHILE
77: REPEAT THEN
78: ;
79:
80: : -? usage ;
81: : -h arg? hostname place ;
82: : -p 0.0 arg? >number 2drop d>s port ! ;
83: : -t 0.0 arg? >number 2drop d>s port ! ;
84: : -s silent-flag on ;
85: : -r result-flag on ;
86: : -b arg? r/w bin create-file throw to data-fd ;
87: : -e arg? r/w bin create-file throw to header-fd ;
88:
89: : fd-readline ( adr len fd -- u ior )
90: >r over + r> { startadr endadr fd }
91: startadr
92: BEGIN
93: dup 1 fd uread
94: ?dup IF nip startadr - EXIT THEN
95: IF dup c@
96: CASE 10 OF startadr - 0 EXIT ENDOF
97: 13 OF ENDOF
98: dup OF char+ ENDOF
99: ENDCASE
100: THEN
101: dup endadr =
102: UNTIL
103: startadr - 0 ;
104:
105: : fieldscan ( adr len c -- adr2 len2 adr3 len3 )
106: >r 2dup r> scan { ia il ra rl }
107: ra rl dup IF -1 /string THEN
108: ia ra ia - ;
109:
110: : http-header ( sd -- ior ) { sd }
111: break:
112: \ read 1st line
113: rbuffer 1000 sd fd-readline ?dup ?EXIT
114: rbuffer swap
115: bl fieldscan 100 min Protocol place
116: bl fieldscan 0 -rot 0 -rot >number 2drop d>s StatusCode !
117: bl fieldscan 100 min ReasonPhrase place
118: 2drop
119:
120: \ read until empty line
121: BEGIN rbuffer 1000 sd fd-readline ?dup IF nip EXIT THEN
122: dup
123: WHILE dup 2 + HeaderBytes +!
124: rbuffer swap
125: silent-flag @ 0= IF 2dup type cr THEN
126: header-fd IF header-fd write-line drop ELSE 2drop THEN
127: REPEAT
128: silent-flag @ 0= IF cr THEN
129: ;
130:
131: : http-body ( sd -- ior ) { sd }
132: BEGIN rbuffer 200 sd uread -39 <>
133: WHILE dup DataBytes +!
134: rbuffer swap
135: silent-flag @ 0= IF 2dup type cr THEN
136: data-fd IF data-fd write-file drop ELSE 2drop THEN
137: REPEAT 0 ;
138:
139: : http-data ( sd -- ior ) { sd }
140: sd http-header ?dup ?EXIT
141: sd http-body ;
142:
143: : main
144: end? ABORT" no file specified!"
145: timeout @ ?dup IF alarm THEN
146: hostname count port @ connect-tcp-name { sd }
147: s" GET " wbuffer place
148: optind arg wbuffer +place
149: s" HTTP/1.0" wbuffer +place
150: crlf 4 wbuffer +place
151: \ crlf char+ 1 wbuffer +place
152: \ crlf char+ 1 wbuffer +place
153: \ crlf 4 wbuffer +place
154: \ wbuffer count type cr
155: break:
156: wbuffer count sd uwrite throw drop
157: sd http-data drop
158: sd uclose throw
159: result-flag @
160: IF
161: ." returnstatus=okay" cr
162: ." statuscode=" StatusCode @ 0 u.r cr
163: ." reasonphrase=" [char] " emit ReasonPhrase count type [char] " emit cr
164: ." headerbytes=" HeaderBytes @ 0 u.r cr
165: ." databytes=" DataBytes @ 0 u.r cr
166: THEN
167: header-fd ?dup IF close-file throw THEN
168: data-fd ?dup IF close-file throw THEN ;
169:
170: : (DoError2) ( throw-code -- )
171: Result-Flag @
172: IF ." returnstatus=failed" cr THEN
173: outfile-id dup flush-file drop >r
174: stderr to outfile-id
175: dup -2 =
176: IF
177: "error @ ?dup
178: IF
179: cr count type
180: THEN
181: drop
182: ELSE
183: .error
184: THEN
185: normal-dp dpp !
186: r> to outfile-id ;
187:
188: ' (DoError2) IS DoError
189: scanarg
190: main
191:
192: bye
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>