adamc@1114
|
1 (* Copyright (c) 2008-2010, Adam Chlipala
|
adamc@764
|
2 * All rights reserved.
|
adamc@764
|
3 *
|
adamc@764
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@764
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@764
|
6 *
|
adamc@764
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@764
|
8 * this list of conditions and the following disclaimer.
|
adamc@764
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@764
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@764
|
11 * and/or other materials provided with the distribution.
|
adamc@764
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@764
|
13 * derived from this software without specific prior written permission.
|
adamc@764
|
14 *
|
adamc@764
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@764
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@764
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@764
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@764
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@764
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@764
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@764
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@764
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@764
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@764
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@764
|
26 *)
|
adamc@764
|
27
|
adamc@764
|
28 structure Settings :> SETTINGS = struct
|
adamc@764
|
29
|
adamc@764
|
30 val urlPrefix = ref "/"
|
adamc@764
|
31 val timeout = ref 0
|
adamc@764
|
32 val headers = ref ([] : string list)
|
adamc@766
|
33 val scripts = ref ([] : string list)
|
adamc@764
|
34
|
adamc@764
|
35 fun getUrlPrefix () = !urlPrefix
|
adamc@764
|
36 fun setUrlPrefix p =
|
adamc@764
|
37 urlPrefix := (if p = "" then
|
adamc@764
|
38 "/"
|
adamc@764
|
39 else if String.sub (p, size p - 1) <> #"/" then
|
adamc@764
|
40 p ^ "/"
|
adamc@764
|
41 else
|
adamc@764
|
42 p)
|
adamc@764
|
43
|
adamc@764
|
44 fun getTimeout () = !timeout
|
adamc@764
|
45 fun setTimeout n = timeout := n
|
adamc@764
|
46
|
adamc@764
|
47 fun getHeaders () = !headers
|
adamc@764
|
48 fun setHeaders ls = headers := ls
|
adamc@764
|
49
|
adamc@766
|
50 fun getScripts () = !scripts
|
adamc@766
|
51 fun setScripts ls = scripts := ls
|
adamc@766
|
52
|
adamc@765
|
53 type ffi = string * string
|
adamc@765
|
54
|
adamc@765
|
55 structure K = struct
|
adamc@765
|
56 type ord_key = ffi
|
adamc@765
|
57 fun compare ((m1, x1), (m2, x2)) =
|
adamc@765
|
58 Order.join (String.compare (m1, m2),
|
adamc@765
|
59 fn () => String.compare (x1, x2))
|
adamc@764
|
60 end
|
adamc@765
|
61
|
adamc@765
|
62 structure S = BinarySetFn(K)
|
adamc@765
|
63 structure M = BinaryMapFn(K)
|
adamc@765
|
64
|
adamc@765
|
65 fun basis x = S.addList (S.empty, map (fn x : string => ("Basis", x)) x)
|
adamc@765
|
66
|
adamc@765
|
67 val clientToServerBase = basis ["int",
|
adamc@765
|
68 "float",
|
adamc@765
|
69 "string",
|
adamc@765
|
70 "time",
|
adamc@765
|
71 "file",
|
adamc@765
|
72 "unit",
|
adamc@765
|
73 "option",
|
adamc@765
|
74 "list",
|
adam@1288
|
75 "bool",
|
adam@1288
|
76 "variant"]
|
adamc@765
|
77 val clientToServer = ref clientToServerBase
|
adamc@765
|
78 fun setClientToServer ls = clientToServer := S.addList (clientToServerBase, ls)
|
adamc@765
|
79 fun mayClientToServer x = S.member (!clientToServer, x)
|
adamc@765
|
80
|
adamc@779
|
81 val effectfulBase = basis ["dml",
|
adamc@779
|
82 "nextval",
|
adamc@1073
|
83 "setval",
|
adamc@779
|
84 "set_cookie",
|
adamc@1050
|
85 "clear_cookie",
|
adamc@765
|
86 "new_channel",
|
adamc@1200
|
87 "send",
|
adamc@1200
|
88 "htmlifyInt_w",
|
adamc@1200
|
89 "htmlifyFloat_w",
|
adamc@1200
|
90 "htmlifyString_w",
|
adamc@1200
|
91 "htmlifyBool_w",
|
adamc@1200
|
92 "htmlifyTime_w",
|
adamc@1200
|
93 "attrifyInt_w",
|
adamc@1200
|
94 "attrifyFloat_w",
|
adamc@1200
|
95 "attrifyString_w",
|
adamc@1200
|
96 "attrifyChar_w",
|
adamc@1200
|
97 "urlifyInt_w",
|
adamc@1200
|
98 "urlifyFloat_w",
|
adamc@1200
|
99 "urlifyString_w",
|
adamc@1200
|
100 "urlifyBool_w",
|
adamc@1200
|
101 "urlifyChannel_w"]
|
adamc@765
|
102
|
adamc@765
|
103 val effectful = ref effectfulBase
|
adamc@765
|
104 fun setEffectful ls = effectful := S.addList (effectfulBase, ls)
|
adamc@765
|
105 fun isEffectful x = S.member (!effectful, x)
|
adamc@765
|
106
|
adamc@1171
|
107 val benignBase = basis ["get_cookie",
|
adamc@1171
|
108 "new_client_source",
|
adamc@1171
|
109 "get_client_source",
|
adamc@1171
|
110 "set_client_source",
|
adamc@1171
|
111 "current",
|
adamc@1171
|
112 "alert",
|
adam@1290
|
113 "confirm",
|
adamc@1171
|
114 "onError",
|
adamc@1171
|
115 "onFail",
|
adamc@1171
|
116 "onConnectFail",
|
adamc@1171
|
117 "onDisconnect",
|
adamc@1171
|
118 "onServerError",
|
adamc@1171
|
119 "kc",
|
adamc@1250
|
120 "debug",
|
adamc@1250
|
121 "rand"]
|
adamc@1171
|
122
|
adamc@1171
|
123 val benign = ref benignBase
|
adamc@1171
|
124 fun setBenignEffectful ls = benign := S.addList (benignBase, ls)
|
adamc@1171
|
125 fun isBenignEffectful x = S.member (!benign, x)
|
adamc@1171
|
126
|
adamc@765
|
127 val clientBase = basis ["get",
|
adamc@765
|
128 "set",
|
adamc@841
|
129 "current",
|
adamc@765
|
130 "alert",
|
adam@1290
|
131 "confirm",
|
adamc@765
|
132 "recv",
|
adamc@765
|
133 "sleep",
|
adamc@765
|
134 "spawn",
|
adamc@765
|
135 "onError",
|
adamc@765
|
136 "onFail",
|
adamc@765
|
137 "onConnectFail",
|
adamc@765
|
138 "onDisconnect",
|
adamc@895
|
139 "onServerError",
|
adamc@895
|
140 "kc"]
|
adamc@765
|
141 val client = ref clientBase
|
adamc@765
|
142 fun setClientOnly ls = client := S.addList (clientBase, ls)
|
adamc@765
|
143 fun isClientOnly x = S.member (!client, x)
|
adamc@765
|
144
|
adamc@765
|
145 val serverBase = basis ["requestHeader",
|
adamc@765
|
146 "query",
|
adamc@765
|
147 "dml",
|
adamc@765
|
148 "nextval",
|
adamc@1073
|
149 "setval",
|
adamc@765
|
150 "channel",
|
adamc@765
|
151 "send"]
|
adamc@765
|
152 val server = ref serverBase
|
adamc@765
|
153 fun setServerOnly ls = server := S.addList (serverBase, ls)
|
adamc@765
|
154 fun isServerOnly x = S.member (!server, x)
|
adamc@765
|
155
|
adamc@765
|
156 val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty
|
adamc@765
|
157
|
adamc@765
|
158 val jsFuncsBase = basisM [("alert", "alert"),
|
adam@1290
|
159 ("confirm", "confrm"),
|
adamc@765
|
160 ("get_client_source", "sg"),
|
adamc@841
|
161 ("current", "scur"),
|
adamc@765
|
162 ("htmlifyBool", "bs"),
|
adamc@765
|
163 ("htmlifyFloat", "ts"),
|
adamc@765
|
164 ("htmlifyInt", "ts"),
|
adamc@765
|
165 ("htmlifyString", "eh"),
|
adamc@765
|
166 ("new_client_source", "sc"),
|
adamc@765
|
167 ("set_client_source", "sv"),
|
adamc@838
|
168 ("stringToFloat", "pflo"),
|
adamc@838
|
169 ("stringToInt", "pio"),
|
adamc@765
|
170 ("stringToFloat_error", "pfl"),
|
adamc@765
|
171 ("stringToInt_error", "pi"),
|
adamc@765
|
172 ("urlifyInt", "ts"),
|
adamc@765
|
173 ("urlifyFloat", "ts"),
|
adamc@765
|
174 ("urlifyString", "uf"),
|
adamc@912
|
175 ("urlifyBool", "ub"),
|
adamc@765
|
176 ("recv", "rv"),
|
adamc@765
|
177 ("strcat", "cat"),
|
adamc@765
|
178 ("intToString", "ts"),
|
adamc@765
|
179 ("floatToString", "ts"),
|
adamc@821
|
180 ("charToString", "ts"),
|
adamc@765
|
181 ("onError", "onError"),
|
adamc@765
|
182 ("onFail", "onFail"),
|
adamc@765
|
183 ("onConnectFail", "onConnectFail"),
|
adamc@765
|
184 ("onDisconnect", "onDisconnect"),
|
adamc@798
|
185 ("onServerError", "onServerError"),
|
adamc@1108
|
186 ("attrifyString", "atr"),
|
adamc@798
|
187 ("attrifyInt", "ts"),
|
adamc@798
|
188 ("attrifyFloat", "ts"),
|
adamc@820
|
189 ("attrifyBool", "bs"),
|
adamc@821
|
190 ("boolToString", "ts"),
|
adamc@1057
|
191 ("str1", "id"),
|
adamc@821
|
192 ("strsub", "sub"),
|
adamc@828
|
193 ("strsuffix", "suf"),
|
adamc@829
|
194 ("strlen", "slen"),
|
adamc@829
|
195 ("strindex", "sidx"),
|
adamc@829
|
196 ("strchr", "schr"),
|
adamc@831
|
197 ("substring", "ssub"),
|
adamc@895
|
198 ("strcspn", "sspn"),
|
adamc@1061
|
199 ("kc", "kc"),
|
adamc@1061
|
200
|
adamc@1061
|
201 ("islower", "isLower"),
|
adamc@1061
|
202 ("isupper", "isUpper"),
|
adamc@1061
|
203 ("isalpha", "isAlpha"),
|
adamc@1061
|
204 ("isdigit", "isDigit"),
|
adamc@1061
|
205 ("isalnum", "isAlnum"),
|
adamc@1061
|
206 ("isblank", "isBlank"),
|
adamc@1061
|
207 ("isspace", "isSpace"),
|
adamc@1061
|
208 ("isxdigit", "isXdigit"),
|
adamc@1061
|
209 ("tolower", "toLower"),
|
adamc@1061
|
210 ("toupper", "toUpper")]
|
adamc@765
|
211 val jsFuncs = ref jsFuncsBase
|
adamc@765
|
212 fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
|
adamc@765
|
213 fun jsFunc x = M.find (!jsFuncs, x)
|
adamc@765
|
214
|
adamc@768
|
215 datatype pattern_kind = Exact | Prefix
|
adamc@768
|
216 datatype action = Allow | Deny
|
adamc@768
|
217 type rule = { action : action, kind : pattern_kind, pattern : string }
|
adamc@768
|
218
|
adamc@768
|
219 datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style
|
adamc@768
|
220 type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string }
|
adamc@768
|
221
|
adamc@768
|
222 val rewrites = ref ([] : rewrite list)
|
adamc@768
|
223
|
adamc@768
|
224 fun subsume (pk1, pk2) =
|
adamc@768
|
225 pk1 = pk2
|
adamc@768
|
226 orelse pk2 = Any
|
adamc@768
|
227 orelse pk2 = Relation andalso (pk1 = Table orelse pk1 = Sequence orelse pk1 = View)
|
adamc@768
|
228
|
adamc@768
|
229 fun setRewriteRules ls = rewrites := ls
|
adamc@768
|
230 fun rewrite pk s =
|
adamc@768
|
231 let
|
adamc@768
|
232 fun rew (ls : rewrite list) =
|
adamc@768
|
233 case ls of
|
adamc@768
|
234 [] => s
|
adamc@768
|
235 | rewr :: ls =>
|
adamc@768
|
236 let
|
adamc@768
|
237 fun match () =
|
adamc@768
|
238 case #kind rewr of
|
adamc@768
|
239 Exact => if #from rewr = s then
|
adamc@768
|
240 SOME (size s)
|
adamc@768
|
241 else
|
adamc@768
|
242 NONE
|
adamc@768
|
243 | Prefix => if String.isPrefix (#from rewr) s then
|
adamc@768
|
244 SOME (size (#from rewr))
|
adamc@768
|
245 else
|
adamc@768
|
246 NONE
|
adamc@768
|
247 in
|
adamc@768
|
248 if subsume (pk, #pkind rewr) then
|
adamc@768
|
249 case match () of
|
adamc@768
|
250 NONE => rew ls
|
adamc@768
|
251 | SOME suffixStart => #to rewr ^ String.extract (s, suffixStart, NONE)
|
adamc@768
|
252 else
|
adamc@768
|
253 rew ls
|
adamc@768
|
254 end
|
adamc@768
|
255 in
|
adamc@768
|
256 rew (!rewrites)
|
adamc@768
|
257 end
|
adamc@768
|
258
|
adamc@769
|
259 val url = ref ([] : rule list)
|
adamc@769
|
260 val mime = ref ([] : rule list)
|
adamc@769
|
261
|
adamc@769
|
262 fun setUrlRules ls = url := ls
|
adamc@769
|
263 fun setMimeRules ls = mime := ls
|
adamc@769
|
264
|
adamc@770
|
265 fun getUrlRules () = !url
|
adamc@770
|
266 fun getMimeRules () = !mime
|
adamc@770
|
267
|
adamc@769
|
268 fun check f rules s =
|
adamc@769
|
269 let
|
adamc@769
|
270 fun chk (ls : rule list) =
|
adamc@769
|
271 case ls of
|
adamc@769
|
272 [] => false
|
adamc@769
|
273 | rule :: ls =>
|
adamc@769
|
274 let
|
adamc@769
|
275 val matches =
|
adamc@769
|
276 case #kind rule of
|
adamc@769
|
277 Exact => #pattern rule = s
|
adamc@769
|
278 | Prefix => String.isPrefix (#pattern rule) s
|
adamc@769
|
279 in
|
adamc@769
|
280 if matches then
|
adamc@769
|
281 case #action rule of
|
adamc@769
|
282 Allow => true
|
adamc@769
|
283 | Deny => false
|
adamc@769
|
284 else
|
adamc@769
|
285 chk ls
|
adamc@769
|
286 end
|
adamc@769
|
287 in
|
adamc@769
|
288 f s andalso chk (!rules)
|
adamc@769
|
289 end
|
adamc@769
|
290
|
adamc@769
|
291 val checkUrl = check (fn _ => true) url
|
adamc@769
|
292 val checkMime = check
|
adamc@769
|
293 (CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #"."))
|
adamc@769
|
294 mime
|
adamc@769
|
295
|
adamc@855
|
296
|
adamc@855
|
297 type protocol = {
|
adamc@855
|
298 name : string,
|
adamc@1096
|
299 compile : string,
|
adamc@1095
|
300 linkStatic : string,
|
adamc@1095
|
301 linkDynamic : string,
|
adamc@1164
|
302 persistent : bool,
|
adamc@1164
|
303 code : unit -> Print.PD.pp_desc
|
adamc@855
|
304 }
|
adamc@855
|
305 val protocols = ref ([] : protocol list)
|
adamc@855
|
306 fun addProtocol p = protocols := p :: !protocols
|
adamc@855
|
307 fun getProtocol s = List.find (fn p => #name p = s) (!protocols)
|
adamc@855
|
308
|
adamc@855
|
309 fun clibFile s = OS.Path.joinDirFile {dir = Config.libC,
|
adamc@855
|
310 file = s}
|
adamc@855
|
311
|
adamc@865
|
312 val curProto = ref {name = "",
|
adamc@1096
|
313 compile = "",
|
adamc@1095
|
314 linkStatic = "",
|
adamc@1095
|
315 linkDynamic = "",
|
adamc@1164
|
316 persistent = false,
|
adamc@1164
|
317 code = fn () => Print.box []}
|
adamc@856
|
318 fun setProtocol name =
|
adamc@856
|
319 case getProtocol name of
|
adamc@856
|
320 NONE => raise Fail ("Unknown protocol " ^ name)
|
adamc@856
|
321 | SOME p => curProto := p
|
adamc@855
|
322 fun currentProtocol () = !curProto
|
adamc@855
|
323
|
adamc@857
|
324 val debug = ref false
|
adamc@857
|
325 fun setDebug b = debug := b
|
adamc@857
|
326 fun getDebug () = !debug
|
adamc@857
|
327
|
adamc@867
|
328 datatype sql_type =
|
adamc@867
|
329 Int
|
adamc@867
|
330 | Float
|
adamc@867
|
331 | String
|
adamc@1011
|
332 | Char
|
adamc@867
|
333 | Bool
|
adamc@867
|
334 | Time
|
adamc@867
|
335 | Blob
|
adamc@867
|
336 | Channel
|
adamc@867
|
337 | Client
|
adamc@867
|
338 | Nullable of sql_type
|
adamc@867
|
339
|
adamc@873
|
340 fun p_sql_ctype t =
|
adamc@867
|
341 let
|
adamc@867
|
342 open Print.PD
|
adamc@867
|
343 open Print
|
adamc@867
|
344 in
|
adamc@867
|
345 case t of
|
adamc@870
|
346 Int => "uw_Basis_int"
|
adamc@870
|
347 | Float => "uw_Basis_float"
|
adamc@870
|
348 | String => "uw_Basis_string"
|
adamc@1011
|
349 | Char => "uw_Basis_char"
|
adamc@870
|
350 | Bool => "uw_Basis_bool"
|
adamc@870
|
351 | Time => "uw_Basis_time"
|
adamc@870
|
352 | Blob => "uw_Basis_blob"
|
adamc@870
|
353 | Channel => "uw_Basis_channel"
|
adamc@870
|
354 | Client => "uw_Basis_client"
|
adamc@870
|
355 | Nullable String => "uw_Basis_string"
|
adamc@873
|
356 | Nullable t => p_sql_ctype t ^ "*"
|
adamc@867
|
357 end
|
adamc@867
|
358
|
adamc@867
|
359 fun isBlob Blob = true
|
adamc@867
|
360 | isBlob (Nullable t) = isBlob t
|
adamc@867
|
361 | isBlob _ = false
|
adamc@867
|
362
|
adamc@870
|
363 fun isNotNull (Nullable _) = false
|
adamc@870
|
364 | isNotNull _ = true
|
adamc@870
|
365
|
adam@1293
|
366 datatype failure_mode = Error | None
|
adam@1293
|
367
|
adamc@866
|
368 type dbms = {
|
adamc@866
|
369 name : string,
|
adamc@866
|
370 header : string,
|
adamc@866
|
371 link : string,
|
adamc@873
|
372 p_sql_type : sql_type -> string,
|
adamc@870
|
373 init : {dbstring : string,
|
adamc@870
|
374 prepared : (string * int) list,
|
adamc@870
|
375 tables : (string * (string * sql_type) list) list,
|
adamc@872
|
376 views : (string * (string * sql_type) list) list,
|
adamc@870
|
377 sequences : string list} -> Print.PD.pp_desc,
|
adamc@873
|
378 query : {loc : ErrorMsg.span, cols : sql_type list,
|
adamc@880
|
379 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc)
|
adamc@867
|
380 -> Print.PD.pp_desc}
|
adamc@867
|
381 -> Print.PD.pp_desc,
|
adamc@867
|
382 queryPrepared : {loc : ErrorMsg.span, id : int, query : string,
|
adamc@873
|
383 inputs : sql_type list, cols : sql_type list,
|
adamc@880
|
384 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int,
|
adamc@880
|
385 typ : sql_type} -> Print.PD.pp_desc)
|
adamc@879
|
386 -> Print.PD.pp_desc,
|
adamc@879
|
387 nested : bool}
|
adamc@868
|
388 -> Print.PD.pp_desc,
|
adam@1293
|
389 dml : ErrorMsg.span * failure_mode -> Print.PD.pp_desc,
|
adamc@868
|
390 dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string,
|
adam@1293
|
391 inputs : sql_type list, mode : failure_mode} -> Print.PD.pp_desc,
|
adamc@878
|
392 nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> Print.PD.pp_desc,
|
adamc@874
|
393 nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc,
|
adamc@1073
|
394 setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc,
|
adamc@874
|
395 sqlifyString : string -> string,
|
adamc@874
|
396 p_cast : string * sql_type -> string,
|
adamc@874
|
397 p_blank : int * sql_type -> string,
|
adamc@877
|
398 supportsDeleteAs : bool,
|
adamc@886
|
399 supportsUpdateAs : bool,
|
adamc@877
|
400 createSequence : string -> string,
|
adamc@878
|
401 textKeysNeedLengths : bool,
|
adamc@879
|
402 supportsNextval : bool,
|
adamc@882
|
403 supportsNestedPrepared : bool,
|
adamc@890
|
404 sqlPrefix : string,
|
adamc@1014
|
405 supportsOctetLength : bool,
|
adamc@1014
|
406 trueString : string,
|
adamc@1196
|
407 falseString : string,
|
adamc@1196
|
408 onlyUnion : bool,
|
adamc@1196
|
409 nestedRelops : bool
|
adamc@866
|
410 }
|
adamc@866
|
411
|
adamc@866
|
412 val dbmses = ref ([] : dbms list)
|
adamc@866
|
413 val curDb = ref ({name = "",
|
adamc@866
|
414 header = "",
|
adamc@866
|
415 link = "",
|
adamc@873
|
416 p_sql_type = fn _ => "",
|
adamc@867
|
417 init = fn _ => Print.box [],
|
adamc@867
|
418 query = fn _ => Print.box [],
|
adamc@868
|
419 queryPrepared = fn _ => Print.box [],
|
adamc@868
|
420 dml = fn _ => Print.box [],
|
adamc@869
|
421 dmlPrepared = fn _ => Print.box [],
|
adamc@869
|
422 nextval = fn _ => Print.box [],
|
adamc@874
|
423 nextvalPrepared = fn _ => Print.box [],
|
adamc@1073
|
424 setval = fn _ => Print.box [],
|
adamc@874
|
425 sqlifyString = fn s => s,
|
adamc@874
|
426 p_cast = fn _ => "",
|
adamc@874
|
427 p_blank = fn _ => "",
|
adamc@877
|
428 supportsDeleteAs = false,
|
adamc@886
|
429 supportsUpdateAs = false,
|
adamc@877
|
430 createSequence = fn _ => "",
|
adamc@878
|
431 textKeysNeedLengths = false,
|
adamc@879
|
432 supportsNextval = false,
|
adamc@882
|
433 supportsNestedPrepared = false,
|
adamc@890
|
434 sqlPrefix = "",
|
adamc@1014
|
435 supportsOctetLength = false,
|
adamc@1014
|
436 trueString = "",
|
adamc@1196
|
437 falseString = "",
|
adamc@1196
|
438 onlyUnion = false,
|
adamc@1196
|
439 nestedRelops = false} : dbms)
|
adamc@866
|
440
|
adamc@866
|
441 fun addDbms v = dbmses := v :: !dbmses
|
adamc@866
|
442 fun setDbms s =
|
adamc@866
|
443 case List.find (fn db => #name db = s) (!dbmses) of
|
adamc@866
|
444 NONE => raise Fail ("Unknown DBMS " ^ s)
|
adamc@866
|
445 | SOME db => curDb := db
|
adamc@866
|
446 fun currentDbms () = !curDb
|
adamc@866
|
447
|
adamc@891
|
448 val dbstring = ref (NONE : string option)
|
adamc@891
|
449 fun setDbstring so = dbstring := so
|
adamc@891
|
450 fun getDbstring () = !dbstring
|
adamc@891
|
451
|
adamc@891
|
452 val exe = ref (NONE : string option)
|
adamc@891
|
453 fun setExe so = exe := so
|
adamc@891
|
454 fun getExe () = !exe
|
adamc@891
|
455
|
adamc@891
|
456 val sql = ref (NONE : string option)
|
adamc@891
|
457 fun setSql so = sql := so
|
adamc@891
|
458 fun getSql () = !sql
|
adamc@891
|
459
|
adamc@1016
|
460 val coreInline = ref 20
|
adamc@1016
|
461 fun setCoreInline n = coreInline := n
|
adamc@1016
|
462 fun getCoreInline () = !coreInline
|
adamc@1016
|
463
|
adamc@1016
|
464 val monoInline = ref 20
|
adamc@1016
|
465 fun setMonoInline n = monoInline := n
|
adamc@1016
|
466 fun getMonoInline () = !monoInline
|
adamc@1016
|
467
|
adamc@1095
|
468 val staticLinking = ref false
|
adamc@1095
|
469 fun setStaticLinking b = staticLinking := b
|
adamc@1095
|
470 fun getStaticLinking () = !staticLinking
|
adamc@1095
|
471
|
adamc@1114
|
472 val deadlines = ref false
|
adamc@1114
|
473 fun setDeadlines b = deadlines := b
|
adamc@1114
|
474 fun getDeadlines () = !deadlines
|
adamc@1114
|
475
|
adamc@1164
|
476 val sigFile = ref (NONE : string option)
|
adamc@1164
|
477 fun setSigFile v = sigFile := v
|
adamc@1164
|
478 fun getSigFile () = !sigFile
|
adamc@1164
|
479
|
adamc@1183
|
480 structure SS = BinarySetFn(struct
|
adamc@1183
|
481 type ord_key = string
|
adamc@1183
|
482 val compare = String.compare
|
adamc@1183
|
483 end)
|
adamc@1183
|
484
|
adamc@1183
|
485 val safeGet = ref SS.empty
|
adamc@1183
|
486 fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls)
|
adamc@1183
|
487 fun isSafeGet x = SS.member (!safeGet, x)
|
adamc@1183
|
488
|
adamc@765
|
489 end
|