MODULE SQLiteCallback;
(* Callback support:
   sqlite3_exec row callbacks, scalar SQL functions and the
   sqlite3_value_* / sqlite3_result_* families. *)

FROM SYSTEM IMPORT ADDRESS, ADR;
FROM CStr IMPORT CString, Copy;
FROM SQLite IMPORT
  SQLiteOk, SQLiteRow, SQLiteDone, SQLiteAbort,
  SQLiteInteger, SQLiteFloat, SQLiteText, SQLiteBlob, SQLiteNull,
  SQLiteUtf8, SQLiteDeterministic,
  SQLiteOpenReadWrite, SQLiteOpenCreate, SQLiteOpenMemory,
  sqlite3_open_v2, sqlite3_exec, sqlite3_close_v2,
  sqlite3_prepare_v2, sqlite3_step,
  sqlite3_column_int, sqlite3_column_int64, sqlite3_column_double,
  sqlite3_column_text, sqlite3_finalize,
  sqlite3_errmsg, sqlite3_free,
  sqlite3_create_function_v2,
  sqlite3_value_type, sqlite3_value_int, sqlite3_value_int64,
  sqlite3_value_double, sqlite3_value_text, sqlite3_value_blob,
  sqlite3_value_bytes,
  sqlite3_result_null, sqlite3_result_int, sqlite3_result_int64,
  sqlite3_result_double, sqlite3_result_text, sqlite3_result_blob,
  sqlite3_result_error, sqlite3_result_error_code,
  sqlite3_user_data, sqlite3_context_db_handle,
  SQLiteArrayAt, SQLiteTransient;

VAR
  ExitCode : INTEGER;
  db : ADDRESS;
  cbRows, rc : INTEGER;
  cbBad : BOOLEAN;
  errmsg : ADDRESS;
  ok : BOOLEAN;
  bin : ARRAY [0..7] OF CHAR;

PROCEDURE SameText (a, b : ARRAY OF CHAR) : BOOLEAN;
VAR
  i : INTEGER;
