MODULE SqlDB;
(**
project = "BlackBox"
organization = "www.oberon.ch"
contributors = "Oberon microsystems"
version = "System/Rsrc/About"
copyright = "System/Rsrc/About"
license = "Docu/BB-License"
changes = ""
issues = ""
**)
IMPORT SYSTEM, Kernel, Log, Strings, Dates, Meta, Dialog, Services, SqlDrivers;
(*
The following framework-defined types are handled by this module, in
addition to the data types of the language itself:
Dialog.Currency
Dialog.List
Dialog.Combo
Dates.Date
Dates.Time
SqlDB.Blob
*)
CONST
names* = -1; types = -2;
converted* = 1; truncated* = 2; overflow* = 3; incompatible* = 4; noData* = 5;
sync* = FALSE; async* = TRUE;
showErrors* = TRUE; hideErrors* = FALSE;
readOp = -10; clearOp = -11; openOp = -12; beginOp = -13; endOp = -14;
commitOp = -15; rollbackOp = -16; callOp = -17; tcallOp = -18;
update = 2; guardCheck = 4;
varLen = 48;
maxOperations = 20;
TYPE
Database* = POINTER TO ABSTRACT RECORD
res*: INTEGER;
async*: BOOLEAN;
showErrors*: BOOLEAN
END;
Table* = POINTER TO ABSTRACT RECORD
base-: Database;
rows*, columns*: INTEGER;
res*: INTEGER;
strictNotify*: BOOLEAN (* strict notification *)
END;
String* = POINTER TO ARRAY OF CHAR;
Row* = RECORD
fields*: POINTER TO ARRAY OF String;
END;
Blob* = RECORD
len*: INTEGER;
data*: POINTER TO ARRAY OF BYTE (* not 0X terminated **)
END;
Command* = PROCEDURE (p: ANYPTR);
TableCommand* = PROCEDURE (t: Table; p: ANYPTR);
Range = POINTER TO RECORD (* list of pending update notifications *)
next: Range;
adr0, adr1: INTEGER (* address range belonging to an interactor that has been modified *)
END;
StdDatabase = POINTER TO RECORD (Database)
queue: Elem; (* list of tasks *)
tail: Elem; (* first element of low priority part in queue *)
range: Range; (* list of pending notifications *)
lastRange: Range; (* the last element in the list of ranges - allows for search optimization *)
action: Action; (* action which executes queue elements & ranges *)
id: INTEGER; (* timestamp of actually executing command *)
executing: BOOLEAN;
driver: SqlDrivers.Driver
END;
StdTable = POINTER TO RECORD (Table)
table: SqlDrivers.Table; (* current result table *)
db: StdDatabase; (* = base(StdDatabase) *)
srows: INTEGER; (* safe copy of rows *)
id: INTEGER (* table creation id *)
END;
Elem = POINTER TO RECORD (* async operations are put into queues of such elements *)
next: Elem; (* list of tasks *)
op: INTEGER;
table: StdTable;
statement: String;
item: Meta.Item;
cmd: Command;
tcmd: TableCommand;
par: ANYPTR
END;
Action = POINTER TO RECORD (Services.Action)
database: StdDatabase (* database # NIL *)
END;
Statement = RECORD (* representation of one SQL statement *)
buf: ARRAY 1024 OF CHAR; (* valid if idx < LEN(buf) *)
ext: String; (* valid if idx >= LEN(buf) *)
idx: INTEGER; (* actual length without 0X *)
blobs, last: SqlDrivers.Blob (* blob parameters *)
END;
CurrencyValue = RECORD (Meta.Value)
value: Dialog.Currency
END;
DateValue = RECORD (Meta.Value)
value: Dates.Date
END;
TimeValue = RECORD (Meta.Value)
value: Dates.Time
END;
StringValue = RECORD (Meta.Value)
value: String
END;
BlobValue = RECORD (Meta.Value)
value: Blob
END;
RowValue = RECORD (Meta.Value)
value: Row
END;
VAR
debug*: BOOLEAN;
dummy: Meta.Item; (* remains undefined *)
ptr: POINTER TO RECORD END; (* used for ptr field in contructed items *)
nullStr: ARRAY 5 OF CHAR;
(* error handling *)
PROCEDURE WriteString (s: ARRAY OF CHAR);
BEGIN
IF debug THEN Log.String(s); Log.Ln END
END WriteString;
(** Table interface **)
PROCEDURE (t: Table) InitBase* (base: Database), NEW;
BEGIN
ASSERT(base # NIL, 20); ASSERT((t.base = NIL) OR (t.base = base), 21);
t.base := base
END InitBase;
PROCEDURE (t: Table) Exec* (statement: ARRAY OF CHAR), NEW, ABSTRACT;
PROCEDURE (t: Table) Available* (): BOOLEAN, NEW, ABSTRACT;
PROCEDURE (t: Table) Read* (row: INTEGER; VAR data: ANYREC), NEW, ABSTRACT;
PROCEDURE (t: Table) Clear*, NEW, ABSTRACT;
PROCEDURE (t: Table) Call* (command: TableCommand; par: ANYPTR), NEW, ABSTRACT;
(** Database interface **)
PROCEDURE (d: Database) Exec* (statement: ARRAY OF CHAR), NEW, ABSTRACT;
PROCEDURE (d: Database) Commit*, NEW, ABSTRACT;
PROCEDURE (d: Database) Rollback*, NEW, ABSTRACT;
PROCEDURE (d: Database) Call* (command: Command; par: ANYPTR), NEW, ABSTRACT;
PROCEDURE (d: Database) NewTable* (): Table, NEW, ABSTRACT;
(* statement expansion *)
PROCEDURE ReadPath (IN s: ARRAY OF CHAR; OUT t: ARRAY OF CHAR; VAR i: INTEGER; VAR ch: CHAR);
VAR j: INTEGER;
BEGIN (* extract the designator that describes a global variable *)
j := 0;
IF (CAP(ch) >= "A") & (CAP(ch) < "Z") THEN
REPEAT
t[j] := ch; INC(j);
INC(i); ch := s[i]
UNTIL (ch < "0") & (ch # ".") OR ("9" < ch) & (CAP(ch) < "A") OR ("Z" < CAP(ch)) & (ch # "_") OR (j = varLen)
END;
t[j] := 0X
END ReadPath;
PROCEDURE AddStr (IN s: ARRAY OF CHAR; native: BOOLEAN; max: INTEGER; VAR t: Statement);
VAR i, len: INTEGER; e: String; ch: CHAR;
BEGIN (* append a string to a statement *)
IF (t.idx + max < LEN(t.buf)) & (t.ext = NIL) THEN
i := 0; ch := s[0];
WHILE (i < max) & (ch # 0X) DO
t.buf[t.idx] := ch; INC(t.idx);
IF (ch = "'") & ~native THEN t.buf[t.idx] := "'"; INC(t.idx) END;
INC(i); ch := s[i]
END
ELSE
IF t.ext = NIL THEN
len := LEN(t.buf); REPEAT len := len * 4 UNTIL t.idx + max < len;
NEW(t.ext, len); t.buf[t.idx] := 0X; t.ext^ := t.buf$
ELSIF t.idx + max >= LEN(t.ext^) THEN
len := LEN(t.ext^); REPEAT len := len * 4 UNTIL t.idx + max < len;
NEW(e, len); t.ext[t.idx] := 0X; e^ := t.ext^$; t.ext := e
END;
i := 0; ch := s[0];
WHILE (i < max) & (ch # 0X) DO
t.ext[t.idx] := ch; INC(t.idx);
IF (ch = "'") & ~native THEN t.ext[t.idx] := "'"; INC(t.idx) END;
INC(i); ch := s[i]
END
END
END AddStr;
PROCEDURE AddChar (ch: CHAR; VAR t: Statement);
VAR e: String;
BEGIN (* append a character to a statement *)
IF (t.idx < LEN(t.buf) - 1) & (t.ext = NIL) THEN
t.buf[t.idx] := ch; INC(t.idx)
ELSE
IF t.ext = NIL THEN
NEW(t.ext, 4 * LEN(t.buf)); t.buf[t.idx] := 0X; t.ext^ := t.buf$
ELSIF t.idx = LEN(t.ext^) - 1 THEN
NEW(e, 4 * LEN(t.ext^)); t.ext[t.idx] := 0X; e^ := t.ext^$; t.ext := e
END;
t.ext[t.idx] := ch; INC(t.idx)
END
END AddChar;
PROCEDURE RealToString (x: SHORTREAL; minPrec: SHORTINT; OUT s: ARRAY OF CHAR);
VAR y: REAL; res: INTEGER;
BEGIN
(* find the shortest string that can represent the number as a string *)
(* this is a hack to avoid conversion problems between binary and textual representations *)
REPEAT
Strings.RealToStringForm(x, minPrec, 0, 0, " ", s);
Strings.StringToReal(s, y, res);
INC(minPrec)
UNTIL x = SHORT(y)
END RealToString;
PROCEDURE LongToString (x: LONGINT; scale: INTEGER; OUT s: ARRAY OF CHAR);
VAR d: ARRAY 24 OF CHAR; i, j: INTEGER;
BEGIN
i := 0; j := 0;
IF x < 0 THEN s[0] := "-"; i := 1; x := -x END;
REPEAT d[j] := CHR(x MOD 10 + ORD("0")); INC(j); x := x DIV 10 UNTIL x = 0;
WHILE j <= scale DO d[j] := "0"; INC(j) END;
WHILE j > scale DO DEC(j); s[i] := d[j]; INC(i) END;
IF j > 0 THEN s[i] := "."; INC(i) END;
WHILE j > 0 DO DEC(j); s[i] := d[j]; INC(i) END;
s[i] := 0X
END LongToString;
PROCEDURE AddItem (d: StdDatabase; item: Meta.Item; native: BOOLEAN; VAR s: Statement);
TYPE Ptr = POINTER TO ARRAY [1] MAX(INTEGER) DIV 2 OF CHAR;
VAR base: Meta.Item; ok: BOOLEAN; i, len, res: INTEGER; h: ARRAY 64 OF CHAR;
mod, typ: Meta.Name; dc: CurrencyValue; dv: DateValue; dt: TimeValue; p: Ptr;
sc: Meta.Scanner; x, y: REAL; z: SHORTREAL; prec: SHORTINT;
bv: BlobValue; blob: SqlDrivers.Blob;
BEGIN (* read the value represented by an item, translate it into a string, and append this string to a statement *)
CASE item.typ OF
| Meta.byteTyp, Meta.sIntTyp, Meta.intTyp:
Strings.IntToString(item.IntVal(), h); AddStr(h, FALSE, 12, s)
| Meta.longTyp:
Strings.IntToString(item.LongVal(), h); AddStr(h, FALSE, 24, s)
| Meta.sRealTyp:
z := SHORT(item.RealVal()); prec := 7;
(* find the shortest string that can represent the number as a string *)
(* this is a hack to avoid conversion problems between binary and textual representations *)
REPEAT
Strings.RealToStringForm(z, prec, 0, 0, " ", h);
Strings.StringToReal(h, y, res);
INC(prec)
UNTIL (z = SHORT(y)) OR (prec = 10);
AddStr(h, FALSE, 20, s)
| Meta.realTyp:
x := item.RealVal(); prec := 16;
(* find the shortest string that can represent the number as a string *)
(* this is a hack to avoid conversion problems between binary and textual representations *)
REPEAT
Strings.RealToStringForm(x, prec, 0, 0, " ", h);
Strings.StringToReal(h, y, res);
INC(prec)
UNTIL (x = y) OR (prec = 19);
AddStr(h, FALSE, 28, s)
| Meta.boolTyp:
IF item.BoolVal() THEN AddChar("1", s) ELSE AddChar("0", s) END
| Meta.arrTyp:
IF item.BaseTyp() = Meta.charTyp THEN (* string *)
p := SYSTEM.VAL(Ptr, item.adr);
IF ~native THEN AddChar("'", s) END;
AddStr(p^, native, item.Len(), s);
IF ~native THEN AddChar("'", s) END
ELSE (* array of basic type *)
len := item.Len(); ASSERT(len > 0, 100);
item.Index(0, base); AddItem(d, base, native, s); i := 1;
WHILE i < len DO
AddChar(",", s); AddChar(" ", s);
item.Index(i, base); AddItem(d, base, native, s);
INC(i)
END
END
| Meta.recTyp:
item.GetTypeName(mod, typ);
IF (mod = "Dialog") & (typ = "Currency") THEN
item.GetVal(dc, ok); ASSERT(ok, 101);
LongToString(dc.value.val, dc.value.scale, h); AddStr(h, FALSE, 24, s);
ELSIF (mod = "Dialog") & (typ = "List") THEN
item.Lookup("index", base);
AddItem(d, base, native, s)
ELSIF (mod = "Dialog") & (typ = "Combo") THEN
item.Lookup("item", base);
AddItem(d, base, native, s)
ELSIF (mod = "Dates") & (typ = "Date") THEN
item.GetVal(dv, ok); ASSERT(ok, 101);
IF (dv.value.year = 0) & (dv.value.month = 0) & (dv.value.day = 0) THEN
AddStr(nullStr, FALSE, 4, s)
ELSE
IF ~native THEN AddChar("'", s) END;
Strings.IntToString(dv.value.year, h);
AddStr(h, FALSE, 8, s); AddChar("/", s);
Strings.IntToStringForm(dv.value.month, Strings.decimal, 2, "0", FALSE, h);
AddStr(h, FALSE, 4, s); AddChar("/", s);
Strings.IntToStringForm(dv.value.day, Strings.decimal, 2, "0", FALSE, h);
AddStr(h, FALSE, 4, s);
IF ~native THEN AddChar("'", s) END
END
ELSIF (mod = "Dates") & (typ = "Time") THEN
item.GetVal(dt, ok); ASSERT(ok, 101);
IF ~native THEN AddChar("'", s) END;
Strings.IntToString(dt.value.hour, h); AddStr(h, native, 8, s); AddChar(":", s);
Strings.IntToString(dt.value.minute, h); AddStr(h, native, 8, s); AddChar(":", s);
Strings.IntToString(dt.value.second, h); AddStr(h, native, 8, s);
IF ~native THEN AddChar("'", s) END
ELSIF (mod = "SqlDB") & (typ = "Blob") THEN
item.GetVal(bv, ok); ASSERT(ok, 101);
AddStr(d.driver.blobStr, FALSE, LEN(d.driver.blobStr), s);
NEW(blob); blob.len := bv.value.len; blob.data := bv.value.data;
IF s.last = NIL THEN s.blobs := blob ELSE s.last.next := blob END;
s.last := blob
ELSE
sc.ConnectTo(item);
sc.Scan; ASSERT(~sc.eos, 22);
AddItem(d, sc.this, native, s); sc.Scan;
WHILE ~sc.eos DO
AddChar(",", s); AddChar(" ", s);
AddItem(d, sc.this, native, s); sc.Scan
END
END
| Meta.ptrTyp:
item.Deref(base); AddItem(d, base, native, s)
ELSE HALT(21)
END
END AddItem;
PROCEDURE Compile (d: StdDatabase; IN s: ARRAY OF CHAR; OUT t: Statement);
VAR i: INTEGER; ch: CHAR; path: ARRAY varLen OF CHAR; quoted, native: BOOLEAN; item: Meta.Item;
BEGIN (* expand designators in an SQL statement by their current values, yielding a correct SQL statement *)
i := 0; ch := s[0]; t.idx := 0; t.ext := NIL; quoted := FALSE;
WHILE ch # 0X DO
IF (ch = ":") & ~quoted & (s[i+1] # "\") THEN
(* ":\" does not trigger Meta substitution, in order to allow for Windows path names such as in
"SELECT * FROM C:\directory\databaseName.tableName"
*)
INC(i); ch := s[i];
IF ch = "!" THEN native := TRUE; INC(i); ch := s[i] ELSE native := FALSE END;
ReadPath(s, path, i, ch); ASSERT(path # "", 20);
Meta.LookupPath(path, item); ASSERT(item.Valid(), 21); ASSERT(item.obj = Meta.varObj, 22);
AddItem(d, item, native, t)
ELSE
IF ch = "'" THEN quoted := ~quoted END;
AddChar(ch, t);
INC(i); ch := s[i]
END
END
END Compile;
PROCEDURE Execute (d: StdDatabase; VAR s: Statement);
BEGIN
IF s.ext # NIL THEN
s.ext[s.idx] := 0X; d.driver.BeginExec(s.ext^, s.blobs, d.async, d.showErrors, d.res)
ELSE
s.buf[s.idx] := 0X; d.driver.BeginExec(s.buf, s.blobs, d.async, d.showErrors, d.res)
END
END Execute;
(* item manipulation *)
PROCEDURE LookupItem (OUT i: Meta.Item; VAR r: ANYREC; async: BOOLEAN);
VAR type: Kernel.Type; mod: Kernel.Module; attr: Kernel.ItemAttr;
BEGIN (* create a meta item for a global variable passed as VAR parameter *)
attr.obj := Meta.varObj;
attr.typ := Meta.recTyp;
attr.vis := Meta.exported;
attr.adr := SYSTEM.ADR(r);
attr.mod := NIL;
attr.desc := SYSTEM.VAL(Kernel.Type, SYSTEM.TYP(r));
attr.ptr := NIL;
attr.ext := NIL;
IF async THEN (* check for global variable *)
mod := Kernel.modList;
WHILE (mod # NIL) & ((attr.adr < mod.data) OR (attr.adr >= mod.data + mod.dsize)) DO mod := mod.next END;
ASSERT(mod # NIL, 24); (* trap if variable was not found in any module *)
attr.mod := mod
ELSE
attr.mod := NIL
END;
Meta.GetThisItem(attr, i)
END LookupItem;
PROCEDURE ReadItem (item: Meta.Item; t: StdTable; row: INTEGER; VAR col: INTEGER);
VAR i, len: INTEGER; base: Meta.Item; s: Meta.Scanner; mod, typ: Meta.Name; ok: BOOLEAN;
r: REAL; date: DateValue; time: TimeValue; cy: CurrencyValue; str: StringValue;
blob: BlobValue; rw: RowValue; tab: SqlDrivers.Table;
BEGIN (* read a value from a result table, and copy it to a global variable represented by a meta item *)
tab := t.table; tab.res := 0;
CASE item.typ OF
| Meta.boolTyp:
tab.ReadInteger(row, col, i);
IF i = 0 THEN item.PutBoolVal(FALSE) ELSE item.PutBoolVal(TRUE) END;
INC(col)
| Meta.byteTyp, Meta.sIntTyp, Meta.intTyp:
tab.ReadInteger(row, col, i);
IF (item.typ = Meta.byteTyp) & ((i < MIN(BYTE)) OR (i > MAX(BYTE)))
OR (item.typ = Meta.sIntTyp) & ((i < MIN(SHORTINT)) OR (i > MAX(SHORTINT))) THEN
i := 0; tab.res := overflow
END;
item.PutIntVal(i); INC(col)
| Meta.sRealTyp, Meta.realTyp:
tab.ReadReal(row, col, r);
IF (item.typ = Meta.sRealTyp) & ((r < MIN(SHORTREAL)) OR (r > MAX(SHORTREAL))) THEN
r := 0; tab.res := overflow
END;
item.PutRealVal(r); INC(col)
| Meta.arrTyp:
IF item.BaseTyp() = Meta.charTyp THEN
tab.ReadString(row, col, SYSTEM.THISARRAY(item.adr, item.Len()));
INC(col)
ELSE
i := 0; len := item.Len();
WHILE i # len DO
item.Index(i, base); ReadItem(base, t, row, col);
INC(i)
END
END
| Meta.recTyp:
item.GetTypeName(mod, typ);
IF (mod = "Dialog") & (typ = "Currency") THEN
tab.ReadCurrency(row, col, cy.value);
item.PutVal(cy, ok); ASSERT(ok, 100);
INC(col)
ELSIF (mod = "Dialog") & (typ = "List") THEN
item.Lookup("index", base);
ReadItem(base, t, row, col)
ELSIF (mod = "Dialog") & (typ = "Combo") THEN
item.Lookup("item", base);
ReadItem(base, t, row, col)
ELSIF (mod = "Dates") & (typ = "Date") THEN
tab.ReadDate(row, col, date.value);
item.PutVal(date, ok); ASSERT(ok, 100);
INC(col)
ELSIF (mod = "Dates") & (typ = "Time") THEN
tab.ReadTime(row, col, time.value);
item.PutVal(time, ok); ASSERT(ok, 100);
INC(col)
ELSIF (mod = "SqlDB") & (typ = "Blob") THEN
tab.ReadBlob(row, col, blob.value.len, blob.value.data);
item.PutVal(blob, ok); ASSERT(ok, 100);
INC(col)
ELSE
IF (mod = "SqlDB") & (typ = "Row") THEN
item.GetVal(rw, ok); ASSERT(ok, 100);
IF (rw.value.fields = NIL) OR (LEN(rw.value.fields^) # t.columns - col) THEN
NEW(rw.value.fields, t.columns - col);
item.PutVal(rw, ok); ASSERT(ok, 100)
END
END;
s.ConnectTo(item);
s.Scan; WHILE ~s.eos DO ReadItem(s.this, t, row, col); s.Scan END
END
| Meta.ptrTyp:
item.GetBaseType(base);
IF (base.typ = Meta.arrTyp) & (base.BaseTyp() = Meta.charTyp) THEN
item.GetVal(str, ok); ASSERT(ok, 100);
IF row = types THEN tab.ReadType(col, str.value)
ELSIF row = names THEN tab.ReadName(col, str.value)
ELSE tab.ReadVarString(row, col, str.value)
END;
item.PutVal(str, ok); ASSERT(ok, 101);
INC(col)
ELSE
item.Deref(base);
ASSERT(base.obj = Meta.varObj, 23);
ReadItem(base, t, row, col)
END
| Meta.procTyp: (* skip *)
ELSE HALT(22)
END;
IF tab.res > t.res THEN t.res := tab.res END
END ReadItem;
PROCEDURE ClearItem (item: Meta.Item);
VAR s: Meta.Scanner; ok: BOOLEAN; base: Meta.Item; len, i: INTEGER;
BEGIN (* zero a global variable represented by a meta item *)
ASSERT(item.Valid(), 20);
IF item.vis = Meta.exported THEN
CASE item.typ OF
| Meta.byteTyp, Meta.sIntTyp, Meta.intTyp:
item.PutIntVal(0)
| Meta.sRealTyp, Meta.realTyp:
item.PutRealVal(0)
| Meta.boolTyp:
item.PutBoolVal(FALSE)
| Meta.arrTyp:
IF item.BaseTyp() = Meta.charTyp THEN
item.PutStringVal("", ok); ASSERT(ok, 22)
ELSE
i := 0; len := item.Len();
WHILE i # len DO
item.Index(i, base); ClearItem(base);
INC(i)
END
END
| Meta.recTyp:
s.ConnectTo(item);
s.Scan; WHILE ~s.eos DO ClearItem(s.this); s.Scan END
| Meta.ptrTyp:
item.Deref(base);
IF base.obj = Meta.varObj THEN ClearItem(base) END
END
END
END ClearItem;
(* notification *)
PROCEDURE NotifyLater (d: StdDatabase; adr0, adr1: INTEGER);
VAR r: Range;
BEGIN (* register an address range for later notification via an action *)
r := d.range;
IF r = NIL THEN
Services.DoLater(d.action, Services.now)
ELSE
IF (d.lastRange # NIL) & (d.lastRange.adr1 < adr0) THEN
r := NIL
ELSE
WHILE (r # NIL) & ((r.adr1 < adr0) OR (r.adr0 > adr1)) DO r := r.next END
END
END;
IF r # NIL THEN
r.adr0 := MIN(r.adr0, adr0); r.adr1 := MAX(r.adr1, adr1)
ELSE
NEW(r); r.adr0 := adr0; r.adr1 := adr1;
r.next := d.range; d.range := r;
d.lastRange := r
END
END NotifyLater;
PROCEDURE Update (d: StdDatabase);
VAR r: Range;
BEGIN (* notify an address range immediately *)
r := d.range;
WHILE r # NIL DO
Dialog.Notify(r.adr0, r.adr1, {update});
r := r.next
END;
IF d.range # NIL THEN Dialog.Notify(0, 0, {guardCheck}) END; (* check only once, after all updates *)
d.range := NIL
END Update;
(* delayed operations *)
PROCEDURE DoRead (t: StdTable; row: INTEGER; VAR item: Meta.Item);
VAR col: INTEGER;
BEGIN
WriteString("DoRead");
ASSERT(t.columns > 0, 20);
IF row < t.rows THEN
col := 0; t.res := 0;
ReadItem(item, t, row, col);
ELSE
ClearItem(item);
t.res := noData
END;
IF t.strictNotify THEN
Dialog.Notify(item.adr, item.adr + item.Size(), {update, guardCheck});
ELSE
NotifyLater(t.db, item.adr, item.adr + item.Size())
END
END DoRead;
PROCEDURE DoClear (t: StdTable);
BEGIN
WriteString("DoClear");
IF (t.table # NIL) & (t.db.driver # NIL) THEN
t.table.Close; t.table := NIL
END;
t.res := 0; t.rows := 0; t.columns := 0; t.srows := 0
END DoClear;
PROCEDURE DoEndOpen (d: StdDatabase);
VAR res: INTEGER;
BEGIN
WriteString("DoEndOpen");
ASSERT(d.driver.Ready(), 100);
d.driver.EndOpen(res);
d.res := res
END DoEndOpen;
PROCEDURE DoBeginExec (d: StdDatabase; t: StdTable; VAR statement: ARRAY OF CHAR);
VAR res: INTEGER; s: Statement;
BEGIN
WriteString("DoBeginExec");
Compile(d, statement, s);
IF debug THEN
IF s.ext # NIL THEN
s.ext[s.idx] := 0X; WriteString(s.ext^)
ELSE
s.buf[s.idx] := 0X; WriteString(s.buf)
END
END;
IF t # NIL THEN DoClear(t) END;
Execute(d, s);
IF t # NIL THEN t.res := d.res END
END DoBeginExec;
PROCEDURE DoEndExec (d: StdDatabase; t: StdTable);
VAR dt: SqlDrivers.Table; rows, columns: INTEGER;
BEGIN
IF d.res = 0 THEN
WriteString("DoEndExec");
ASSERT(d.driver.Ready(), 100);
d.driver.EndExec(dt, rows, columns, d.res);
IF t # NIL THEN
t.rows := rows; t.srows := rows; t.columns := columns;
t.table := dt; t.res := d.res;
IF t.strictNotify THEN
Dialog.Notify(SYSTEM.ADR(t^), SYSTEM.ADR(t^) + 4, {update, guardCheck})
ELSE
NotifyLater(t.db, SYSTEM.ADR(t^), SYSTEM.ADR(t^) + 4)
END
ELSE
ASSERT(columns = 0, 21);
END
END
END DoEndExec;
PROCEDURE DoCommit (d: StdDatabase; accept: BOOLEAN);
BEGIN
WriteString("DoCommit");
d.driver.Commit(accept, d.res)
END DoCommit;
(* serialization *)
PROCEDURE Reset (d: StdDatabase);
VAR e: Elem;
BEGIN (* trap cleanup *)
e := d.queue; d.queue := NIL; d.range := NIL; d.tail := NIL;
WHILE e # NIL DO
IF e.table # NIL THEN e.table.Clear END;
IF e.item.Valid() THEN ClearItem(e.item) END;
e := e.next
END
END Reset;
PROCEDURE Process (d: StdDatabase);
VAR e: Elem; operations: INTEGER;
BEGIN (* this is the heart of the processing of asynchronous operations *)
WriteString("start processing");
operations := 0;
WHILE (d.queue # NIL) & (operations < maxOperations) & d.driver.Ready() DO
e := d.queue; d.queue := e.next; d.tail := d.queue; INC(operations);
CASE e.op OF
| openOp: DoEndOpen(d)
| beginOp: DoBeginExec(d, e.table, e.statement^)
| endOp: DoEndExec(d, e.table)
| commitOp: DoCommit(d, TRUE)
| rollbackOp: DoCommit(d, FALSE)
| clearOp: DoClear(e.table)
| callOp: INC(d.id); e.cmd(e.par)
| tcallOp: INC(d.id); e.table.id := d.id; e.tcmd(e.table, e.par)
ELSE DoRead(e.table, e.op, e.item)
END;
d.tail := NIL
END;
WriteString("stop processing")
END Process;
PROCEDURE (a: Action) Do;
VAR d: StdDatabase;
BEGIN (* async operations are advanced by an action, which belongs to the database object *)
d := a.database;
IF d.executing THEN (* trapped *)
Reset(d)
ELSIF (d.queue # NIL) OR (d.range # NIL) THEN
Services.DoLater(a, Services.now);
d.executing := TRUE;
Process(d);
Update(d)
END;
d.executing := FALSE
END Do;
PROCEDURE Put (d: StdDatabase; op: INTEGER; t: StdTable; s: ARRAY OF CHAR;
VAR i: Meta.Item; cmd: Command; tcmd: TableCommand; par: ANYPTR);
VAR e, h, k: Elem;
BEGIN (* put a SQL statement into a queue for later async processing *)
NEW(e); e.op := op; e.table := t; e.item := i; e.cmd := cmd; e.tcmd := tcmd; e.par := par;
IF s # "" THEN NEW(e.statement, LEN(s)); e.statement^ := s$ END;
h := d.queue;
IF h = NIL THEN Services.DoLater(d.action, Services.now) END; (* start process *)
IF h = d.tail THEN
e.next := h; d.queue := e
ELSIF op >= clearOp THEN (* clear, read: insert after last op on same table *)
k := NIL;
WHILE h # d.tail DO
IF h.table = t THEN k := h END;
h := h.next
END;
IF k = NIL THEN e.next := d.queue; d.queue := e
ELSE e.next := k.next; k.next := e
END
ELSE
WHILE h.next # d.tail DO h := h.next END;
e.next := h.next; h.next := e
END
END Put;
PROCEDURE Synch (d: StdDatabase; op: INTEGER; t: StdTable): BOOLEAN;
(* check whether it is necessary to enqueue this operation *)
(* TRUE if Put would insert at beginning of queue *)
VAR h: Elem;
BEGIN
h := d.queue;
IF h = d.tail THEN
RETURN TRUE
ELSIF op >= clearOp THEN
WHILE (h # d.tail) & (h.table # t) DO h := h.next END;
RETURN h = d.tail
ELSE
RETURN FALSE
END
END Synch;
(* StdTable *)
PROCEDURE (t: StdTable) Exec (statement: ARRAY OF CHAR);
BEGIN
WriteString("Table Exec");
ASSERT(t.db.driver # NIL, 100); ASSERT(statement # "", 20);
ASSERT(~t.db.executing OR (t.id >= t.db.id), 21);
IF Synch(t.db, beginOp, t) THEN DoBeginExec(t.db, t, statement)
ELSE Put(t.db, beginOp, t, statement, dummy, NIL, NIL, NIL)
END;
IF Synch(t.db, endOp, t) & t.db.driver.Ready() THEN DoEndExec(t.db, t)
ELSE Put(t.db, endOp, t, "", dummy, NIL, NIL, NIL)
END
END Exec;
PROCEDURE (t: StdTable) Available (): BOOLEAN;
BEGIN
RETURN Synch(t.db, readOp, t)
END Available;
PROCEDURE (t: StdTable) Read (row: INTEGER; VAR data: ANYREC);
VAR item: Meta.Item;
BEGIN
WriteString("Read");
ASSERT((row >= 0) OR (data IS Row) & (row >= -2), 21);
ASSERT(~t.db.executing OR (t.id >= t.db.id), 25);
IF Synch(t.db, readOp, t) THEN
LookupItem(item, data, FALSE);
DoRead(t, row, item)
ELSE
LookupItem(item, data, TRUE);
Put(t.db, row, t, "", item, NIL, NIL, NIL)
END
END Read;
PROCEDURE (t: StdTable) Clear;
BEGIN
WriteString("Clear");
ASSERT(~t.db.executing OR (t.id >= t.db.id), 20);
IF Synch(t.db, clearOp, t) THEN DoClear(t)
ELSE Put(t.db, clearOp, t, "", dummy, NIL, NIL, NIL)
END
END Clear;
PROCEDURE (t: StdTable) Call (command: TableCommand; par: ANYPTR);
BEGIN
WriteString("Table Call");
ASSERT(command # NIL, 20);
ASSERT(~t.db.executing OR (t.id >= t.db.id), 21);
IF Synch(t.db, tcallOp, t) THEN command(t, par)
ELSE Put(t.db, tcallOp, t, "", dummy, NIL, command, par)
END
END Call;
(* StdDatabase *)
PROCEDURE (d: StdDatabase) Exec (statement: ARRAY OF CHAR);
BEGIN
WriteString("Exec");
ASSERT(d.driver # NIL, 100); ASSERT(statement # "", 20);
IF Synch(d, beginOp, NIL) THEN DoBeginExec(d, NIL, statement)
ELSE Put(d, beginOp, NIL, statement, dummy, NIL, NIL, NIL)
END;
IF Synch(d, endOp, NIL) & d.driver.Ready() THEN DoEndExec(d, NIL)
ELSE Put(d, endOp, NIL, "", dummy, NIL, NIL, NIL)
END
END Exec;
PROCEDURE (d: StdDatabase) Commit;
BEGIN
WriteString("Commit");
IF Synch(d, commitOp, NIL) THEN DoCommit(d, TRUE)
ELSE Put(d, commitOp, NIL, "", dummy, NIL, NIL, NIL)
END
END Commit;
PROCEDURE (d: StdDatabase) Rollback;
BEGIN
WriteString("Rollback");
IF Synch(d, rollbackOp, NIL) THEN DoCommit(d, FALSE)
ELSE Put(d, rollbackOp, NIL, "", dummy, NIL, NIL, NIL)
END
END Rollback;
PROCEDURE (d: StdDatabase) Call (command: Command; par: ANYPTR);
BEGIN
WriteString("Call");
ASSERT(command # NIL, 20);
IF Synch(d, callOp, NIL) THEN command(par)
ELSE Put(d, callOp, NIL, "", dummy, command, NIL, par)
END
END Call;
PROCEDURE (d: StdDatabase) NewTable (): Table;
VAR t: StdTable;
BEGIN
ASSERT(d.driver # NIL, 100);
NEW(t);
t.res := 0; t.rows := 0; t.columns := 0; t.strictNotify := FALSE;
t.table := NIL; t.srows := 0; t.id := d.id;
t.InitBase(d); t.db := d;
d.res := 0;
RETURN t
END NewTable;
PROCEDURE OpenDatabase* (protocol, id, password, datasource: ARRAY OF CHAR;
async, showErrors: BOOLEAN; OUT d: Database; OUT res: INTEGER);
VAR driver: SqlDrivers.Driver; sd: StdDatabase;
BEGIN
WriteString("OpenDatabase");
ASSERT(protocol # "", 20);
SqlDrivers.Open(protocol, id, password, datasource, async, showErrors, driver, res);
IF res = 0 THEN
ASSERT(driver # NIL, 100);
NEW(sd); sd.driver := driver; sd.queue := NIL; sd.tail := NIL;
sd.async := async; sd.showErrors := showErrors;
NEW(sd.action); sd.action.database := sd;
IF driver.Ready() THEN DoEndOpen(sd)
ELSE Put(sd, openOp, NIL, "", dummy, NIL, NIL, NIL)
END;
sd.res := 0; d := sd
ELSE
d := NIL
END
END OpenDatabase;
BEGIN
NEW(ptr);
nullStr := "null"
END SqlDB.