Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.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 ; | ||
| 76 : | anton | 1.2 | |
| 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; [[ ; |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |