File:  [gforth] / gforth / wordlibs / httpclient.fs
Revision 1.1: download - view: text, annotated - select for diffs
Tue Mar 2 15:50:06 1999 UTC (25 years, 1 month ago) by jwilke
Branches: MAIN
CVS tags: v0-7-0, v0-6-2, v0-6-1, v0-6-0, v0-5-0, HEAD
Supports to build up c libraries of forth words in the format used in the
prim file. Worked on linux machines.
On sun linker exits with "fatal signal 6"...

    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>