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