minor
[sqlgg.git] / cgi.f
blob5d61ebf960f1dedab82d146223da9a24d4c2ed65
1 #! /usr/bin/spf4
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
21 : (sys) ( az -- x )
22 (()) fork ?DUP
24 NIP
25 1 <( 0 0 )) waitpid
26 ELSE
27 \ FIXME
29 S" /bin/sh" DROP DUP 2 <( S" -c" DROP R> 0 )) execlp \ no return
30 THEN ;
32 : sys ( a u -- ) DROP (sys) DROP ;
34 : BACKSTRFREE ( s --> s \ <-- ) PRO BACK STRFREE TRACKING RESTB CONT ;
35 : SEVALUATE BACKSTRFREE STR@ EVALUATE ;
36 \ append s1 to s
37 : SAPPEND ( s s1 -- s' ) OVER S+ ;
39 ALSO XMLSAFE
40 ALSO XHTML
42 \ Every page
43 : <page> ( `title -- )
44 PRO
45 xml-declaration
46 doctype-strict
47 xhtml
48 << `head tag
49 << `application/xhtml+xml;charset=utf-8 `content-type http-equiv >>
50 << `title tag ( `title ) TYPE >>
51 \ << `wiki.css link-stylesheet >>
54 `body tag
55 CONT ;
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
62 `div tag
65 %[ `content `name $$ `25 `rows $$ `80 `cols $$ ]% `textarea atag
66 ( a u ) TYPE
69 `save `button `submit input
72 : GetParamInt ( `str -- n ) GetParam NUMBER NOT IF 0 THEN ;
74 20 1024 * CONSTANT limit
76 : process ( a u -- )
77 `p tag
78 << `h2 tag S" Input" TYPE >>
79 DUP limit > IF DROP limit S" Input too long, truncated" TYPE CR THEN
80 << `pre tag 2DUP TYPE >>
81 hrule
82 (( S" sql" DROP 0x1FF )) mkdir DROP
83 ms@ { tick | src dst err }
84 tick " sql/{n}.in" -> src
85 tick " sql/{n}.out" -> dst
86 tick " sql/{n}.err" -> err
87 \ src STR@ TYPE CR dst STR@ TYPE CR err STR@ TYPE CR
88 src STR@ OCCUPY
89 err STR@ dst STR@ src STR@ " ./sqlgg.native {s} > {s} 2> {s}" STR@ sys
90 dst STR@ FILE
91 << `h2 tag S" Output" TYPE >>
92 << `pre tag TYPE >>
93 hrule
94 err STR@ FILE DUP 0= IF 2DROP EXIT THEN
95 << `h2 tag S" Errors" TYPE >>
96 << `pre tag TYPE >>
97 hrule
100 : ask-input
101 << `p tag
102 S" Input SQL statements terminated with semicolon (;) each. " TYPE
103 S" Use ? or @name for binding slots" TYPE
105 S" " render-edit ;
107 : main ( -- )
108 S" SQL to C++ code generator" 2DUP <page>
109 << `h1 tag `/p/sqlgg.html link-text >>
110 `content GetParam DUP 0= IF 2DROP ask-input ELSE process THEN
111 \ S" CREATE TABLE x (z INT);" process
114 PREVIOUS
115 PREVIOUS
117 : content:html S" Content-type: text/html" TYPE CR ;
118 : content:xhtml S" Content-type: application/xhtml+xml" TYPE CR ;
119 : content-length " Content-Length: {n}" STYPE CR ;
121 \ : comment PRO ." <!-- " CONT ." -->" ;
123 : get_post_params
124 S" CONTENT_LENGTH" ENVIRONMENT? NOT IF EXIT THEN
125 NUMBER NOT IF EXIT THEN
126 ALLOCATED 2DUP H-STDIN READ-FILE-EXACT IF 2DROP ELSE GetParamsFromString THEN ;
127 \ ALLOCATED 2DUP H-STDIN READ-FILE . NIP 2DUP TYPE CR GetParamsFromString ;
129 : get_get_params
130 S" QUERY_STRING" ENVIRONMENT? IF GetParamsFromString THEN ;
132 : get_params
133 `REQUEST_METHOD ENVIRONMENT? NOT IF EXIT THEN
134 2DUP `POST CEQUAL IF 2DROP get_post_params EXIT THEN
135 2DUP `GET CEQUAL IF 2DROP get_get_params EXIT THEN
136 2DROP ;
138 [UNDEFINED] WINAPI: [IF]
139 : environ
140 S" environ" symbol-lookup symbol-address @
141 BEGIN
142 DUP @
143 WHILE
144 DUP @ ASCIIZ> TYPE CR
145 CELL+
146 REPEAT
147 DROP ;
148 [ELSE]
150 WINAPI: GetEnvironmentStrings KERNEL32.DLL
152 : environ
153 GetEnvironmentStrings
154 BEGIN
155 DUP B@
156 WHILE
157 ASCIIZ> 2DUP TYPE CR
158 + 1+
159 REPEAT
160 DROP ;
162 [THEN]
164 : env ENVIRONMENT? NOT IF S" " THEN ;
166 : TAB 0x09 EMIT ;
168 : log_request
169 LAMBDA{
170 TIME&DATE DateTime>PAD TYPE TAB
171 `REMOTE_ADDR env TYPE TAB
172 `REQUEST_METHOD env TYPE TAB
173 `SCRIPT_NAME env TYPE SPACE
174 `QUERY_STRING env TYPE TAB
175 `HTTP_USER_AGENT env TYPE
176 } TYPE>STR BACKSTRFREE STR@ `request.log ATTACH-LINE-CATCH DROP ;
178 : headers
179 content:xhtml
180 \ S" Cache-Control: no-cache" TYPE CR
183 : content
184 log_request
185 get_params
186 main
187 CR ;
189 : index
190 headers
191 ['] content TYPE>STR DUP STRLEN content-length
193 STYPE
194 BYE ;
196 \ : index headers CR content ;
198 \ : REQUEST_METHOD S" GET" ;
199 \ : QUERY_STRING S" page_name=MainPage" ;
201 \ ' TYPE1 TO USER-TYPE
203 : save ['] index MAINX ! `sql.cgi SAVE ;
204 save BYE
206 index