File:  [gforth] / gforth / netlib / httpclient.fs
Revision 1.1: download - view: text, annotated - select for diffs
Mon May 17 13:29:56 1999 UTC (24 years, 10 months ago) by jwilke
Branches: MAIN
CVS tags: v0-7-0, v0-6-2, v0-6-1, v0-6-0, v0-5-0, HEAD
Moved netlib stuff to extra directory, because I need a configure
script for it.

    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>