Something went wrong. Try again.
My own corner of monopam
Something went wrong. Try again.
35 kB · 807 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808module V = Catalog.Valuemodule Func = Sql.Func
let value = Alcotest.testable V.pp V.equallet vint n = V.Int (Int64.of_int n)let apply name args = Func.apply name args
let text = function | V.Text s -> s | v -> Alcotest.failf "expected text, got %a" V.pp v
(* The plain forms of the string and numeric scalars, ahead of the edge cases below: length counts characters, substr is 1-based with an optional length, upper/lower fold ASCII, replace substitutes, trim strips, abs and round are the usual arithmetic, and min/max are variadic over their arguments. *)let test_scalar_basics () = Alcotest.check value "length('abc') is 3" (vint 3) (apply "length" [ V.Text "abc" ]); Alcotest.check value "substr('hello',2,3) is 'ell'" (V.Text "ell") (apply "substr" [ V.Text "hello"; vint 2; vint 3 ]); Alcotest.check value "upper('aB') is 'AB'" (V.Text "AB") (apply "upper" [ V.Text "aB" ]); Alcotest.check value "replace('aXa','X','-') is 'a-a'" (V.Text "a-a") (apply "replace" [ V.Text "aXa"; V.Text "X"; V.Text "-" ]); Alcotest.check value "trim(' x ') is 'x'" (V.Text "x") (apply "trim" [ V.Text " x " ]); Alcotest.check value "abs(-5) is 5" (vint 5) (apply "abs" [ vint (-5) ]); Alcotest.check value "round(2.5) is 3.0" (V.Float 3.0) (apply "round" [ V.Float 2.5 ]); Alcotest.check value "round(3.14159, 2) is 3.14" (V.Float 3.14) (apply "round" [ V.Float 3.14159; vint 2 ]); Alcotest.check value "max(3,7,1) is 7" (vint 7) (apply "max" [ vint 3; vint 7; vint 1 ]); Alcotest.check value "min(3,7,1) is 1" (vint 1) (apply "min" [ vint 3; vint 7; vint 1 ])
(* coalesce returns the first non-NULL; nullif returns NULL when the two compare equal, else the first. *)let test_null_funcs () = Alcotest.check value "coalesce(NULL, NULL, 4) is 4" (vint 4) (apply "coalesce" [ V.Null; V.Null; vint 4 ]); Alcotest.check value "nullif(5, 5) is NULL" V.Null (apply "nullif" [ vint 5; vint 5 ]); Alcotest.check value "nullif(5, 6) is 5" (vint 5) (apply "nullif" [ vint 5; vint 6 ]); Alcotest.check value "nullif(NULL, 1) is NULL" V.Null (apply "nullif" [ V.Null; vint 1 ])
let test_text_edges () = Alcotest.check value "length counts UTF-8 scalar values" (vint 3) (apply "length" [ V.Text "a\195\169b" ]); Alcotest.check value "octet_length counts bytes" (vint 4) (apply "octet_length" [ V.Text "a\195\169b" ]); Alcotest.check value "substr is one-based" (V.Text "ell") (apply "substr" [ V.Text "hello"; vint 2; vint 3 ]); Alcotest.check value "negative length clamps to empty" (V.Text "") (apply "substr" [ V.Text "hello"; vint 5; vint (-3) ])
let test_substr_coerces_bounds () = Alcotest.check value "a text offset coerces to a number" (V.Text "ello") (apply "substr" [ V.Text "hello"; V.Text "2" ]); Alcotest.check value "a fractional text offset truncates" (V.Text "ello") (apply "substr" [ V.Text "hello"; V.Text "2.7" ]); Alcotest.check value "an unparsable offset is zero" (V.Text "hello") (apply "substr" [ V.Text "hello"; V.Text "abc" ]); Alcotest.check value "a text length coerces too" (V.Text "el") (apply "substr" [ V.Text "hello"; vint 2; V.Text "2" ]); Alcotest.check value "a negative text offset counts from the end" (V.Text "lo") (apply "substr" [ V.Text "hello"; V.Text "-2" ])
let test_json_edges () = Alcotest.check value "json_extract indexes array" (vint 20) (apply "json_extract" [ V.Text "{\"a\":[10,20]}"; V.Text "$.a[1]" ]); Alcotest.check value "json ->> returns SQL text" (V.Text "v") (Func.json_arrow ~as_text:true (V.Text "{\"k\":\"v\"}") (V.Text "$.k")); Alcotest.check value "missing json path is NULL" V.Null (apply "json_extract" [ V.Text "{\"a\":1}"; V.Text "$.missing" ]); Alcotest.check_raises "malformed json is rejected" (Failure "malformed JSON") (fun () -> ignore (apply "json_extract" [ V.Text "{"; V.Text "$" ]))
let test_table_function_edges () = Alcotest.(check (list string)) "generate_series column" [ "value" ] (Func.table_function_columns "generate_series"); let series args = let _cols, rows = Func.table_function "generate_series" args in rows in Alcotest.check (Alcotest.list (Alcotest.list value)) "generate_series(1,3) rows" [ [ vint 1 ]; [ vint 2 ]; [ vint 3 ] ] (series [ vint 1; vint 3 ]); Alcotest.check (Alcotest.list (Alcotest.list value)) "descending generate_series" [ [ vint 3 ]; [ vint 2 ]; [ vint 1 ] ] (series [ vint 3; vint 1; vint (-1) ]); Alcotest.check_raises "zero step rejected" (Failure "generate_series: step must be non-zero") (fun () -> ignore (Func.table_function "generate_series" [ vint 1; vint 3; vint 0 ])); Alcotest.check_raises "oversized series is rejected" (Failure "generate_series: range too large to materialise") (fun () -> ignore (Func.table_function "generate_series" [ vint 0; vint 10_000_000 ])); Alcotest.check_raises "non-integer series arg is rejected" (Failure "generate_series: integer arguments expected") (fun () -> ignore (Func.table_function "generate_series" [ V.Text "1"; vint 3 ]))
let test_cve_format_edges () = (* CVE-2022-35737-style: hostile printf width/precision must be bounded before any allocation is attempted. *) let padded = text (apply "printf" [ V.Text "%*s"; vint 4096; V.Text "x" ]) in Alcotest.(check int) "bounded star width length" 4096 (String.length padded); Alcotest.(check string) "bounded star width right edge" "x" (String.sub padded 4095 1); let left = text (apply "printf" [ V.Text "%*s"; vint (-16); V.Text "x" ]) in Alcotest.(check int) "negative star width length" 16 (String.length left); Alcotest.(check string) "negative star width left-justifies" "x" (String.sub left 0 1); Alcotest.(check string) "star precision clips text" "abc" (text (apply "printf" [ V.Text "%.*s"; vint 3; V.Text "abcdef" ])); Alcotest.(check string) "negative star precision is ignored" "abcdef" (text (apply "printf" [ V.Text "%.*s"; vint (-1); V.Text "abcdef" ])); Alcotest.check_raises "oversized star width rejected" (Failure "format: width or precision too large") (fun () -> ignore (apply "printf" [ V.Text "%*s"; V.Int Int64.max_int; V.Text "x" ])); Alcotest.check_raises "oversized literal width rejected" (Failure "format: width or precision too large") (fun () -> ignore (apply "printf" [ V.Text "%1000001s"; V.Text "x" ])); Alcotest.check_raises "oversized literal precision rejected" (Failure "format: width or precision too large") (fun () -> ignore (apply "printf" [ V.Text "%.1000001s"; V.Text "x" ]))
let test_binary_and_unicode_edges () = Alcotest.check value "unhex decodes mixed-case hex" (V.Blob "\000\015\255") (apply "unhex" [ V.Text "000Fff" ]); Alcotest.check value "unhex rejects odd-length input" V.Null (apply "unhex" [ V.Text "123" ]); Alcotest.check value "unhex rejects non-hex input" V.Null (apply "unhex" [ V.Text "00xz" ]); Alcotest.check value "negative zeroblob clamps to empty blob" (V.Blob "") (apply "zeroblob" [ vint (-3) ]); Alcotest.check value "zeroblob materialises zero bytes" (V.Blob "\000\000\000") (apply "zeroblob" [ vint 3 ]); Alcotest.check value "zeroblob(NULL) is an empty blob, not NULL" (V.Blob "") (apply "zeroblob" [ V.Null ]); Alcotest.check value "zeroblob reads text by its numeric prefix" (V.Blob "\000\000\000\000\000") (apply "zeroblob" [ V.Text "5" ]); Alcotest.check value "zeroblob truncates a real" (V.Blob "\000\000\000") (apply "zeroblob" [ V.Float 3.7 ]); Alcotest.check value "char invalid codepoint uses replacement character" (V.Text "\239\191\189") (apply "char" [ V.Int 0x110000L ]); Alcotest.check value "unicode malformed UTF-8 uses replacement codepoint" (vint 0xfffd) (apply "unicode" [ V.Text "\255" ]); Alcotest.check value "unicode empty text is NULL" V.Null (apply "unicode" [ V.Text "" ])
let test_math_non_finite () = let inf = V.Float Float.infinity in let c what expected name args = Alcotest.check value what expected (apply name args) in c "pow to a negative power of zero overflows" inf "pow" [ vint 0; vint (-1) ]; c "and to an even one" inf "pow" [ vint 0; vint (-2) ]; c "a product past the exponent range" inf "pow" [ V.Float 1e300; vint 2 ]; c "exp of an infinity" inf "exp" [ V.Float Float.infinity ]; c "exp past the exponent range" inf "exp" [ V.Float 710. ]; c "exp of a negative infinity underflows to zero" (V.Float 0.) "exp" [ V.Float Float.neg_infinity ]; c "sqrt of an infinity" inf "sqrt" [ V.Float Float.infinity ]; c "degrees scales past the range" inf "degrees" [ V.Float 1e308 ]; c "sinh overflows" inf "sinh" [ V.Float 1000. ]; c "cosh overflows" inf "cosh" [ V.Float 1000. ]; c "atanh at the edge of its domain" inf "atanh" [ V.Float 1. ]; c "atan2 at the origin is zero, not a domain error" (V.Float 0.) "atan2" [ vint 0; vint 0 ]; (* the NaN half of the same rule *) c "sqrt outside its domain" V.Null "sqrt" [ vint (-1) ]; c "acos outside its domain" V.Null "acos" [ vint 2 ]; c "asin outside its domain" V.Null "asin" [ vint 2 ]; c "a fractional power of a negative base" V.Null "pow" [ vint (-1); V.Float 0.5 ]; c "fmod by zero" V.Null "mod" [ vint 1; vint 0 ]; c "atanh outside its domain" V.Null "atanh" [ V.Float 2. ]; c "acosh outside its domain" V.Null "acosh" [ V.Float 0. ]; (* the logarithms reject the argument, so no -Inf ever reaches the value *) c "ln of zero" V.Null "ln" [ vint 0 ]; c "ln of a negative" V.Null "ln" [ vint (-1) ]; c "log10 of zero" V.Null "log10" [ vint 0 ]; c "log2 of zero" V.Null "log2" [ vint 0 ]; c "log base zero" V.Null "log" [ vint 0; vint 5 ]; c "log base one, whose own log is zero" V.Null "log" [ vint 1; vint 5 ]; c "log base below one" V.Null "log" [ V.Float 0.5; vint 4 ]; c "log of zero in any base" V.Null "log" [ vint 2; vint 0 ]; c "a base above one still answers" (V.Float 3.) "log" [ vint 2; vint 8 ]
let test_math_numeric_gate () = let c what expected name args = Alcotest.check value what expected (apply name args) in c "numeric text is read as its number" (V.Float 2.) "sqrt" [ V.Text "4" ]; c "surrounding whitespace and all" (V.Float 2.) "sqrt" [ V.Text " 4 " ]; c "a numeric prefix is not a number" V.Null "sqrt" [ V.Text "4x" ]; c "nor is non-numeric text" V.Null "sqrt" [ V.Text "abc" ]; c "a blob is never numeric" V.Null "sqrt" [ V.Blob "4" ]; c "two-argument functions gate both" V.Null "pow" [ V.Text "abc"; vint 2 ]; c "either way round" V.Null "pow" [ vint 2; V.Text "abc" ]; c "and so does the logarithm" V.Null "ln" [ V.Text "abc" ]; c "which still reads numeric text" (V.Float 1.3862943611198906) "ln" [ V.Text "4" ]; c "sign gates its argument" V.Null "sign" [ V.Text "abc" ]; c "and reads numeric text as a number" (vint 1) "sign" [ V.Text "4" ]; (* ceil/floor/trunc keep the class the gate landed on *) c "ceil of an integer stays an integer" (vint 17) "ceil" [ vint 17 ]; c "floor of an integer too" (vint 17) "floor" [ vint 17 ]; c "trunc of an integer too" (vint 17) "trunc" [ vint 17 ]; c "ceil of a real rounds up" (V.Float 43.) "ceil" [ V.Float 42.2 ]; c "floor of a real rounds down" (V.Float 42.) "floor" [ V.Float 42.2 ]; c "trunc of a real drops the fraction" (V.Float 42.) "trunc" [ V.Float 42.7 ]; c "trunc towards zero for a negative" (V.Float (-42.)) "trunc" [ V.Float (-42.7) ]; c "integral text stays an integer" (vint 4) "ceil" [ V.Text "4" ]; c "fractional text becomes a real" (V.Float 5.) "ceil" [ V.Text "4.2" ]; c "an exponent spelling is a real, whole or not" (V.Float 400.) "ceil" [ V.Text "4e2" ]; c "text too wide for int64 is a real" (V.Float 9.223372036854775808e18) "ceil" [ V.Text "9223372036854775808" ]; c "and one that fits stays an integer" (V.Int Int64.max_int) "ceil" [ V.Text "9223372036854775807" ]; c "non-numeric text has no answer" V.Null "ceil" [ V.Text "abc" ]; c "nor has a blob" V.Null "ceil" [ V.Blob "4" ]; (* a NULL argument is NULL for every one of them *) List.iter (fun name -> c (name ^ " of NULL") V.Null name [ V.Null ]) [ "sqrt"; "exp"; "ln"; "log10"; "log2"; "ceil"; "floor"; "trunc"; "sign" ]; c "pow with a NULL base" V.Null "pow" [ V.Null; vint 1 ]; c "pow with a NULL exponent" V.Null "pow" [ vint 1; V.Null ]
let test_math_table_is_complete () = let c what expected name args = Alcotest.check value what expected (apply name args) in c "mod is fmod, so it answers a real" (V.Float 2.) "mod" [ vint 5; vint 3 ]; c "over reals too" (V.Float 1.5) "mod" [ V.Float 5.5; vint 2 ]; c "keeping the sign of the dividend" (V.Float (-2.)) "mod" [ vint (-5); vint 3 ]; (* the digits sqlite3 printed, not a re-derivation of them: an identity that is exact in the reals (asinh 1 = ln(1 + sqrt 2)) lands one ulp away in doubles, and would let the wrong libm call pass *) c "sinh" (V.Float 1.1752011936438014) "sinh" [ V.Float 1. ]; c "cosh" (V.Float 1.5430806348152437) "cosh" [ V.Float 1. ]; c "tanh" (V.Float 0.76159415595576485) "tanh" [ V.Float 1. ]; c "asinh" (V.Float 0.88137358701954305) "asinh" [ V.Float 1. ]; c "acosh at its lower bound" (V.Float 0.) "acosh" [ V.Float 1. ]; c "atanh" (V.Float 0.54930614433405489) "atanh" [ V.Float 0.5 ]
let test_embedded_nul_cuts_text_short () = let nul = V.Text "A\000B" in let c what expected name args = Alcotest.check value what expected (apply name args) in c "length counts the C string's characters" (vint 1) "length" [ nul ]; c "quote renders the C string" (V.Text "'A'") "quote" [ nul ]; c "printf %s reads a C string" (V.Text "A") "printf" [ V.Text "%s"; nul ]; c "unicode has no first character before a NUL" V.Null "unicode" [ V.Text "\000A" ]; c "substr indexes the C string" (V.Text "") "substr" [ nul; vint 2; vint 2 ]; c "an empty pattern leaves replace's subject alone" nul "replace" [ nul; V.Text "\000"; V.Text "-" ]; (* and the byte string the value carries is untouched *) c "hex sees every byte" (V.Text "410042") "hex" [ nul ]; c "octet_length counts every byte" (vint 3) "octet_length" [ nul ]; c "upper keeps every byte" (V.Text "A\000B") "upper" [ V.Text "A\000b" ]; c "instr finds a byte past the NUL" (vint 3) "instr" [ nul; V.Text "B" ]; c "trim keeps every byte" nul "trim" [ nul ]; (* unhex reads its argument through the accessor as well (unhexFunc walks a C string), so the NUL and the bytes after it are not there to make the digit count odd: quote(unhex('41' || char(0))) -> X'41' *) c "unhex stops at the NUL rather than failing on it" (V.Blob "A") "unhex" [ V.Text "41\000" ]
let test_leading_prefix_coercion () = let c what expected name args = Alcotest.check value what expected (apply name args) in c "abs takes the number the text leads with" (V.Float 4.) "abs" [ V.Text "4x" ]; c "sign, exponent and surrounding space included" (V.Float 45.) "abs" [ V.Text " -4.5e1x " ]; c "text leading with no number is zero" (V.Float 0.) "abs" [ V.Text "abc" ]; c "and so is empty text" (V.Float 0.) "abs" [ V.Text "" ]; c "a bare fractional part still leads" (V.Float 0.5) "abs" [ V.Text ".5" ]; c "a blob is read as its bytes" (V.Float 4.) "abs" [ V.Blob "4u" ]; c "round coerces the same way" (V.Float 5.) "round" [ V.Text "4.6x" ]; c "and past a non-numeric tail" (V.Float 3.) "round" [ V.Text "2.7abc" ]; c "substr's offset too" (V.Text "ello") "substr" [ V.Text "hello"; V.Text "2x" ]; c "and char's code point" (V.Text "A") "char" [ V.Text "65x" ]; c "and zeroblob's length" (V.Blob "\000\000\000") "zeroblob" [ V.Text "3x" ]; c "and printf's numeric conversions" (V.Text "4.000000") "printf" [ V.Text "%f"; V.Text "4x" ]
let test_round_rounds_the_decimal () = let c what expected args = Alcotest.check value what expected (apply "round" args) in let f x = V.Float x in c "4.55 at one place rounds down" (f 4.5) [ f 4.55; vint 1 ]; c "2.675 at two places rounds down" (f 2.67) [ f 2.675; vint 2 ]; c "and the negative rounds towards zero" (f (-4.5)) [ f (-4.55); vint 1 ]; c "0.15 rounds down" (f 0.1) [ f 0.15; vint 1 ]; c "0.25 rounds up" (f 0.3) [ f 0.25; vint 1 ]; c "0.35 rounds down" (f 0.3) [ f 0.35; vint 1 ]; c "0.45 rounds up" (f 0.5) [ f 0.45; vint 1 ]; c "1.45 rounds down" (f 1.4) [ f 1.45; vint 1 ]; c "1.55 rounds up" (f 1.6) [ f 1.55; vint 1 ]; c "1.005 rounds down" (f 1.0) [ f 1.005; vint 2 ]; c "2.345 rounds up" (f 2.35) [ f 2.345; vint 2 ]; c "10.235 rounds down" (f 10.23) [ f 10.235; vint 2 ]; c "3.14159 at three places" (f 3.142) [ f 3.14159; vint 3 ]; c "-2.675 rounds towards zero" (f (-2.67)) [ f (-2.675); vint 2 ]; c "0.06 carries into the first place" (f 0.1) [ f 0.06; vint 1 ]; c "0.04 falls short of it" (f 0.0) [ f 0.04; vint 1 ]; c "9.99 carries out of the units digit" (f 10.0) [ f 9.99; vint 1 ]; c "9.95 rounds down" (f 9.9) [ f 9.95; vint 1 ]; (* the precision clamps *) c "a negative precision reads as zero" (f 5.0) [ f 4.55; vint (-1) ]; c "and one past thirty reads as thirty" (f 4.55) [ f 4.55; vint 40 ]; (* n = 0 keeps roundFunc's binary half-away-from-zero *) c "round(0.5)" (f 1.0) [ f 0.5 ]; c "round(1.5)" (f 2.0) [ f 1.5 ]; c "round(2.5)" (f 3.0) [ f 2.5 ]; c "round(-0.5)" (f (-1.0)) [ f (-0.5) ]; c "round(-1.5)" (f (-2.0)) [ f (-1.5) ]; (* past 2 ** 52 there is no fractional part left to round *) c "an infinity comes back whole" (f Float.infinity) [ f Float.infinity; vint 1 ]; c "and so does a large magnitude" (f 1e300) [ f 1e300; vint 2 ]; c "a whole value below 2 ** 52 still goes through the decimal" (f 1234567890123456.0) [ f 1234567890123456.0; vint 1 ]; c "keeping a fraction it does have" (f 1000000000000000.5) [ f 1000000000000000.5; vint 1 ]; c "and one past it is already whole" (f 9007199254740992.0) [ f 9007199254740993.0; vint 1 ]; (* NULL is contagious in either argument (roundFunc returns without setting a result), and the answer is always REAL: round(NULL,1) NULL round(4.55,NULL) NULL typeof(round(4.55,1)) real *) c "a NULL value" V.Null [ V.Null; vint 1 ]; c "a NULL precision" V.Null [ f 4.55; V.Null ]; Alcotest.check value "the answer is always a real" (V.Text "real") (apply "typeof" [ apply "round" [ vint 4; vint 1 ] ])
let test_unknown_and_overflow () = (* sqlite3 3.54.0 names an unresolved function the way it names an unresolved table or column: SELECT nofunc(1) -> no such function: nofunc *) Alcotest.check_raises "unknown scalar rejected" (Catalog.Error.Prepare "no such function: no_such_function") (fun () -> ignore (apply "no_such_function" [ vint 1 ])); Alcotest.check_raises "int64 min abs overflow rejected" (Failure "integer overflow") (fun () -> ignore (apply "abs" [ V.Int Int64.min_int ]))
let scalar_names = [ "abs"; "acos"; "acosh"; "asin"; "asinh"; "atan"; "atan2"; "atanh"; "ceil"; "ceiling"; "char"; "coalesce"; "concat"; "concat_ws"; "cos"; "cosh"; "current_date"; "current_time"; "current_timestamp"; "date"; "datetime"; "degrees"; "exp"; "floor"; "format"; "glob"; "hex"; "ifnull"; "iif"; "instr"; "json"; "json_array"; "json_array_length"; "json_extract"; "json_object"; "json_quote"; "json_type"; "json_valid"; "julianday"; "length"; "like"; "likelihood"; "likely"; "ln"; "log"; "log10"; "log2"; "lower"; "ltrim"; "max"; "min"; "mod"; "nullif"; "octet_length"; "pi"; "pow"; "power"; "printf"; "quote"; "radians"; "random"; "randomblob"; "replace"; "round"; "rtrim"; "sign"; "sin"; "sinh"; "sqrt"; "strftime"; "substr"; "tan"; "tanh"; "time"; "trim"; "trunc"; "typeof"; "unhex"; "unicode"; "unixepoch"; "unlikely"; "upper"; "zeroblob"; ]
let stateful_names = [ "changes"; "last_insert_rowid"; "sqlite_source_id"; "sqlite_version"; "total_changes"; ]
let test_exists () = List.iter (fun name -> Alcotest.(check bool) (Fmt.str "%s exists" name) true (Func.exists name)) (scalar_names @ stateful_names); List.iter (fun name -> Alcotest.(check bool) (Fmt.str "%s does not exist" name) false (Func.exists name)) [ "no_such_function"; "nosuchfunc"; "generate_series"; ""; "select" ]
(* A name resolves the way sqlite3 resolves one: case-insensitively (sqlite3FindFunction hashes the name folded to lower case). *)let test_exists_is_case_insensitive () = List.iter (fun name -> Alcotest.(check bool) (String.uppercase_ascii name) true (Func.exists (String.uppercase_ascii name))) (scalar_names @ stateful_names)
let test_apply_never_denies_a_name_that_exists () = List.iter (fun name -> let unknown = "no such function: " ^ name in let arity n = List.init n (fun i -> vint (i + 1)) in List.iter (fun n -> match apply name (arity n) with | _ -> () | exception (Failure m | Catalog.Error.Prepare m) -> Alcotest.(check bool) (Fmt.str "%s/%d: %s" name n m) false (String.equal m unknown)) [ 0; 1; 2; 3 ]) (scalar_names @ stateful_names)
(* A builtin this package does not evaluate refuses by saying that, not by denying the name -- a caller told "no such function: random" would go looking for a typo in a function sqlite3 answers. *)let test_stateful_builtins_refuse_by_name () = List.iter (fun name -> Alcotest.check_raises name (Fmt.kstr (fun s -> Catalog.Error.Prepare s) "function %s() is not supported yet" name) (fun () -> ignore (apply name []))) stateful_names
(* A name that exists at some arity and was applied at another is the other refusal, sqlite3's own wording. *)let test_wrong_arity_is_not_an_unknown_name () = Alcotest.check_raises "length of two arguments" (Catalog.Error.Prepare "wrong number of arguments to function length()") (fun () -> ignore (apply "length" [ vint 1; vint 2 ])); Alcotest.check_raises "abs of none" (Catalog.Error.Prepare "wrong number of arguments to function abs()") (fun () -> ignore (apply "abs" []))
let admitted_by_apply name nargs = let complaint = Fmt.str "wrong number of arguments to function %s()" name in match apply name (List.init nargs (fun _ -> V.Null)) with | _ -> true | exception Catalog.Error.Prepare m -> not (String.equal m complaint) | exception Failure _ -> true
let stated_divergences = [ "iif/3: takes says true, apply says false" ]
let test_takes_agrees_with_apply () = let counts = [ 0; 1; 2; 3; 4 ] in let disagreements name = let stated nargs = let takes = Func.takes name ~nargs in let applies = admitted_by_apply name nargs in if Bool.equal takes applies then None else Fmt.kstr (fun s -> Some s) "%s/%d: takes says %b, apply says %b" name nargs takes applies in List.filter_map stated counts in Alcotest.(check (list string)) "takes admits exactly the calls apply answers" stated_divergences (List.concat_map disagreements scalar_names)
let test_a_variadic_name_states_its_floor () = let resolves name nargs = Alcotest.(check bool) (Fmt.str "%s at %d arguments resolves" name nargs) true (Func.takes name ~nargs) in let refused_by_count name nargs = Alcotest.(check bool) (Fmt.str "%s at %d arguments does not" name nargs) false (Func.takes name ~nargs) in refused_by_count "coalesce" 0; refused_by_count "coalesce" 1; resolves "coalesce" 2; refused_by_count "concat" 0; resolves "concat" 1; refused_by_count "concat_ws" 0; refused_by_count "concat_ws" 1; resolves "concat_ws" 2; (* the tail with no floor keeps none *) List.iter (fun name -> resolves name 0) [ "char"; "date"; "format"; "json_array"; "json_object"; "printf" ]; (* and the refusal is the statement's, made in sqlite3's words before a row is read: a select with no FROM has none to read at all *) let cat = Catalog.of_mem [] in let refused name q = let msg = Fmt.str "wrong number of arguments to function %s()" name in Alcotest.check_raises q (Catalog.Error.Prepare msg) (fun () -> ignore (Sql.Engine.exec cat q)) in refused "coalesce" "SELECT coalesce()"; refused "coalesce" "SELECT coalesce(1)"; refused "concat" "SELECT concat()"; refused "concat_ws" "SELECT concat_ws('-')"; let answers q = match Sql.Engine.exec cat q with | Sql.Engine.Rows [ [ v ] ] -> v | _ -> Alcotest.failf "%s: expected one row of one column" q in Alcotest.check value "a count the name does take still answers" (vint 1) (answers "SELECT coalesce(NULL, 1)"); Alcotest.check value "and a name with no floor answers at none" (V.Text "") (answers "SELECT char()")
let blob = function | V.Blob s -> s | v -> Alcotest.failf "expected a blob, got %a" V.pp v
let test_randomblob () = let len v = String.length (blob (apply "randomblob" [ v ])) in Alcotest.(check int) "N bytes" 16 (len (vint 16)); Alcotest.(check int) "one byte at N = 1" 1 (len (vint 1)); Alcotest.(check int) "N below 1 floors at one byte" 1 (len (vint 0)); Alcotest.(check int) "a negative N floors too" 1 (len (vint (-3))); Alcotest.(check int) "NULL coerces to zero, so one byte" 1 (len V.Null); Alcotest.(check int) "a real N truncates" 2 (len (V.Float 2.7)); Alcotest.(check int) "a text N reads its leading number" 5 (len (V.Text "5")); (* Random, not a constant: two draws of 32 bytes collide with probability 2^-256, and 64 bytes of one repeated value with probability 2^-504. A zeroblob-shaped stub fails both. *) let a = blob (apply "randomblob" [ vint 32 ]) in let b = blob (apply "randomblob" [ vint 32 ]) in Alcotest.(check bool) "two draws differ" true (not (String.equal a b)); let wide = blob (apply "randomblob" [ vint 64 ]) in Alcotest.(check bool) "the bytes of one draw are not all equal" true (String.exists (fun c -> not (Char.equal c wide.[0])) wide)
let test_random () = let draw () = match apply "random" [] with | V.Int i -> i | v -> Alcotest.failf "expected an integer, got %a" V.pp v in let draws = List.init 64 (fun _ -> draw ()) in Alcotest.(check bool) "64 draws are not all one value" true (List.exists (fun i -> not (Int64.equal i (List.hd draws))) draws); (* Signed, not the 63 bits a non-negative generator would give: 64 draws all of one sign happen with probability 2^-63. *) Alcotest.(check bool) "both signs are reachable" true (List.exists (fun i -> Int64.compare i 0L < 0) draws && List.exists (fun i -> Int64.compare i 0L >= 0) draws); Alcotest.check_raises "no argument takes one" (Catalog.Error.Prepare "wrong number of arguments to function random()") (fun () -> ignore (apply "random" [ vint 1 ]))
(* A date function is deterministic where its arguments say nothing about the machine, and reaches the clock where they do -- which is what a stored expression is refused for, and what sqlite3 tests on the whole string, case-folded (sqlite/src/date.c). *)let test_reads_the_clock () = let clock name args = Alcotest.(check bool) (Fmt.str "%s reads the clock" name) true (Func.reads_the_clock name args) in let fixed name args = Alcotest.(check bool) (Fmt.str "%s does not" name) false (Func.reads_the_clock name args) in clock "julianday" [ V.Text "now" ]; clock "JULIANDAY" [ V.Text "NOW" ]; clock "date" [ V.Text "subsec" ]; clock "date" [ V.Text "subsecond" ]; clock "datetime" [ V.Text "2020-01-01"; V.Text "localtime" ]; clock "datetime" [ V.Text "2020-01-01"; V.Text "utc" ]; clock "julianday" []; clock "strftime" [ V.Text "%Y" ]; fixed "strftime" [ V.Text "%Y"; V.Text "2020-01-01" ]; fixed "julianday" [ V.Text "2020-01-01" ]; fixed "date" [ vint 1 ]; fixed "date" [ V.Null ]; (* sqlite3 compares the whole string, so a modifier written with spaces around it is not one of these to it either. *) fixed "datetime" [ V.Text "2020-01-01"; V.Text " utc " ]; fixed "date" [ V.Text " now " ]; (* Only the date functions can: random() changes between calls and nothing is decided by asking it again. *) fixed "random" []; fixed "randomblob" [ vint 1 ]; fixed "abs" [ V.Text "now" ]
(* The nine names a clock answers, and the clock reaching each of them. Every value below is what the sqlite3 CLI 3.54.0 returns for the same instant, spelled to it as a unix epoch it can be handed: what [datetime(1786968000,'unixepoch')] answers there is what [datetime('now')] answers on a machine whose clock reads that instant. *)let test_date_call () = let instant = 1786968000_000L in let at ?zone name args = match Func.date_call ~now:instant ?zone name with | Some f -> f args | None -> Alcotest.failf "%s names no date function" name in let now = [ V.Text "now" ] in Alcotest.check value "datetime('now')" (V.Text "2026-08-17 12:00:00") (at "datetime" now); Alcotest.check value "date('now')" (V.Text "2026-08-17") (at "date" now); Alcotest.check value "time('now')" (V.Text "12:00:00") (at "time" now); Alcotest.check value "julianday('now')" (V.Float 2461270.0) (at "julianday" now); Alcotest.check value "unixepoch('now')" (V.Int 1786968000L) (at "unixepoch" now); Alcotest.check value "strftime('%Y-%m','now')" (V.Text "2026-08") (at "strftime" [ V.Text "%Y-%m"; V.Text "now" ]); (* The keywords are the like-named function over 'now', so the one clock answers all three (sqlite/src/date.c: ctimestampFunc calls datetimeFunc). *) Alcotest.check value "CURRENT_TIMESTAMP" (V.Text "2026-08-17 12:00:00") (at "current_timestamp" []); Alcotest.check value "CURRENT_DATE" (V.Text "2026-08-17") (at "current_date" []); Alcotest.check value "CURRENT_TIME" (V.Text "12:00:00") (at "current_time" []); (* The zone is seconds east of UTC, which 'localtime' adds and 'utc' subtracts. sqlite3 under TZ=Europe/Paris in August answers these three: 'utc' is a no-op on a value already carrying one, which the clock's own reading is, and turns a spelled-out local time into UTC. *) let east2 _ = 7200 in Alcotest.check value "localtime adds the offset" (V.Text "2026-08-17 14:00:00") (at ~zone:east2 "datetime" [ V.Text "now"; V.Text "localtime" ]); Alcotest.check value "utc leaves the clock's own reading" (V.Text "2026-08-17 12:00:00") (at ~zone:east2 "datetime" [ V.Text "now"; V.Text "utc" ]); Alcotest.check value "and subtracts it from a local time" (V.Text "2026-08-17 10:00:00") (at ~zone:east2 "datetime" [ V.Text "2026-08-17 12:00:00"; V.Text "utc" ]); (* The option is the name test, and it folds case like every other lookup here. A keyword takes no argument, so any is a wrong count. *) Alcotest.(check bool) "a scalar is no date function" true (Option.is_none (Func.date_call "abs")); Alcotest.(check bool) "nor is a name of nothing" true (Option.is_none (Func.date_call "wat")); Alcotest.(check bool) "and the name folds" true (Option.is_some (Func.date_call "DATETIME")); Alcotest.check_raises "CURRENT_TIMESTAMP takes no argument" (Catalog.Error.Prepare "wrong number of arguments to function current_timestamp()") (fun () -> ignore (at "current_timestamp" [ vint 1 ])); (* With no clock injected the same nine answer what {!Func.apply} answers: 'now' is NULL rather than a guess, and the zone modifiers are the no-ops the CLI performs under TZ=UTC. *) let clockless name args = match Func.date_call name with | Some f -> f args | None -> Alcotest.failf "%s names no date function" name in Alcotest.check value "'now' with no clock is NULL" V.Null (clockless "datetime" now); Alcotest.check value "and so is the keyword over it" V.Null (clockless "current_timestamp" []); Alcotest.check value "which is what apply answers" V.Null (apply "current_timestamp" []); Alcotest.check value "a spelled-out time still answers" (V.Text "2020-01-01 00:00:00") (clockless "datetime" [ V.Text "2020-01-01"; V.Text "utc" ])
let suite = ( "func", [ Alcotest.test_case "scalar basics" `Quick test_scalar_basics; Alcotest.test_case "coalesce and nullif" `Quick test_null_funcs; Alcotest.test_case "text edge cases" `Quick test_text_edges; Alcotest.test_case "randomblob" `Quick test_randomblob; Alcotest.test_case "random" `Quick test_random; Alcotest.test_case "a call that reads the clock" `Quick test_reads_the_clock; Alcotest.test_case "the date functions under an injected clock" `Quick test_date_call; Alcotest.test_case "substr coerces its bounds" `Quick test_substr_coerces_bounds; Alcotest.test_case "json edge cases" `Quick test_json_edges; Alcotest.test_case "table-function edge cases" `Quick test_table_function_edges; Alcotest.test_case "CVE-style format edges" `Quick test_cve_format_edges; Alcotest.test_case "binary and unicode edges" `Quick test_binary_and_unicode_edges; Alcotest.test_case "unknown and overflow" `Quick test_unknown_and_overflow; Alcotest.test_case "a name exists or it does not" `Quick test_exists; Alcotest.test_case "a name resolves case-insensitively" `Quick test_exists_is_case_insensitive; Alcotest.test_case "apply never denies a name that exists" `Quick test_apply_never_denies_a_name_that_exists; Alcotest.test_case "a builtin we do not answer refuses by name" `Quick test_stateful_builtins_refuse_by_name; Alcotest.test_case "a wrong arity is not an unknown name" `Quick test_wrong_arity_is_not_an_unknown_name; Alcotest.test_case "takes states the arities apply answers" `Quick test_takes_agrees_with_apply; Alcotest.test_case "a variadic name states its floor" `Quick test_a_variadic_name_states_its_floor; Alcotest.test_case "math: a non-finite answer" `Quick test_math_non_finite; Alcotest.test_case "math: the numeric gate" `Quick test_math_numeric_gate; Alcotest.test_case "math: the whole table" `Quick test_math_table_is_complete; Alcotest.test_case "an embedded NUL cuts text short" `Quick test_embedded_nul_cuts_text_short; Alcotest.test_case "the leading-prefix coercion" `Quick test_leading_prefix_coercion; Alcotest.test_case "round rounds the decimal" `Quick test_round_rounds_the_decimal; ] )