Annotation of gforth/webform.fs, revision 1.3

1.1       anton       1: \ Webform and CGI handling
                      2: \
1.3     ! anton       3: \ Copyright (C) 2011,2012 Free Software Foundation, Inc.
1.1       anton       4: 
                      5: \ This file is part of Gforth.
                      6: 
                      7: \ Gforth is free software; you can redistribute it and/or
                      8: \ modify it under the terms of the GNU General Public License
                      9: \ as published by the Free Software Foundation, either version 3
                     10: \ of the License, or (at your option) any later version.
                     11: 
                     12: \ This program is distributed in the hope that it will be useful,
                     13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: \ GNU General Public License for more details.
                     16: 
                     17: \ You should have received a copy of the GNU General Public License
                     18: \ along with this program. If not, see http://www.gnu.org/licenses/.
                     19: 
                     20: wordlist constant form-fields
                     21: 
                     22: : cut-string ( c-addr1 u1 c -- c-addr2 u2 c-addr3 u3 )
                     23:     \ cut c-addr1 u1 using separator c; c-addr3 u3 is the part before
                     24:     \ the first separator, c-addr2 u2 the rest.
                     25:     >r 2dup r> scan over >r dup if
                     26:         1 /string \ skip c
                     27:     endif
                     28:     2swap drop r> over - ;
                     29: 
                     30: : hex>u ( c-addr u -- u2 f )
                     31:     \ convert hex string c-addr u into u2; f is true if the conversion
                     32:     \ worked, otherwise it is false and u2 is anything
                     33:     0. 2swap ['] >number $10 base-execute nip nip 0= ;
                     34: 
                     35: 
                     36: \ basic CGI handling
                     37: 
                     38: : type-cgi ( c-addr u -- )
                     39:     begin
                     40:         dup while
                     41:             over c@ case
                     42:                 '% of
                     43:                     dup 3 >= if
                     44:                         over 1+ 2 hex>u if
                     45:                             emit 3
                     46:                         else
                     47:                             drop 1
                     48:                         then
                     49:                     else
                     50:                         1
                     51:                     then
                     52:                 endof
                     53:                 '+ of
                     54:                     space 1 endof
                     55:                 dup emit 1 swap
                     56:             endcase
                     57:             /string
                     58:     repeat
                     59:     2drop ;
                     60: 
                     61: \ s" q=bla%26foo%25%23&test=field2%3Dxy&review=line1%0D%0Aline2%0D%0A" type-cgi
                     62: 
                     63: : cgi-field ( c-addr u -- )
                     64:     \ process a cgi field
                     65:     get-current >r form-fields set-current
                     66:     '= cut-string 2>r ['] type-cgi >string-execute 2r> nextname 2constant
                     67:     r> set-current ;
                     68: 
                     69: : cgi-input ( c-addr u -- )
                     70:     \ process gci input: split into fields, and make the fields words
                     71:     begin
                     72:         '& cut-string dup while
                     73:             cgi-field
                     74:     repeat
                     75:     2drop 2drop ;
1.2       anton      76: 
                     77: s" EOF while scanning HTML" exception constant eof-on-scanning
                     78: 
                     79: : sh-nextline ( u1 -- 0 )
                     80:     \ print the current line, starting at char u1, then switch to next line
                     81:     source rot /string type
                     82:     refill 0= eof-on-scannin throw
                     83:     0 ;
                     84: 
                     85: : scan-html ( -- )
                     86:     \ print the input until a "<forth>" is seen; Comments from <!-- to
                     87:     \ --> are skipped.
                     88:     0 { html-comment? }
                     89:     >in @ begin
                     90:         parse-name dup 0= if \ end-of-line
                     91:             sh-nextline
                     92:         else 2dup s" <forth>" str= html-comment? 0= and if
                     93:                 2drop source drop >in @ 7 - rot /string type exit
                     94:             else 2dup s" <!--" str= if
                     95:                     2drop true to html-comment
                     96:                 else s" -->" str= if
                     97:                         false to html-comment
                     98:                     then
                     99:                 then
                    100:             then
                    101:         then
                    102:     again ;
                    103: 
                    104: : </forth> ( u1 -- xt u2 )
                    105:     ['] scan-html >string-execute ( c-addr u )
                    106:     2>r :noname 2r> ]] 2literal type ; [[ swap 1+ ;
                    107: 
                    108: : >html> ( -- x1 1 )
                    109:     0 </forth> ;
                    110: 
                    111: : <html< ( x1 ... xu u -- )
                    112:     >r :noname
                    113:     r@ dup 0 +do
                    114:          dup 5 + i - pick . compile,
                    115:     loop
                    116:     drop ]] ; [[
                    117:     r> 0 +do
                    118:         nip
                    119:     loop
                    120:     execute ;
                    121: 
                    122: : field-contents ( c-addr1 u1 -- c-addr2 u2 )
                    123:     \ c-addr2 u2 is the CGI input string for field named c-addr1 u1
                    124:     \ c-addr2 u2 is an empty string if the CGI input did not contain the field
                    125:     form-fields search-wordlist if
                    126:         execute
                    127:     else
                    128:         0 0
                    129:     then ;
                    130: 
                    131: variable input-acceptable? \ true if all the fields are acceptable
                    132: 
                    133: : do-textfield { uwidth xt d: name -- }
                    134:     \ print an html text input field with width uwidth and name c-addr u
                    135:     \ check whether the input is satisfactory with xt ( c-addr u -- f )
                    136:     .\" <input type=\"text\" name=\"" string type .\" \" size=\""
                    137:     uwidth 0 .r ." >" name field-contents 2dup type ." </input> "
                    138:     xt execute 0= if input-acceptable? off then ;
                    139: 
                    140: : textfield ( uwidth xt1 "name" -- xt2 )
                    141:     2>r :noname parse-name 2r> ]] 2literal sliteral do-textfield; [[ ;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>