Annotation of gforth/netlib/httpclient.fs, revision 1.1

1.1     ! jwilke      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>