Annotation of gforth/webform.fs, revision 1.2
1.1 anton 1: \ Webform and CGI handling
2: \
3: \ Copyright (C) 2011 Free Software Foundation, Inc.
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>