1: \ Webform and CGI handling
2: \
3: \ Copyright (C) 2011,2012 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 ;
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>