2 \ #
! /home
/ygrek
/work
/forth
/spf
/spf4
4 REQUIRE ATTACH ~pinka
/samples
/2005/lib
/append
-file
.f
5 REQUIRE USER
-TYPE ~ygrek
/lib
/typestr
.f
6 \
:NONAME
2DROP
; TO USER
-TYPE \ no stdout
8 REQUIRE XSLTmm ~ac
/lib
/lin
/xml
/xslt
.f
9 REQUIRE XHTML ~ygrek
/lib
/xhtml
/core
.f
10 REQUIRE DumpParams ~ac
/lib
/string
/get_params
.f
11 REQUIRE EQUAL ~pinka
/spf
/string
-equal
.f
12 REQUIRE NOT ~profit
/lib
/logic
.f
13 REQUIRE cat ~ygrek
/lib
/cat
.f
14 REQUIRE ALLOCATED ~pinka
/lib
/ext
/basics
.f
15 REQUIRE NUMBER ~ygrek
/lib
/parse
.f
16 REQUIRE DateTime
>PAD ~ygrek
/lib
/spec
/unixdate
.f
17 REQUIRE FileLines
=> ~ygrek
/lib
/filelines
.f
18 REQUIRE
READ-FILE
-EXACT ~pinka
/lib
/files
-ext
.f
19 \ REQUIRE CREATE
-ANON
-PIPE ~ygrek
/lib
/sys
/pipe
.f
29 S
" /bin/sh" DROP DUP
2 <( S
" -c" DROP R
> 0 )) execlp \ no
return
32 : sys
( a u
-- ) DROP
(sys
) DROP
;
34 : BACKSTRFREE
( s
--> s \
<-- ) PRO BACK STRFREE TRACKING RESTB CONT
;
35 : SEVALUATE BACKSTRFREE STR@ EVALUATE
;
37 : SAPPEND
( s s1
-- s
' ) OVER S+ ;
43 : <page> ( `title -- )
49 << `application/xhtml+xml;charset=utf-8 `content-type http-equiv >>
50 << `title tag ( `title ) TYPE >>
51 \ << `wiki.css link-stylesheet >>
57 : input ( `value `name `type -- ) %[ `type $$ `name $$ `value $$ ]% `input /atag ;
59 : render-edit ( a u -- )
60 \ << `h1 tag S" Nota bene: Editing is disabled ('save
' will ignore your changes)" TYPE >>
61 %[ `POST `method $$ S" " `action $$ ]% `form atag
65 %[ `content `name $$ `25 `rows $$ `80 `cols $$ ]% `textarea atag
69 `save `button `submit input
72 : GetParamInt ( `str -- n ) GetParam NUMBER NOT IF 0 THEN ;
74 20 1024 * CONSTANT limit
78 DUP limit > IF DROP limit S" Input too long, truncated" TYPE CR THEN
79 << `pre tag 2DUP TYPE >>
81 \ (( 0 )) tmpnam ASCIIZ> >STR
82 \ (( 0 )) tmpnam ASCIIZ> >STR
83 (( S" sql" DROP 0x1FF )) mkdir DROP
84 ms@ DUP " sql/{n}.in" SWAP " sql/{n}.out" { src dst }
85 \ src STR@ TYPE CR dst STR@ TYPE CR
87 dst STR@ src STR@ " ./sql2cpp {s} > {s}" STR@ sys
93 S" SQL to C++ code generator" 2DUP <page>
94 << `h1 tag `/p/sql_to_cpp.html link-text >>
95 `content GetParam DUP 0= IF 2DROP S" " render-edit ELSE process THEN
96 \ S" CREATE TABLE x (z INT);" process
102 : content:html S" Content-type: text/html" TYPE CR ;
103 : content:xhtml S" Content-type: application/xhtml+xml" TYPE CR ;
104 : content-length " Content-Length: {n}" STYPE CR ;
106 \ : comment PRO ." <!-- " CONT ." -->" ;
109 S" CONTENT_LENGTH" ENVIRONMENT? NOT IF EXIT THEN
110 NUMBER NOT IF EXIT THEN
111 ALLOCATED 2DUP H-STDIN READ-FILE-EXACT IF 2DROP ELSE GetParamsFromString THEN ;
112 \ ALLOCATED 2DUP H-STDIN READ-FILE . NIP 2DUP TYPE CR GetParamsFromString ;
115 S" QUERY_STRING" ENVIRONMENT? IF GetParamsFromString THEN ;
118 `REQUEST_METHOD ENVIRONMENT? NOT IF EXIT THEN
119 2DUP `POST CEQUAL IF 2DROP get_post_params EXIT THEN
120 2DUP `GET CEQUAL IF 2DROP get_get_params EXIT THEN
123 [UNDEFINED] WINAPI: [IF]
125 S" environ" symbol-lookup symbol-address @
129 DUP @ ASCIIZ> TYPE CR
135 WINAPI: GetEnvironmentStrings KERNEL32.DLL
138 GetEnvironmentStrings
149 : env ENVIRONMENT? NOT IF S" " THEN ;
155 TIME&DATE DateTime>PAD TYPE TAB
156 `REMOTE_ADDR env TYPE TAB
157 `REQUEST_METHOD env TYPE TAB
158 `SCRIPT_NAME env TYPE SPACE
159 `QUERY_STRING env TYPE TAB
160 `HTTP_USER_AGENT env TYPE
161 } TYPE>STR BACKSTRFREE STR@ `request.log ATTACH-LINE-CATCH DROP ;
165 \ S" Cache-Control: no-cache" TYPE CR
176 ['] content TYPE
>STR DUP STRLEN content
-length
181 \
: index headers CR content
;
183 \
: REQUEST_METHOD S
" GET" ;
184 \
: QUERY_STRING S
" page_name=MainPage" ;
186 \
' TYPE1 TO USER-TYPE
188 : save ['] index MAINX
! `sql
.cgi SAVE
;