Annotation of gforth/wordlibs/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: 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>