BEGIN
  i := 0;
  WHILE (a[i] # CHR(0)) AND (a[i] = b[i]) DO
    i := i + 1
  END;
  RETURN (a[i] = CHR(0)) AND (b[i] = CHR(0))
END SameText;

(* sqlite3_exec row callback. *)
PROCEDURE RowCb (arg : ADDRESS; argc : INTEGER;
                 argv, colNames : ADDRESS) : INTEGER;
VAR
  value, name : CString;
  vbuf, nbuf : ARRAY [0..7] OF CHAR;
BEGIN
  IF (argc = 1) AND (arg = ADR(cbRows)) THEN
    value := SQLiteArrayAt(argv, 0);
    name := SQLiteArrayAt(colNames, 0);
    IF (value # NIL) AND (name # NIL)
       AND (Copy(value, vbuf) > 0) AND (Copy(name, nbuf) > 0) THEN
      IF ((vbuf[0] = '1') OR (vbuf[0] = '2')) AND (nbuf[0] = 'n') THEN
        cbRows := cbRows + 1
      ELSE
        cbBad := TRUE
      END
    ELSE
      cbBad := TRUE
    END
  ELSE
    cbBad := TRUE
  END;
  RETURN 0
END RowCb;

(* Scalar SQL function callbacks. *)
PROCEDURE AddFn (ctx : ADDRESS; argc : INTEGER; argv : ADDRESS);
BEGIN
  IF argc = 2 THEN
    sqlite3_result_int(ctx,
      sqlite3_value_int(SQLiteArrayAt(argv, 0))
      + sqlite3_value_int(SQLiteArrayAt(argv, 1)))
  ELSE
    sqlite3_result_error(ctx, "m2_add expects 2 arguments", -1)
  END
END AddFn;

PROCEDURE MixFn (ctx : ADDRESS; argc : INTEGER; argv : ADDRESS);
VAR
  v : ADDRESS;
  s : CString;
  buf : ARRAY [0..7] OF CHAR;
  n : CARDINAL;
  good : BOOLEAN;
BEGIN
  good := FALSE;
  IF argc = 4 THEN
    v := SQLiteArrayAt(argv, 0);
    good := (sqlite3_value_type(v) = SQLiteInteger)
            AND (sqlite3_value_int(v) = 7)
            AND (sqlite3_value_int64(v) = 7);

    v := SQLiteArrayAt(argv, 1);
    good := good AND (sqlite3_value_type(v) = SQLiteFloat)
            AND (sqlite3_value_double(v) = 8.5);

    v := SQLiteArrayAt(argv, 2);
    s := sqlite3_value_text(v);
    n := Copy(s, buf);
    good := good AND (sqlite3_value_type(v) = SQLiteText)
            AND (sqlite3_value_bytes(v) = 2)
            AND (n = 2) AND (buf[0] = 'h') AND (buf[1] = 'i');

    v := SQLiteArrayAt(argv, 3);
    good := good AND (sqlite3_value_type(v) = SQLiteNull)
  END;
  IF good THEN
    sqlite3_result_int(ctx, 42)
  ELSE
    sqlite3_result_error(ctx, "m2_mix bad arguments", -1)
  END
END MixFn;

PROCEDURE EchoFn (ctx : ADDRESS; argc : INTEGER; argv : ADDRESS);
VAR
  v : ADDRESS;
  s : CString;
  buf : ARRAY [0..63] OF CHAR;
  n : CARDINAL;
BEGIN
  IF argc = 1 THEN
    v := SQLiteArrayAt(argv, 0);
    IF sqlite3_value_type(v) = SQLiteText THEN
      s := sqlite3_value_text(v);
      n := Copy(s, buf);
      sqlite3_result_text(ctx, buf, INTEGER(n), SQLiteTransient())
    ELSE
      sqlite3_result_null(ctx)
    END
  ELSE
    sqlite3_result_error(ctx, "m2_echo expects 1 argument", -1)
  END
END EchoFn;

PROCEDURE NullFn (ctx : ADDRESS; argc : INTEGER; argv : ADDRESS);
BEGIN
  sqlite3_result_null(ctx)
END NullFn;

PROCEDURE Int64Fn (ctx : ADDRESS; argc : INTEGER; argv : ADDRESS);
BEGIN
  IF argc = 1 THEN
    sqlite3_result_int64(ctx,
      sqlite3_value_int64(SQLiteArrayAt(argv, 0)))
  ELSE
    sqlite3_result_error(ctx, "m2_int64 expects 1 argument", -1)
  END
END Int64Fn;

PROCEDURE DoubleFn (ctx : ADDRESS; argc : INTEGER; argv : ADDRESS);
BEGIN
  IF argc = 1 THEN
    sqlite3_result_double(ctx,
      sqlite3_value_double(SQLiteArrayAt(argv, 0)))
  ELSE
    sqlite3_result_error(ctx, "m2_double expects 1 argument", -1)
  END
END DoubleFn;

PROCEDURE BlobFn (ctx : ADDRESS; argc : INTEGER; argv : ADDRESS);
BEGIN
  sqlite3_result_blob(ctx, ADR(bin[0]), 3, SQLiteTransient())
END BlobFn;

PROCEDURE BlobLenFn (ctx : ADDRESS; argc : INTEGER; argv : ADDRESS);
VAR
  v, p : ADDRESS;
BEGIN
  IF argc = 1 THEN
    v := SQLiteArrayAt(argv, 0);
    p := sqlite3_value_blob(v);
    IF (sqlite3_value_type(v) = SQLiteBlob) AND (p # NIL) THEN
      sqlite3_result_int(ctx, sqlite3_value_bytes(v))
    ELSE
      sqlite3_result_error(ctx, "m2_blob_len expects a BLOB", -1)
    END
  ELSE
    sqlite3_result_error(ctx, "m2_blob_len expects 1 argument", -1)
  END
END BlobLenFn;

PROCEDURE DataFn (ctx : ADDRESS; argc : INTEGER; argv : ADDRESS);
BEGIN
  IF (sqlite3_user_data(ctx) = ADR(db))
     AND (sqlite3_context_db_handle(ctx) = db) THEN
    sqlite3_result_int(ctx, 1)
  ELSE
    sqlite3_result_int(ctx, 0)
  END
END DataFn;

PROCEDURE FailFn (ctx : ADDRESS; argc : INTEGER; argv : ADDRESS);
BEGIN
  sqlite3_result_error(ctx, "m2_fail", -1);
  sqlite3_result_error_code(ctx, SQLiteAbort)
END FailFn;

PROCEDURE QueryInt (sql : ARRAY OF CHAR; want : INTEGER) : BOOLEAN;
VAR
  stmt : ADDRESS;
  rc, got : INTEGER;
  ok : BOOLEAN;
BEGIN
  stmt := NIL; got := -777; ok := FALSE;
  rc := sqlite3_prepare_v2(db, sql, -1, stmt, NIL);
  IF (rc = SQLiteOk) AND (stmt # NIL) THEN
    IF sqlite3_step(stmt) = SQLiteRow THEN
      got := sqlite3_column_int(stmt, 0);
      IF sqlite3_step(stmt) = SQLiteDone THEN ok := TRUE END
    END;
    IF sqlite3_finalize(stmt) # SQLiteOk THEN ok := FALSE END
  END;
  RETURN ok AND (got = want)
END QueryInt;

PROCEDURE QueryInt64 (sql : ARRAY OF CHAR; want : LONGINT) : BOOLEAN;
VAR
  stmt : ADDRESS;
  rc : INTEGER;
  got : LONGINT;
  ok : BOOLEAN;
BEGIN
  stmt := NIL; got := -777; ok := FALSE;
  rc := sqlite3_prepare_v2(db, sql, -1, stmt, NIL);
  IF (rc = SQLiteOk) AND (stmt # NIL) THEN
    IF sqlite3_step(stmt) = SQLiteRow THEN
      got := sqlite3_column_int64(stmt, 0);
      IF sqlite3_step(stmt) = SQLiteDone THEN ok := TRUE END
    END;
    IF sqlite3_finalize(stmt) # SQLiteOk THEN ok := FALSE END
  END;
  RETURN ok AND (got = want)
END QueryInt64;

PROCEDURE QueryDouble (sql : ARRAY OF CHAR; want : REAL) : BOOLEAN;
VAR
  stmt : ADDRESS;
  rc : INTEGER;
  got : REAL;
  ok : BOOLEAN;
BEGIN
  stmt := NIL; got := -777.0; ok := FALSE;
  rc := sqlite3_prepare_v2(db, sql, -1, stmt, NIL);
  IF (rc = SQLiteOk) AND (stmt # NIL) THEN
    IF sqlite3_step(stmt) = SQLiteRow THEN
      got := sqlite3_column_double(stmt, 0);
      IF sqlite3_step(stmt) = SQLiteDone THEN ok := TRUE END
    END;
    IF sqlite3_finalize(stmt) # SQLiteOk THEN ok := FALSE END
  END;
  RETURN ok AND (got = want)
END QueryDouble;

PROCEDURE QueryText (sql : ARRAY OF CHAR; want : ARRAY OF CHAR) : BOOLEAN;
VAR
  stmt : ADDRESS;
  rc : INTEGER;
  s : CString;
  buf : ARRAY [0..63] OF CHAR;
  ok : BOOLEAN;
BEGIN
  stmt := NIL; ok := FALSE;
  rc := sqlite3_prepare_v2(db, sql, -1, stmt, NIL);
  IF (rc = SQLiteOk) AND (stmt # NIL) THEN
    IF sqlite3_step(stmt) = SQLiteRow THEN
      s := sqlite3_column_text(stmt, 0);
      IF (s # NIL) AND (Copy(s, buf) > 0) THEN
        ok := SameText(buf, want)
      END;
      IF sqlite3_step(stmt) # SQLiteDone THEN ok := FALSE END
    END;
    IF sqlite3_finalize(stmt) # SQLiteOk THEN ok := FALSE END
  END;
  RETURN ok
END QueryText;

PROCEDURE QueryFails (sql : ARRAY OF CHAR) : BOOLEAN;
VAR
  stmt : ADDRESS;
  rc : INTEGER;
  s : CString;
  buf : ARRAY [0..63] OF CHAR;
  ok : BOOLEAN;
BEGIN
  stmt := NIL; ok := FALSE;
  rc := sqlite3_prepare_v2(db, sql, -1, stmt, NIL);
  IF (rc = SQLiteOk) AND (stmt # NIL) THEN
    IF sqlite3_step(stmt) = SQLiteAbort THEN
      s := sqlite3_errmsg(db);
      IF (s # NIL) AND (Copy(s, buf) > 0)
         AND SameText(buf, "m2_fail") THEN
        ok := TRUE
      END
    END;
    rc := sqlite3_finalize(stmt)
  END;
  RETURN ok
END QueryFails;

PROCEDURE Register (name : ARRAY OF CHAR;
                    nArgs : INTEGER;
                    userData, fn : ADDRESS) : BOOLEAN;
BEGIN
  RETURN sqlite3_create_function_v2(db, name, nArgs,
    SQLiteUtf8 + SQLiteDeterministic, userData, fn, NIL, NIL, NIL)
    = SQLiteOk
END Register;

BEGIN
  ExitCode := 1;
  db := NIL; cbRows := 0; cbBad := FALSE;
  bin[0] := CHR(0); bin[1] := CHR(1); bin[2] := CHR(2);
  bin[3] := CHR(0); bin[4] := CHR(255);

  IF (sqlite3_open_v2(":memory:", db,
        SQLiteOpenReadWrite + SQLiteOpenCreate + SQLiteOpenMemory,
        NIL) = SQLiteOk) AND (db # NIL) THEN
    IF Register("m2_add", 2, NIL, ADR(AddFn))
       AND Register("m2_mix", 4, NIL, ADR(MixFn))
       AND Register("m2_echo", 1, NIL, ADR(EchoFn))
       AND Register("m2_null", 0, NIL, ADR(NullFn))
       AND Register("m2_int64", 1, NIL, ADR(Int64Fn))
       AND Register("m2_double", 1, NIL, ADR(DoubleFn))
       AND Register("m2_blob", 0, NIL, ADR(BlobFn))
       AND Register("m2_blob_len", 1, NIL, ADR(BlobLenFn))
       AND Register("m2_hasdata", 0, ADR(db), ADR(DataFn))
       AND Register("m2_fail", 0, NIL, ADR(FailFn)) THEN
      ok := TRUE
    ELSE
      ok := FALSE
    END
  END;

  IF ok THEN ok := QueryInt("SELECT m2_add(20, 22);", 42) END;
  IF ok THEN
    ok := QueryInt("SELECT m2_mix(7, 8.5, 'hi', NULL);", 42)
  END;
  IF ok THEN ok := QueryText("SELECT m2_echo('hello');", "hello") END;
  IF ok THEN ok := QueryInt("SELECT m2_echo(NULL) IS NULL;", 1) END;
  IF ok THEN ok := QueryInt("SELECT m2_null() IS NULL;", 1) END;
  IF ok THEN ok := QueryInt64("SELECT m2_int64(42);", 42) END;
  IF ok THEN ok := QueryDouble("SELECT m2_double(3.5);", 3.5) END;
  IF ok THEN ok := QueryText("SELECT hex(m2_blob());", "000102") END;
  IF ok THEN
    ok := QueryInt("SELECT m2_blob_len(zeroblob(3));", 3)
  END;
  IF ok THEN ok := QueryInt("SELECT m2_hasdata();", 1) END;
  IF ok THEN ok := QueryFails("SELECT m2_fail();") END;

  IF ok THEN
    cbRows := 0; cbBad := FALSE; errmsg := NIL;
    rc := sqlite3_exec(db, "SELECT 1 AS n UNION ALL SELECT 2;",
                       ADR(RowCb), ADR(cbRows), errmsg);
    ok := (rc = SQLiteOk) AND (NOT cbBad) AND (cbRows = 2);
    IF errmsg # NIL THEN
      sqlite3_free(errmsg);
      errmsg := NIL
    END
  END;

  IF db # NIL THEN
    IF sqlite3_close_v2(db) # SQLiteOk THEN ok := FALSE END
  END;
  IF ok THEN ExitCode := 42 END
END SQLiteCallback.