Mercurial > urweb

annotate src/settings.sml @ 1404:82b204f20026

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Patch from Vladimir Shabanov to support implicit passing of 'time' values from server to client
author Adam Chlipala <adam@chlipala.net>
date Thu, 20 Jan 2011 10:40:40 -0500
parents 802c179dac1f
children 07ef5771568d
rev   line source
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 "/"
adam@1370 31 val urlPrePrefix = ref ""
adamc@764 32 val timeout = ref 0
adamc@764 33 val headers = ref ([] : string list)
adamc@766 34 val scripts = ref ([] : string list)
adamc@764 35
adamc@764 36 fun getUrlPrefix () = !urlPrefix
adam@1370 37 fun getUrlPrePrefix () = !urlPrePrefix
adamc@764 38 fun setUrlPrefix p =
adam@1370 39 let
adam@1370 40 val prefix = if p = "" then
adam@1370 41 "/"
adam@1370 42 else if String.sub (p, size p - 1) <> #"/" then
adam@1370 43 p ^ "/"
adam@1370 44 else
adam@1370 45 p
adam@1370 46
adam@1370 47 val (prepre, prefix) =
adam@1370 48 if String.isPrefix "http://" prefix then
adam@1370 49 let
adam@1370 50 val (befor, after) = Substring.splitl (fn ch => ch <> #"/") (Substring.extract (prefix, 7, NONE))
adam@1370 51 in
adam@1370 52 if Substring.isEmpty after then
adam@1370 53 ("", prefix)
adam@1370 54 else
adam@1370 55 ("http://" ^ Substring.string befor, Substring.string after)
adam@1370 56 end
adam@1370 57 else
adam@1370 58 ("", prefix)
adam@1370 59 in
adam@1370 60 urlPrePrefix := prepre;
adam@1370 61 urlPrefix := prefix
adam@1370 62 end
adamc@764 63
adamc@764 64 fun getTimeout () = !timeout
adamc@764 65 fun setTimeout n = timeout := n
adamc@764 66
adamc@764 67 fun getHeaders () = !headers
adamc@764 68 fun setHeaders ls = headers := ls
adamc@764 69
adamc@766 70 fun getScripts () = !scripts
adamc@766 71 fun setScripts ls = scripts := ls
adamc@766 72
adamc@765 73 type ffi = string * string
adamc@765 74
adamc@765 75 structure K = struct
adamc@765 76 type ord_key = ffi
adamc@765 77 fun compare ((m1, x1), (m2, x2)) =
adamc@765 78 Order.join (String.compare (m1, m2),
adamc@765 79 fn () => String.compare (x1, x2))
adamc@764 80 end
adamc@765 81
adamc@765 82 structure S = BinarySetFn(K)
adamc@765 83 structure M = BinaryMapFn(K)
adamc@765 84
adamc@765 85 fun basis x = S.addList (S.empty, map (fn x : string => ("Basis", x)) x)
adamc@765 86
adamc@765 87 val clientToServerBase = basis ["int",
adamc@765 88 "float",
adamc@765 89 "string",
adamc@765 90 "time",
adamc@765 91 "file",
adamc@765 92 "unit",
adamc@765 93 "option",
adamc@765 94 "list",
adam@1288 95 "bool",
adam@1288 96 "variant"]
adamc@765 97 val clientToServer = ref clientToServerBase
adamc@765 98 fun setClientToServer ls = clientToServer := S.addList (clientToServerBase, ls)
adamc@765 99 fun mayClientToServer x = S.member (!clientToServer, x)
adamc@765 100
adamc@779 101 val effectfulBase = basis ["dml",
adamc@779 102 "nextval",
adamc@1073 103 "setval",
adamc@779 104 "set_cookie",
adamc@1050 105 "clear_cookie",
adamc@765 106 "new_channel",
adamc@1200 107 "send",
adamc@1200 108 "htmlifyInt_w",
adamc@1200 109 "htmlifyFloat_w",
adamc@1200 110 "htmlifyString_w",
adamc@1200 111 "htmlifyBool_w",
adamc@1200 112 "htmlifyTime_w",
adamc@1200 113 "attrifyInt_w",
adamc@1200 114 "attrifyFloat_w",
adamc@1200 115 "attrifyString_w",
adamc@1200 116 "attrifyChar_w",
adamc@1200 117 "urlifyInt_w",
adamc@1200 118 "urlifyFloat_w",
adamc@1200 119 "urlifyString_w",
adamc@1200 120 "urlifyBool_w",
adamc@1200 121 "urlifyChannel_w"]
adamc@765 122
adamc@765 123 val effectful = ref effectfulBase
adamc@765 124 fun setEffectful ls = effectful := S.addList (effectfulBase, ls)
adamc@765 125 fun isEffectful x = S.member (!effectful, x)
adamc@765 126
adamc@1171 127 val benignBase = basis ["get_cookie",
adamc@1171 128 "new_client_source",
adamc@1171 129 "get_client_source",
adamc@1171 130 "set_client_source",
adamc@1171 131 "current",
adamc@1171 132 "alert",
adam@1290 133 "confirm",
adamc@1171 134 "onError",
adamc@1171 135 "onFail",
adamc@1171 136 "onConnectFail",
adamc@1171 137 "onDisconnect",
adamc@1171 138 "onServerError",
adamc@1171 139 "kc",
adamc@1250 140 "debug",
adam@1389 141 "naughtyDebug",
adamc@1250 142 "rand"]
adamc@1171 143
adamc@1171 144 val benign = ref benignBase
adamc@1171 145 fun setBenignEffectful ls = benign := S.addList (benignBase, ls)
adamc@1171 146 fun isBenignEffectful x = S.member (!benign, x)
adamc@1171 147
adamc@765 148 val clientBase = basis ["get",
adamc@765 149 "set",
adamc@841 150 "current",
adamc@765 151 "alert",
adam@1290 152 "confirm",
adamc@765 153 "recv",
adamc@765 154 "sleep",
adamc@765 155 "spawn",
adamc@765 156 "onError",
adamc@765 157 "onFail",
adamc@765 158 "onConnectFail",
adamc@765 159 "onDisconnect",
adamc@895 160 "onServerError",
adamc@895 161 "kc"]
adamc@765 162 val client = ref clientBase
adamc@765 163 fun setClientOnly ls = client := S.addList (clientBase, ls)
adamc@765 164 fun isClientOnly x = S.member (!client, x)
adamc@765 165
adamc@765 166 val serverBase = basis ["requestHeader",
adamc@765 167 "query",
adamc@765 168 "dml",
adamc@765 169 "nextval",
adamc@1073 170 "setval",
adamc@765 171 "channel",
adamc@765 172 "send"]
adamc@765 173 val server = ref serverBase
adamc@765 174 fun setServerOnly ls = server := S.addList (serverBase, ls)
adamc@765 175 fun isServerOnly x = S.member (!server, x)
adamc@765 176
adamc@765 177 val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty
adamc@765 178
adamc@765 179 val jsFuncsBase = basisM [("alert", "alert"),
adam@1290 180 ("confirm", "confrm"),
adamc@765 181 ("get_client_source", "sg"),
adamc@841 182 ("current", "scur"),
adamc@765 183 ("htmlifyBool", "bs"),
adamc@765 184 ("htmlifyFloat", "ts"),
adamc@765 185 ("htmlifyInt", "ts"),
adamc@765 186 ("htmlifyString", "eh"),
adamc@765 187 ("new_client_source", "sc"),
adamc@765 188 ("set_client_source", "sv"),
adamc@838 189 ("stringToFloat", "pflo"),
adamc@838 190 ("stringToInt", "pio"),
adamc@765 191 ("stringToFloat_error", "pfl"),
adamc@765 192 ("stringToInt_error", "pi"),
adamc@765 193 ("urlifyInt", "ts"),
adamc@765 194 ("urlifyFloat", "ts"),
adam@1360 195 ("urlifyTime", "ts"),
adamc@765 196 ("urlifyString", "uf"),
adamc@912 197 ("urlifyBool", "ub"),
adamc@765 198 ("recv", "rv"),
adamc@765 199 ("strcat", "cat"),
adamc@765 200 ("intToString", "ts"),
adamc@765 201 ("floatToString", "ts"),
adamc@821 202 ("charToString", "ts"),
adamc@765 203 ("onError", "onError"),
adamc@765 204 ("onFail", "onFail"),
adamc@765 205 ("onConnectFail", "onConnectFail"),
adamc@765 206 ("onDisconnect", "onDisconnect"),
adamc@798 207 ("onServerError", "onServerError"),
adamc@1108 208 ("attrifyString", "atr"),
adamc@798 209 ("attrifyInt", "ts"),
adamc@798 210 ("attrifyFloat", "ts"),
adamc@820 211 ("attrifyBool", "bs"),
adamc@821 212 ("boolToString", "ts"),
adamc@1057 213 ("str1", "id"),
adamc@821 214 ("strsub", "sub"),
adamc@828 215 ("strsuffix", "suf"),
adamc@829 216 ("strlen", "slen"),
adamc@829 217 ("strindex", "sidx"),
adamc@829 218 ("strchr", "schr"),
adamc@831 219 ("substring", "ssub"),
adamc@895 220 ("strcspn", "sspn"),
adamc@1061 221 ("kc", "kc"),
adam@1404 222 ("minTime", "0"),
adamc@1061 223
adamc@1061 224 ("islower", "isLower"),
adamc@1061 225 ("isupper", "isUpper"),
adamc@1061 226 ("isalpha", "isAlpha"),
adamc@1061 227 ("isdigit", "isDigit"),
adamc@1061 228 ("isalnum", "isAlnum"),
adamc@1061 229 ("isblank", "isBlank"),
adamc@1061 230 ("isspace", "isSpace"),
adamc@1061 231 ("isxdigit", "isXdigit"),
adamc@1061 232 ("tolower", "toLower"),
adamc@1323 233 ("toupper", "toUpper"),
adamc@1323 234
adamc@1323 235 ("checkUrl", "checkUrl"),
adam@1366 236 ("bless", "bless"),
adam@1366 237
adam@1366 238 ("eq_time", "eq"),
adam@1366 239 ("lt_time", "lt"),
adam@1366 240 ("le_time", "le")]
adamc@765 241 val jsFuncs = ref jsFuncsBase
adamc@765 242 fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
adamc@765 243 fun jsFunc x = M.find (!jsFuncs, x)
adamc@765 244
adamc@768 245 datatype pattern_kind = Exact | Prefix
adamc@768 246 datatype action = Allow | Deny
adamc@768 247 type rule = { action : action, kind : pattern_kind, pattern : string }
adamc@768 248
adamc@768 249 datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style
adamc@768 250 type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string }
adamc@768 251
adamc@768 252 val rewrites = ref ([] : rewrite list)
adamc@768 253
adamc@768 254 fun subsume (pk1, pk2) =
adamc@768 255 pk1 = pk2
adamc@768 256 orelse pk2 = Any
adamc@768 257 orelse pk2 = Relation andalso (pk1 = Table orelse pk1 = Sequence orelse pk1 = View)
adamc@768 258
adamc@768 259 fun setRewriteRules ls = rewrites := ls
adamc@768 260 fun rewrite pk s =
adamc@768 261 let
adamc@768 262 fun rew (ls : rewrite list) =
adamc@768 263 case ls of
adamc@768 264 [] => s
adamc@768 265 | rewr :: ls =>
adamc@768 266 let
adamc@768 267 fun match () =
adamc@768 268 case #kind rewr of
adamc@768 269 Exact => if #from rewr = s then
adamc@768 270 SOME (size s)
adamc@768 271 else
adamc@768 272 NONE
adamc@768 273 | Prefix => if String.isPrefix (#from rewr) s then
adamc@768 274 SOME (size (#from rewr))
adamc@768 275 else
adamc@768 276 NONE
adamc@768 277 in
adamc@768 278 if subsume (pk, #pkind rewr) then
adamc@768 279 case match () of
adamc@768 280 NONE => rew ls
adamc@768 281 | SOME suffixStart => #to rewr ^ String.extract (s, suffixStart, NONE)
adamc@768 282 else
adamc@768 283 rew ls
adamc@768 284 end
adamc@768 285 in
adamc@768 286 rew (!rewrites)
adamc@768 287 end
adamc@768 288
adamc@769 289 val url = ref ([] : rule list)
adamc@769 290 val mime = ref ([] : rule list)
adamc@769 291
adamc@769 292 fun setUrlRules ls = url := ls
adamc@769 293 fun setMimeRules ls = mime := ls
adamc@769 294
adamc@770 295 fun getUrlRules () = !url
adamc@770 296 fun getMimeRules () = !mime
adamc@770 297
adamc@769 298 fun check f rules s =
adamc@769 299 let
adamc@769 300 fun chk (ls : rule list) =
adamc@769 301 case ls of
adamc@769 302 [] => false
adamc@769 303 | rule :: ls =>
adamc@769 304 let
adamc@769 305 val matches =
adamc@769 306 case #kind rule of
adamc@769 307 Exact => #pattern rule = s
adamc@769 308 | Prefix => String.isPrefix (#pattern rule) s
adamc@769 309 in
adamc@769 310 if matches then
adamc@769 311 case #action rule of
adamc@769 312 Allow => true
adamc@769 313 | Deny => false
adamc@769 314 else
adamc@769 315 chk ls
adamc@769 316 end
adamc@769 317 in
adamc@769 318 f s andalso chk (!rules)
adamc@769 319 end
adamc@769 320
adamc@769 321 val checkUrl = check (fn _ => true) url
adamc@769 322 val checkMime = check
adamc@769 323 (CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #"."))
adamc@769 324 mime
adamc@769 325
adamc@855 326
adamc@855 327 type protocol = {
adamc@855 328 name : string,
adamc@1096 329 compile : string,
adamc@1095 330 linkStatic : string,
adamc@1095 331 linkDynamic : string,
adamc@1164 332 persistent : bool,
adamc@1164 333 code : unit -> Print.PD.pp_desc
adamc@855 334 }
adamc@855 335 val protocols = ref ([] : protocol list)
adamc@855 336 fun addProtocol p = protocols := p :: !protocols
adamc@855 337 fun getProtocol s = List.find (fn p => #name p = s) (!protocols)
adamc@855 338
adamc@855 339 fun clibFile s = OS.Path.joinDirFile {dir = Config.libC,
adamc@855 340 file = s}
adamc@855 341
adamc@865 342 val curProto = ref {name = "",
adamc@1096 343 compile = "",
adamc@1095 344 linkStatic = "",
adamc@1095 345 linkDynamic = "",
adamc@1164 346 persistent = false,
adamc@1164 347 code = fn () => Print.box []}
adamc@856 348 fun setProtocol name =
adamc@856 349 case getProtocol name of
adamc@856 350 NONE => raise Fail ("Unknown protocol " ^ name)
adamc@856 351 | SOME p => curProto := p
adamc@855 352 fun currentProtocol () = !curProto
adamc@855 353
adamc@857 354 val debug = ref false
adamc@857 355 fun setDebug b = debug := b
adamc@857 356 fun getDebug () = !debug
adamc@857 357
adamc@867 358 datatype sql_type =
adamc@867 359 Int
adamc@867 360 | Float
adamc@867 361 | String
adamc@1011 362 | Char
adamc@867 363 | Bool
adamc@867 364 | Time
adamc@867 365 | Blob
adamc@867 366 | Channel
adamc@867 367 | Client
adamc@867 368 | Nullable of sql_type
adamc@867 369
adamc@873 370 fun p_sql_ctype t =
adamc@867 371 let
adamc@867 372 open Print.PD
adamc@867 373 open Print
adamc@867 374 in
adamc@867 375 case t of
adamc@870 376 Int => "uw_Basis_int"
adamc@870 377 | Float => "uw_Basis_float"
adamc@870 378 | String => "uw_Basis_string"
adamc@1011 379 | Char => "uw_Basis_char"
adamc@870 380 | Bool => "uw_Basis_bool"
adamc@870 381 | Time => "uw_Basis_time"
adamc@870 382 | Blob => "uw_Basis_blob"
adamc@870 383 | Channel => "uw_Basis_channel"
adamc@870 384 | Client => "uw_Basis_client"
adamc@870 385 | Nullable String => "uw_Basis_string"
adamc@873 386 | Nullable t => p_sql_ctype t ^ "*"
adamc@867 387 end
adamc@867 388
adamc@867 389 fun isBlob Blob = true
adamc@867 390 | isBlob (Nullable t) = isBlob t
adamc@867 391 | isBlob _ = false
adamc@867 392
adamc@870 393 fun isNotNull (Nullable _) = false
adamc@870 394 | isNotNull _ = true
adamc@870 395
adam@1293 396 datatype failure_mode = Error | None
adam@1293 397
adamc@866 398 type dbms = {
adamc@866 399 name : string,
adamc@866 400 header : string,
adamc@866 401 link : string,
adamc@873 402 p_sql_type : sql_type -> string,
adamc@870 403 init : {dbstring : string,
adamc@870 404 prepared : (string * int) list,
adamc@870 405 tables : (string * (string * sql_type) list) list,
adamc@872 406 views : (string * (string * sql_type) list) list,
adamc@870 407 sequences : string list} -> Print.PD.pp_desc,
adamc@873 408 query : {loc : ErrorMsg.span, cols : sql_type list,
adamc@880 409 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc)
adamc@867 410 -> Print.PD.pp_desc}
adamc@867 411 -> Print.PD.pp_desc,
adamc@867 412 queryPrepared : {loc : ErrorMsg.span, id : int, query : string,
adamc@873 413 inputs : sql_type list, cols : sql_type list,
adamc@880 414 doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int,
adamc@880 415 typ : sql_type} -> Print.PD.pp_desc)
adamc@879 416 -> Print.PD.pp_desc,
adamc@879 417 nested : bool}
adamc@868 418 -> Print.PD.pp_desc,
adam@1293 419 dml : ErrorMsg.span * failure_mode -> Print.PD.pp_desc,
adamc@868 420 dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string,
adam@1293 421 inputs : sql_type list, mode : failure_mode} -> Print.PD.pp_desc,
adamc@878 422 nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> Print.PD.pp_desc,
adamc@874 423 nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc,
adamc@1073 424 setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc,
adamc@874 425 sqlifyString : string -> string,
adamc@874 426 p_cast : string * sql_type -> string,
adamc@874 427 p_blank : int * sql_type -> string,
adamc@877 428 supportsDeleteAs : bool,
adamc@886 429 supportsUpdateAs : bool,
adamc@877 430 createSequence : string -> string,
adamc@878 431 textKeysNeedLengths : bool,
adamc@879 432 supportsNextval : bool,
adamc@882 433 supportsNestedPrepared : bool,
adamc@890 434 sqlPrefix : string,
adamc@1014 435 supportsOctetLength : bool,
adamc@1014 436 trueString : string,
adamc@1196 437 falseString : string,
adamc@1196 438 onlyUnion : bool,
adamc@1196 439 nestedRelops : bool
adamc@866 440 }
adamc@866 441
adamc@866 442 val dbmses = ref ([] : dbms list)
adamc@866 443 val curDb = ref ({name = "",
adamc@866 444 header = "",
adamc@866 445 link = "",
adamc@873 446 p_sql_type = fn _ => "",
adamc@867 447 init = fn _ => Print.box [],
adamc@867 448 query = fn _ => Print.box [],
adamc@868 449 queryPrepared = fn _ => Print.box [],
adamc@868 450 dml = fn _ => Print.box [],
adamc@869 451 dmlPrepared = fn _ => Print.box [],
adamc@869 452 nextval = fn _ => Print.box [],
adamc@874 453 nextvalPrepared = fn _ => Print.box [],
adamc@1073 454 setval = fn _ => Print.box [],
adamc@874 455 sqlifyString = fn s => s,
adamc@874 456 p_cast = fn _ => "",
adamc@874 457 p_blank = fn _ => "",
adamc@877 458 supportsDeleteAs = false,
adamc@886 459 supportsUpdateAs = false,
adamc@877 460 createSequence = fn _ => "",
adamc@878 461 textKeysNeedLengths = false,
adamc@879 462 supportsNextval = false,
adamc@882 463 supportsNestedPrepared = false,
adamc@890 464 sqlPrefix = "",
adamc@1014 465 supportsOctetLength = false,
adamc@1014 466 trueString = "",
adamc@1196 467 falseString = "",
adamc@1196 468 onlyUnion = false,
adamc@1196 469 nestedRelops = false} : dbms)
adamc@866 470
adamc@866 471 fun addDbms v = dbmses := v :: !dbmses
adamc@866 472 fun setDbms s =
adamc@866 473 case List.find (fn db => #name db = s) (!dbmses) of
adamc@866 474 NONE => raise Fail ("Unknown DBMS " ^ s)
adamc@866 475 | SOME db => curDb := db
adamc@866 476 fun currentDbms () = !curDb
adamc@866 477
adamc@891 478 val dbstring = ref (NONE : string option)
adamc@891 479 fun setDbstring so = dbstring := so
adamc@891 480 fun getDbstring () = !dbstring
adamc@891 481
adamc@891 482 val exe = ref (NONE : string option)
adamc@891 483 fun setExe so = exe := so
adamc@891 484 fun getExe () = !exe
adamc@891 485
adamc@891 486 val sql = ref (NONE : string option)
adamc@891 487 fun setSql so = sql := so
adamc@891 488 fun getSql () = !sql
adamc@891 489
adamc@1016 490 val coreInline = ref 20
adamc@1016 491 fun setCoreInline n = coreInline := n
adamc@1016 492 fun getCoreInline () = !coreInline
adamc@1016 493
adam@1351 494 val monoInline = ref 100
adamc@1016 495 fun setMonoInline n = monoInline := n
adamc@1016 496 fun getMonoInline () = !monoInline
adamc@1016 497
adamc@1095 498 val staticLinking = ref false
adamc@1095 499 fun setStaticLinking b = staticLinking := b
adamc@1095 500 fun getStaticLinking () = !staticLinking
adamc@1095 501
adamc@1114 502 val deadlines = ref false
adamc@1114 503 fun setDeadlines b = deadlines := b
adamc@1114 504 fun getDeadlines () = !deadlines
adamc@1114 505
adamc@1164 506 val sigFile = ref (NONE : string option)
adamc@1164 507 fun setSigFile v = sigFile := v
adamc@1164 508 fun getSigFile () = !sigFile
adamc@1164 509
adamc@1183 510 structure SS = BinarySetFn(struct
adamc@1183 511 type ord_key = string
adamc@1183 512 val compare = String.compare
adamc@1183 513 end)
adamc@1183 514
adamc@1183 515 val safeGet = ref SS.empty
adamc@1183 516 fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls)
adamc@1183 517 fun isSafeGet x = SS.member (!safeGet, x)
adamc@1183 518
adam@1294 519 val onError = ref (NONE : (string * string list * string) option)
adam@1294 520 fun setOnError x = onError := x
adam@1294 521 fun getOnError () = !onError
adam@1294 522
adam@1307 523 val limits = ["messages", "clients", "headers", "page", "heap", "script",
adam@1307 524 "inputs", "subinputs", "cleanup", "deltas", "transactionals",
adam@1308 525 "globals", "database", "time"]
adam@1307 526
adam@1307 527 val limitsList = ref ([] : (string * int) list)
adam@1307 528 fun addLimit (v as (name, _)) =
adam@1307 529 if List.exists (fn name' => name' = name) limits then
adam@1308 530 (limitsList := v :: !limitsList;
adam@1308 531 if name = "time" then
adam@1308 532 setDeadlines true
adam@1308 533 else
adam@1308 534 ())
adam@1307 535 else
adam@1307 536 raise Fail ("Unknown limit category '" ^ name ^ "'")
adam@1307 537 fun limits () = !limitsList
adam@1307 538
adam@1332 539 val minHeap = ref 0
adam@1332 540 fun setMinHeap n = if n >= 0 then minHeap := n else raise Fail "Trying to set negative minHeap"
adam@1332 541 fun getMinHeap () = !minHeap
adam@1332 542
adam@1393 543 structure SS = BinarySetFn(struct
adam@1393 544 type ord_key = string
adam@1393 545 val compare = String.compare
adam@1393 546 end)
adam@1393 547
adam@1393 548 val alwaysInline = ref SS.empty
adam@1393 549 fun addAlwaysInline s = alwaysInline := SS.add (!alwaysInline, s)
adam@1393 550 fun checkAlwaysInline s = SS.member (!alwaysInline, s)
adam@1393 551
adamc@765 552 end