--- gforth/webform.fs	2011/07/21 17:40:30	1.1
+++ gforth/webform.fs	2012/02/16 17:13:04	1.2
@@ -73,3 +73,69 @@ wordlist constant form-fields
             cgi-field
     repeat
     2drop 2drop ;
+
+s" EOF while scanning HTML" exception constant eof-on-scanning
+
+: sh-nextline ( u1 -- 0 )
+    \ print the current line, starting at char u1, then switch to next line
+    source rot /string type
+    refill 0= eof-on-scannin throw
+    0 ;
+
+: scan-html ( -- )
+    \ print the input until a "<forth>" is seen; Comments from <!-- to
+    \ --> are skipped.
+    0 { html-comment? }
+    >in @ begin
+        parse-name dup 0= if \ end-of-line
+            sh-nextline
+        else 2dup s" <forth>" str= html-comment? 0= and if
+                2drop source drop >in @ 7 - rot /string type exit
+            else 2dup s" <!--" str= if
+                    2drop true to html-comment
+                else s" -->" str= if
+                        false to html-comment
+                    then
+                then
+            then
+        then
+    again ;
+
+: </forth> ( u1 -- xt u2 )
+    ['] scan-html >string-execute ( c-addr u )
+    2>r :noname 2r> ]] 2literal type ; [[ swap 1+ ;
+
+: >html> ( -- x1 1 )
+    0 </forth> ;
+
+: <html< ( x1 ... xu u -- )
+    >r :noname
+    r@ dup 0 +do
+         dup 5 + i - pick . compile,
+    loop
+    drop ]] ; [[
+    r> 0 +do
+        nip
+    loop
+    execute ;
+
+: field-contents ( c-addr1 u1 -- c-addr2 u2 )
+    \ c-addr2 u2 is the CGI input string for field named c-addr1 u1
+    \ c-addr2 u2 is an empty string if the CGI input did not contain the field
+    form-fields search-wordlist if
+        execute
+    else
+        0 0
+    then ;
+
+variable input-acceptable? \ true if all the fields are acceptable
+
+: do-textfield { uwidth xt d: name -- }
+    \ print an html text input field with width uwidth and name c-addr u
+    \ check whether the input is satisfactory with xt ( c-addr u -- f )
+    .\" <input type=\"text\" name=\"" string type .\" \" size=\""
+    uwidth 0 .r ." >" name field-contents 2dup type ." </input> "
+    xt execute 0= if input-acceptable? off then ;
+
+: textfield ( uwidth xt1 "name" -- xt2 )
+    2>r :noname parse-name 2r> ]] 2literal sliteral do-textfield; [[ ;