Return to webform.fs CVS log

Up to [gforth] / gforth

updated copyright year

    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; [[ ;