UNSAFE MODULEThis module (ab)uses two compiler-dependent features of the code:DB EXPORTSDB ,DBRep ; IMPORT Fmt, Process, SQL, SQLext, Text, WeakRef, Word, M3toC, Ctypes; FROM SQLtypes IMPORT SQLHENV, SQLRETURN, SQLSMALLINT, SQLHDBC, SQLHSTMT, SQLINTEGER, SQLUINTEGER, LDOUBLE, DATE_STRUCT, TIME_STRUCT, TIMESTAMP_STRUCT, SFLOAT, SWORD, SQLCHAR_star;
1) It imports TextF and assumes that TEXT values are implemented
as open arrays of CHAR.
2) It assumes that 1-D open arrays are implemented as 2-word
records (e.g. OpenArrayRep).
TYPE
OpenArrayRep = RECORD
data_ptr : ADDRESS;
n_elts : INTEGER;
END;
VAR
mu : MUTEX := NEW (MUTEX);
henv : SQLHENV := SQL.SQL_NULL_HENV;
------------------------------------------------------- connections ---
REVEAL
T = Public BRANDED "DB.T" OBJECT
hdbc : SQLHDBC;
OVERRIDES
disconnect := Disconnect;
new_stmt := NewStmt;
auto_commit := AutoCommit;
commit := Commit;
abort := Abort;
END;
PROCEDURE Connect (database, user_id, password: TEXT): T RAISES {Error} =
VAR
t := NEW (T);
err : SQLRETURN;
database_c := M3toC.SharedTtoS(database);
user_id_c := M3toC.SharedTtoS(user_id);
password_c := M3toC.SharedTtoS(password);
BEGIN
Init ();
err := SQL.SQLAllocConnect (henv, ADR (t.hdbc));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, NIL, t) END;
err := SQL.SQLConnect (t.hdbc,
LOOPHOLE(database_c, SQLCHAR_star), Text.Length(database),
LOOPHOLE(user_id_c, SQLCHAR_star), Text.Length(user_id),
LOOPHOLE(password_c, SQLCHAR_star), Text.Length(password));
M3toC.FreeSharedS(database, database_c);
M3toC.FreeSharedS(user_id, user_id_c);
M3toC.FreeSharedS(password, password_c);
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, NIL, t); END;
EVAL WeakRef.FromRef (t, CleanupConnection);
RETURN t;
END Connect;
PROCEDURE Disconnect (t: T) RAISES {Error} =
VAR err: SQLRETURN;
BEGIN
IF (t.hdbc = SQL.SQL_NULL_HDBC) THEN
Die (1, "DB.T is already disconnected.");
END;
err := SQL.SQLDisconnect (t.hdbc);
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, NIL, t); END;
err := SQL.SQLFreeConnect (t.hdbc);
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, NIL, t); END;
t.hdbc := SQL.SQL_NULL_HDBC;
END Disconnect;
PROCEDURE CleanupConnection (<*UNUSED*> READONLY w: WeakRef.T; ref: REFANY) =
VAR t := NARROW (ref, T);
BEGIN
IF (t.hdbc # SQL.SQL_NULL_HDBC) THEN
EVAL SQL.SQLDisconnect (t.hdbc);
EVAL SQL.SQLFreeConnect (t.hdbc);
t.hdbc := SQL.SQL_NULL_HDBC;
END;
END CleanupConnection;
PROCEDURE AutoCommit (t: T; on: BOOLEAN) RAISES {Error} =
CONST flag = ARRAY BOOLEAN OF INTEGER {SQL.SQL_AUTOCOMMIT_OFF,
SQL.SQL_AUTOCOMMIT_ON};
VAR err : SQLRETURN;
BEGIN
IF (t.hdbc = SQL.SQL_NULL_HDBC) THEN
Die (2, "Attempted to set AutoCommit on a disconnected DB.T.");
END;
err := SQL.SQLSetConnectOption (t.hdbc, SQL.SQL_AUTOCOMMIT, flag[on]);
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, NIL, t); END;
END AutoCommit;
PROCEDURE Commit (t: T) RAISES {Error} =
VAR err : SQLRETURN;
BEGIN
IF (t.hdbc = SQL.SQL_NULL_HDBC) THEN
Die (3, "Attempted to commit a disconnected DB.T.");
END;
err := SQL.SQLTransact (henv, t.hdbc, SQL.SQL_COMMIT);
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, NIL, t); END;
END Commit;
PROCEDURE Abort (t: T) RAISES {Error} =
VAR err : SQLRETURN;
BEGIN
IF (t.hdbc = SQL.SQL_NULL_HDBC) THEN
Die (4, "Attempted to abort a disconnected DB.T.");
END;
err := SQL.SQLTransact (henv, t.hdbc, SQL.SQL_ROLLBACK);
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, NIL, t); END;
END Abort;
PROCEDURE NewStmt (t: T): Stmt RAISES {Error} =
VAR
st := NEW (Stmt);
err : SQLRETURN;
BEGIN
IF (t.hdbc = SQL.SQL_NULL_HDBC) THEN
Die (5, "Attempted to create a new statement on a disconnected DB.T.");
END;
st.conn := t;
st.hstmt := SQL.SQL_NULL_HSTMT;
st.prepared := FALSE;
st.executed := FALSE;
err := SQL.SQLAllocStmt (t.hdbc, ADR (st.hstmt));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
EVAL WeakRef.FromRef (st, CleanupStmt);
RETURN st;
END NewStmt;
PROCEDURE CleanupStmt (<*UNUSED*> READONLY wr: WeakRef.T; ref: REFANY) =
VAR st := NARROW (ref, Stmt);
BEGIN
IF (st.hstmt # SQL.SQL_NULL_HSTMT) THEN
IF (st.conn # NIL) AND (st.conn.hdbc # SQL.SQL_NULL_HDBC) THEN
EVAL SQL.SQLFreeStmt (st.hstmt, SQL.SQL_DROP);
(* otherwise, the DB.T connection is already broken... *)
END;
DisposeStmt (st);
END;
END CleanupStmt;
PROCEDURE DisposeStmt (st: Stmt) =
BEGIN
CleanValueInfo (st);
st.conn := NIL;
st.hstmt := SQL.SQL_NULL_HSTMT;
st.prepared := FALSE;
st.executed := FALSE;
st.col_info := NIL;
st.values := NIL;
st.val_info := NIL;
IF (st.buffer # NIL) THEN DISPOSE (st.buffer) END;
END DisposeStmt;
PROCEDURE CleanValueInfo (st: Stmt) =
BEGIN
IF (st.val_info # NIL) THEN
(* free any existing string buffers *)
FOR i := 0 TO LAST (st.val_info^) DO
WITH z = st.val_info[i] DO
IF (z.buffer # NIL) THEN DISPOSE (z.buffer); END;
z.buffer := NIL;
END;
END;
END;
END CleanValueInfo;
-------------------------------------------------------- statements ---
REVEAL
(* a SQL database statement (query or update) *)
Stmt = StmtPublic BRANDED "DB.Stmt" OBJECT
conn : T; (* my database connection *)
hstmt : SQLHSTMT;
prepared : BOOLEAN;
executed : BOOLEAN;
col_info : ResultDesc;
values : Results;
val_info : ValueDesc;
buffer : Buffer;
first_getdata : INTEGER;
OVERRIDES
prepare := Prepare;
execute := Execute;
fetch := Fetch;
done := Done;
close := Close;
get_cursor_name := GetCursorName;
set_cursor_name := SetCursorName;
num_rows := NumRows;
describe_result := DescribeResult;
connection := StmtConnection;
END;
PROCEDURE StmtConnection (st: Stmt): T =
BEGIN
RETURN st.conn;
END StmtConnection;
PROCEDURE Prepare (st: Stmt; operation: TEXT) RAISES {Error} =
VAR
err: SQLRETURN;
operation_c := M3toC.SharedTtoS(operation);
BEGIN
LOCK st DO
CheckStmt (st, 12, "prepare", check_exec := FALSE);
err := SQL.SQLPrepare (st.hstmt, LOOPHOLE(operation, SQLCHAR_star),
Text.Length (operation));
M3toC.FreeSharedS(operation, operation_c);
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
st.prepared := TRUE;
st.executed := FALSE;
st.col_info := NIL;
st.values := NIL;
END;
END Prepare;
PROCEDURE Execute (st: Stmt; operation: TEXT) RAISES {Error} =
VAR
err: SQLRETURN;
operation_c: Ctypes.char_star;
BEGIN
LOCK st DO
CheckStmt (st, 15, "execute", check_exec := FALSE);
IF (operation = NIL) THEN
(* use the prepared statement *)
IF (NOT st.prepared) THEN
Die (6, "Attempted to execute an unspecified or prepared DB.Stmt");
END;
err := SQL.SQLExecute (st.hstmt);
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
ELSE
st.prepared := FALSE;
operation_c := M3toC.SharedTtoS(operation);
err := SQL.SQLExecDirect (st.hstmt, LOOPHOLE(operation, SQLCHAR_star),
Text.Length (operation));
M3toC.FreeSharedS(operation, operation_c);
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
END;
st.executed := TRUE;
st.col_info := NIL;
st.values := NIL;
END;
END Execute;
PROCEDURE Fetch (st: Stmt): Results RAISES {Error} =
VAR err: SQLRETURN;
BEGIN
LOCK st DO
CheckStmt (st, 18, "fetch from", check_exec := TRUE);
IF (st.values = NIL) THEN BuildValueArea (st); END;
err := SQL.SQLFetch (st.hstmt);
IF (err = SQL.SQL_SUCCESS) THEN RETURN MapValues (st); END;
IF (err = SQL.SQL_NO_DATA_FOUND) THEN RETURN NIL; END;
CheckErr (err, st);
END;
RETURN NIL;
END Fetch;
TYPE
Buffer = UNTRACED REF ARRAY OF CHAR;
TYPE
ValueDesc = REF ARRAY OF ValueInfo;
ValueInfo = RECORD
ref : REFANY;
ptr : ADDRESS; (* == ADR (receive_buffer [offset]) *)
offset : INTEGER; (* byte offset into the receive buffer *)
datatype : DataType;
buffer : Buffer; (* holding area for string data *)
END;
We don't seem to be able to get reliable size data for string
or binary fields from the ODBC drivers. Perhaps we (Farshad & Bill)
don't understand the spec. So, we don't call SQLBindCol() to fix their
locations, instead we use SQLGetData() to retrieve the string in chunks.
These types define the layout of the receive buffer for each DataType.
TYPE
(* => Char, VarChar, LongVarChar, Binary, VarBinary, LongVarBinary *)
StringPtr = UNTRACED REF StringVal;
StringVal = OpenArrayRep;
(* => BigInt *)
BigIntPtr = UNTRACED REF BigIntVal;
BigIntVal = RECORD
data_len : SQLINTEGER;
value : RECORD lo, hi: SQLINTEGER; END;
END;
(* => Integer, SmallInt, TinyInt *)
IntPtr = UNTRACED REF IntVal;
IntVal = RECORD
data_len : SQLINTEGER;
value : SQLINTEGER;
END;
(* => Numeric, Decimal, Float, Double *)
FloatPtr = UNTRACED REF FloatVal;
FloatVal = RECORD
data_len : SQLINTEGER;
value : LDOUBLE;
END;
(* => Real *)
RealPtr = UNTRACED REF RealVal;
RealVal = RECORD
data_len : SQLINTEGER;
value : SFLOAT;
END;
(* => Bit *)
BitPtr = UNTRACED REF BitVal;
BitVal = RECORD
data_len : SQLINTEGER;
value : SWORD;
END;
(* => Date *)
DatePtr = UNTRACED REF DateVal;
DateVal = RECORD
data_len : SQLINTEGER;
value : DATE_STRUCT;
END;
(* => Time *)
TimePtr = UNTRACED REF TimeVal;
TimeVal = RECORD
data_len : SQLINTEGER;
value : TIME_STRUCT;
END;
(* => TimeStamp *)
TimeStampPtr = UNTRACED REF TimeStampVal;
TimeStampVal = RECORD
data_len : SQLINTEGER;
value : TIMESTAMP_STRUCT;
END;
PROCEDURE BuildValueArea (st: Stmt) RAISES {Error} =
(* LL = st.mu *)
CONST
Mask = Word.Not (BYTESIZE (LONGREAL) - 1);
Bump = BYTESIZE (LONGREAL) - 1;
VAR
next_buf : INTEGER;
len : INTEGER;
err : SQLRETURN;
seen_getdata : BOOLEAN;
BEGIN
IF (st.col_info = NIL) THEN BuildColumnInfo (st); END;
st.values := NEW (Results, NUMBER (st.col_info^));
st.val_info := NEW (ValueDesc, NUMBER (st.col_info^));
st.first_getdata := NUMBER(st.col_info^);
(* assign buffer offsets *)
next_buf := 0;
seen_getdata := FALSE;
FOR i := 0 TO LAST (st.values^) DO
WITH z = st.val_info[i] DO
next_buf := Word.And (next_buf + Bump, Mask); (* keep it aligned! *)
z.offset := next_buf;
z.datatype := st.col_info[i].type;
CASE z.datatype OF
| DataType.Null => len := 0;
| DataType.Char,
DataType.Binary,
DataType.VarChar,
DataType.VarBinary,
DataType.LongVarChar,
DataType.LongVarBinary => len := BYTESIZE (StringVal);
IF NOT seen_getdata THEN
seen_getdata := TRUE;
st.first_getdata := i;
END;
| DataType.Numeric,
DataType.Decimal,
DataType.Float,
DataType.Double => len := BYTESIZE (FloatVal);
| DataType.BigInt => len := BYTESIZE (BigIntVal);
| DataType.Integer,
DataType.SmallInt,
DataType.TinyInt => len := BYTESIZE (IntVal);
| DataType.Real => len := BYTESIZE (RealVal);
| DataType.Bit => len := BYTESIZE (BitVal);
| DataType.Date => len := BYTESIZE (DateVal);
| DataType.Time => len := BYTESIZE (TimeVal);
| DataType.Timestamp => len := BYTESIZE (TimeStampVal);
END;
INC (next_buf, len);
END; (* WITH z *)
END;
(* release any existing bindings so they don't confuse us *)
IF (st.buffer # NIL) THEN
err := SQL.SQLFreeStmt (st.hstmt, SQL.SQL_UNBIND);
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
END;
(* free any existing string buffers *)
CleanValueInfo (st);
(* allocate an immovable buffer to hold the incoming data *)
IF (st.buffer = NIL) OR (BYTESIZE (st.buffer^) < next_buf) THEN
IF (st.buffer # NIL) THEN DISPOSE (st.buffer); END;
st.buffer := NEW (Buffer, Word.And (next_buf + 16_fff, Word.Not (16_fff)));
END;
(* Allocate all fields. *)
FOR i := 0 TO LAST(st.values^) DO
WITH z = st.val_info[i] DO
z.ptr := ADR (st.buffer [z.offset]);
CASE z.datatype OF
| DataType.Null => z.ref := NIL;
| DataType.Char,
DataType.Binary,
DataType.VarChar,
DataType.VarBinary,
DataType.LongVarChar,
DataType.LongVarBinary => z.ref := NEW (RefString);
| DataType.BigInt => z.ref := NEW (RefBigInt);
| DataType.Integer,
DataType.SmallInt,
DataType.TinyInt => z.ref := NEW (REF INTEGER);
| DataType.Numeric,
DataType.Decimal,
DataType.Float,
DataType.Double => z.ref := NEW (REF LONGREAL);
| DataType.Real => z.ref := NEW (REF REAL);
| DataType.Bit => z.ref := NEW (REF BOOLEAN);
| DataType.Date => z.ref := NEW (RefDate);
| DataType.Time => z.ref := NEW (RefTime);
| DataType.Timestamp => z.ref := NEW (RefTimestamp);
END; (* CASE *)
END; (* WITH z *)
END;
(* Bind the result columns to their location in the buffer.
We only bind until we see the first column that requires
a SQLGetData, to workaround a restriction in some ODBC drivers.
The rest of the columns will be mapped using SQLGetData
in MapValues. *)
FOR i := 0 TO st.first_getdata-1 DO
WITH z = st.val_info[i], col = i+1 DO
z.ptr := ADR (st.buffer [z.offset]);
CASE z.datatype OF
| DataType.Null => (* do nothing *)
| DataType.Char,
DataType.Binary,
DataType.VarChar,
DataType.VarBinary,
DataType.LongVarChar,
DataType.LongVarBinary =>
<* ASSERT FALSE *>
(* We must not have hit a string in this loop. *)
| DataType.BigInt =>
VAR big: BigIntPtr := z.ptr; BEGIN
err := SQL.SQLBindCol (st.hstmt, col, SQL.SQL_BIGINT,
ADR (big.value), BYTESIZE (big.value), ADR (big.data_len));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
END;
| DataType.Integer,
DataType.SmallInt,
DataType.TinyInt =>
VAR int: IntPtr := z.ptr; BEGIN
err := SQL.SQLBindCol (st.hstmt, col, SQL.SQL_C_SLONG,
ADR (int.value), BYTESIZE (int.value), ADR (int.data_len));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
END;
| DataType.Numeric,
DataType.Decimal,
DataType.Float,
DataType.Double =>
VAR flt: FloatPtr := z.ptr; BEGIN
err := SQL.SQLBindCol (st.hstmt, col, SQL.SQL_C_DOUBLE,
ADR (flt.value), BYTESIZE (flt.value), ADR (flt.data_len));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
END;
| DataType.Real =>
VAR flt: RealPtr := z.ptr; BEGIN
err := SQL.SQLBindCol (st.hstmt, col, SQL.SQL_C_FLOAT,
ADR (flt.value), BYTESIZE (flt.value), ADR (flt.data_len));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
END;
| DataType.Bit =>
VAR bit: BitPtr := z.ptr; BEGIN
err := SQL.SQLBindCol (st.hstmt, col, SQL.SQL_C_SHORT,
ADR (bit.value), BYTESIZE (bit.value), ADR (bit.data_len));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
END;
| DataType.Date =>
VAR dat: DatePtr := z.ptr; BEGIN
err := SQL.SQLBindCol (st.hstmt, col, SQL.SQL_C_DATE,
ADR (dat.value), BYTESIZE (dat.value), ADR (dat.data_len));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
END;
| DataType.Time =>
VAR tim: TimePtr := z.ptr; BEGIN
err := SQL.SQLBindCol (st.hstmt, col, SQL.SQL_C_TIME,
ADR (tim.value), BYTESIZE (tim.value), ADR (tim.data_len));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
END;
| DataType.Timestamp =>
VAR ts: TimeStampPtr := z.ptr; BEGIN
err := SQL.SQLBindCol (st.hstmt, col, SQL.SQL_C_TIMESTAMP,
ADR (ts.value), BYTESIZE (ts.value), ADR (ts.data_len));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
END;
END; (* CASE *)
END; (* WITH z *)
END;
END BuildValueArea;
PROCEDURE MapValues (st: Stmt): Results RAISES {Error} =
(* Convert each value in the result buffer into its Modula-3 REF value.
Detect and return NIL for nullified values. LL = st.mu *)
VAR ref: REFANY;
VAR err: SQLRETURN;
BEGIN
(* First, map all the values up that were bound using SQLBindData. *)
FOR i := 0 TO st.first_getdata-1 DO
WITH z = st.val_info[i] DO
ref := NIL;
CASE z.datatype OF
| DataType.Null =>
(* no value *)
ref := NIL;
| DataType.Char,
DataType.Binary,
DataType.VarChar,
DataType.VarBinary,
DataType.LongVarChar,
DataType.LongVarBinary =>
ref := z.ref;
| DataType.BigInt =>
VAR big: BigIntPtr := z.ptr; rr: RefBigInt; BEGIN
IF (big.data_len > 0) THEN
rr := z.ref;
rr.lo := big.value.lo;
rr.hi := big.value.hi;
ref := rr;
END;
END;
| DataType.Integer,
DataType.SmallInt,
DataType.TinyInt =>
VAR int: IntPtr := z.ptr; rr: REF INTEGER; BEGIN
IF (int.data_len > 0) THEN
rr := z.ref;
rr^ := int.value;
ref := rr;
END;
END;
| DataType.Numeric,
DataType.Decimal,
DataType.Float,
DataType.Double =>
VAR flt: FloatPtr := z.ptr; rr: REF LONGREAL; BEGIN
IF (flt.data_len > 0) THEN
rr := z.ref;
rr^ := flt.value;
ref := rr;
END;
END;
| DataType.Real =>
VAR flt: RealPtr := z.ptr; rr: REF REAL; BEGIN
IF (flt.data_len > 0) THEN
rr := z.ref;
rr^ := flt.value;
ref := rr;
END;
END;
| DataType.Bit =>
VAR bit: BitPtr := z.ptr; rr: REF BOOLEAN; BEGIN
IF (bit.data_len > 0) THEN
rr := z.ref;
rr^ := (bit.value # 0);
ref := rr;
END;
END;
| DataType.Date =>
VAR dat: DatePtr := z.ptr; rr: RefDate; BEGIN
IF (dat.data_len > 0) THEN
rr := z.ref;
rr.year := dat.value.year;
rr.month := dat.value.month;
rr.day := dat.value.day;
ref := rr;
END;
END;
| DataType.Time =>
VAR tim: TimePtr := z.ptr; rr: RefTime; BEGIN
IF (tim.data_len > 0) THEN
rr := z.ref;
rr.hour := tim.value.hour;
rr.minute := tim.value.minute;
rr.second := tim.value.second;
ref := rr;
END;
END;
| DataType.Timestamp =>
VAR ts: TimeStampPtr := z.ptr; rr: RefTimestamp; BEGIN
IF (ts.data_len > 0) THEN
rr := z.ref;
rr.year := ts.value.year;
rr.month := ts.value.month;
rr.day := ts.value.day;
rr.hour := ts.value.hour;
rr.minute := ts.value.minute;
rr.second := ts.value.second;
rr.fraction := ts.value.fraction;
ref := rr;
END;
END;
END; (* CASE *)
st.values [i] := ref;
END; (* WITH z *)
END;
(* Map all the values that use GetData. *)
FOR i := st.first_getdata TO LAST (st.values^) DO
WITH z = st.val_info[i], col = i+1 DO
ref := NIL;
CASE z.datatype OF
| DataType.Null =>
(* no value *)
ref := NIL;
| DataType.Char,
DataType.Binary,
DataType.VarChar,
DataType.VarBinary,
DataType.LongVarChar,
DataType.LongVarBinary =>
MapString (st, z, col);
ref := z.ref;
| DataType.BigInt =>
VAR big: BigIntPtr := z.ptr; rr: RefBigInt; BEGIN
err := SQL.SQLGetData (st.hstmt, col, SQL.SQL_BIGINT,
ADR (big.value), BYTESIZE (big.value), ADR (big.data_len));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
IF (big.data_len > 0) THEN
rr := z.ref;
rr.lo := big.value.lo;
rr.hi := big.value.hi;
ref := rr;
END;
END;
| DataType.Integer,
DataType.SmallInt,
DataType.TinyInt =>
VAR int: IntPtr := z.ptr; rr: REF INTEGER; BEGIN
err := SQL.SQLGetData (st.hstmt, col, SQL.SQL_C_SLONG,
ADR (int.value), BYTESIZE (int.value), ADR (int.data_len));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
IF (int.data_len > 0) THEN
rr := z.ref;
rr^ := int.value;
ref := rr;
END;
END;
| DataType.Numeric,
DataType.Decimal,
DataType.Float,
DataType.Double =>
VAR flt: FloatPtr := z.ptr; rr: REF LONGREAL; BEGIN
err := SQL.SQLGetData (st.hstmt, col, SQL.SQL_C_DOUBLE,
ADR (flt.value), BYTESIZE (flt.value), ADR (flt.data_len));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
IF (flt.data_len > 0) THEN
rr := z.ref;
rr^ := flt.value;
ref := rr;
END;
END;
| DataType.Real =>
VAR flt: RealPtr := z.ptr; rr: REF REAL; BEGIN
err := SQL.SQLGetData (st.hstmt, col, SQL.SQL_C_FLOAT,
ADR (flt.value), BYTESIZE (flt.value), ADR (flt.data_len));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
IF (flt.data_len > 0) THEN
rr := z.ref;
rr^ := flt.value;
ref := rr;
END;
END;
| DataType.Bit =>
VAR bit: BitPtr := z.ptr; rr: REF BOOLEAN; BEGIN
err := SQL.SQLGetData (st.hstmt, col, SQL.SQL_C_SHORT,
ADR (bit.value), BYTESIZE (bit.value), ADR (bit.data_len));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
IF (bit.data_len > 0) THEN
rr := z.ref;
rr^ := (bit.value # 0);
ref := rr;
END;
END;
| DataType.Date =>
VAR dat: DatePtr := z.ptr; rr: RefDate; BEGIN
IF (dat.data_len > 0) THEN
err := SQL.SQLGetData (st.hstmt, col, SQL.SQL_C_DATE,
ADR (dat.value), BYTESIZE (dat.value), ADR (dat.data_len));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
rr := z.ref;
rr.year := dat.value.year;
rr.month := dat.value.month;
rr.day := dat.value.day;
ref := rr;
END;
END;
| DataType.Time =>
VAR tim: TimePtr := z.ptr; rr: RefTime; BEGIN
err := SQL.SQLGetData (st.hstmt, col, SQL.SQL_C_TIME,
ADR (tim.value), BYTESIZE (tim.value), ADR (tim.data_len));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
IF (tim.data_len > 0) THEN
rr := z.ref;
rr.hour := tim.value.hour;
rr.minute := tim.value.minute;
rr.second := tim.value.second;
ref := rr;
END;
END;
| DataType.Timestamp =>
VAR ts: TimeStampPtr := z.ptr; rr: RefTimestamp; BEGIN
err := SQL.SQLGetData (st.hstmt, col, SQL.SQL_C_TIMESTAMP,
ADR (ts.value), BYTESIZE (ts.value), ADR (ts.data_len));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
IF (ts.data_len > 0) THEN
rr := z.ref;
rr.year := ts.value.year;
rr.month := ts.value.month;
rr.day := ts.value.day;
rr.hour := ts.value.hour;
rr.minute := ts.value.minute;
rr.second := ts.value.second;
rr.fraction := ts.value.fraction;
ref := rr;
END;
END;
END; (* CASE *)
st.values [i] := ref;
END; (* WITH z *)
END;
RETURN st.values;
END MapValues;
TYPE
RcvBuffer = ARRAY [0..1023] OF CHAR;
PROCEDURE MapString (st: Stmt; VAR z: ValueInfo; col: CARDINAL) RAISES {Error} =
VAR
rr : RefString := z.ref;
str : StringPtr := z.ptr;
offset : CARDINAL := 0;
len : SQLINTEGER;
err : INTEGER;
buf : RcvBuffer;
BEGIN
LOOP
err := SQL.SQLGetData (st.hstmt, col, SQL.SQL_C_BINARY,
ADR(buf[0]), BYTESIZE (buf), ADR (len));
IF (err = SQL.SQL_SUCCESS) THEN
(* ok, got all the remaining data *)
CopyData (z, offset, buf, len);
EXIT;
ELSIF (err = SQL.SQL_SUCCESS_WITH_INFO)
AND ((len > BYTESIZE (buf)) OR (len = SQL.SQL_NO_TOTAL)) THEN
(* assume it's a "data truncated" error and continue... *)
CopyData (z, offset, buf, len);
ELSE (* must be a "real" error *)
CheckErr (err, st);
END;
END;
IF (z.buffer = NIL) THEN
str.data_ptr := NIL;
str.n_elts := 0;
ELSE
str.data_ptr := ADR (z.buffer[0]);
str.n_elts := offset;
END;
rr^ := LOOPHOLE (str, UNTRACED REF ARRAY OF CHAR);
(* rr^ := ADR(str^) also works, but is more puzzling. *)
END MapString;
PROCEDURE CopyData (VAR z: ValueInfo; VAR offset: CARDINAL;
READONLY buf: RcvBuffer; len: INTEGER) =
BEGIN
IF (len = SQL.SQL_NO_TOTAL) THEN
(* ODBC isn't telling how much data we're going to get! *)
len := BYTESIZE (buf);
END;
IF (z.buffer = NIL) OR (NUMBER (z.buffer^) < offset + len) THEN
IF (z.buffer # NIL) THEN DISPOSE (z.buffer); END;
z.buffer := NEW (Buffer, Word.And (offset + len + 16_ff, Word.Not (16_ff)));
END;
len := MAX (0, MIN (len, BYTESIZE (buf)));
SUBARRAY (z.buffer^, offset, len) := SUBARRAY (buf, 0, len);
INC (offset, len);
END CopyData;
PROCEDURE Done (st: Stmt) RAISES {Error} =
VAR err: SQLRETURN;
BEGIN
LOCK st DO
CheckStmt (st, 21, "finish", check_exec := FALSE);
err := SQL.SQLFreeStmt (st.hstmt, SQL.SQL_CLOSE);
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
st.prepared := FALSE;
st.executed := FALSE;
END;
END Done;
PROCEDURE Close (st: Stmt) RAISES {Error} =
VAR err: SQLRETURN;
BEGIN
LOCK st DO
CheckStmt (st, 24, "close", check_exec := FALSE);
err := SQL.SQLFreeStmt (st.hstmt, SQL.SQL_DROP);
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
DisposeStmt (st);
END;
END Close;
PROCEDURE GetCursorName (st: Stmt): TEXT RAISES {Error} =
VAR err: SQLRETURN; len: SQLSMALLINT; buf: ARRAY [0..255] OF CHAR;
BEGIN
LOCK st DO
CheckStmt (st, 27, "get the cursor name from", check_exec := FALSE);
err := SQL.SQLGetCursorName (st.hstmt, ADR (buf[0]), BYTESIZE (buf),
ADR (len));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
END;
len := MAX (0, MIN (len, NUMBER (buf)));
RETURN Text.FromChars (SUBARRAY (buf, 0, len));
END GetCursorName;
PROCEDURE SetCursorName (st: Stmt; nm: TEXT) RAISES {Error} =
VAR
err: SQLRETURN;
nm_c := M3toC.SharedTtoS(nm);
BEGIN
LOCK st DO
CheckStmt (st, 30, "set the cursor name in", check_exec := FALSE);
err := SQL.SQLSetCursorName (st.hstmt, LOOPHOLE(nm, SQLCHAR_star),
Text.Length (nm));
M3toC.FreeSharedS(nm, nm_c);
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
END;
END SetCursorName;
PROCEDURE NumRows (st: Stmt): INTEGER RAISES {Error} =
VAR err: SQLRETURN; cnt: SQLINTEGER;
BEGIN
LOCK st DO
CheckStmt (st, 33, "get the row count from", check_exec := TRUE);
err := SQL.SQLRowCount (st.hstmt, ADR (cnt));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
END;
RETURN cnt;
END NumRows;
PROCEDURE DescribeResult (st: Stmt): ResultDesc RAISES {Error} =
VAR res: ResultDesc;
BEGIN
LOCK st DO
CheckStmt (st, 36, "get the result description from", check_exec := TRUE);
IF (st.col_info = NIL) THEN BuildColumnInfo (st); END;
res := NEW (ResultDesc, NUMBER (st.col_info^));
res^ := st.col_info^;
END;
RETURN res; (* we return a fresh copy so the client can't screw up our copy. *)
END DescribeResult;
PROCEDURE BuildColumnInfo (st: Stmt) RAISES {Error} =
(* LL = st.mu *)
VAR
err : SQLRETURN;
cnt : SQLSMALLINT;
nm : ARRAY [0..255] OF CHAR;
nm_len : SQLSMALLINT;
sqltype : SQLSMALLINT;
coldef : SQLUINTEGER;
scale : SQLSMALLINT;
nullable: SQLSMALLINT;
BEGIN
IF (st.col_info # NIL) THEN RETURN; END;
err := SQL.SQLNumResultCols (st.hstmt, ADR (cnt));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
st.col_info := NEW (ResultDesc, cnt);
FOR i := 0 TO cnt-1 DO
err := SQL.SQLDescribeCol (st.hstmt, i+1,
ADR (nm[0]), BYTESIZE (nm), ADR (nm_len),
ADR (sqltype), ADR(coldef), ADR(scale),
ADR (nullable));
IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, st); END;
nm_len := MAX (0, MIN (nm_len, NUMBER (nm)));
WITH z = st.col_info[i] DO
z.name := Text.FromChars (SUBARRAY (nm, 0, nm_len));
z.type := MapSqlType (sqltype);
z.precision := coldef;
z.scale := scale;
z.nullable := MapNullable (nullable);
END;
END;
END BuildColumnInfo;
PROCEDURE MapSqlType (sqltype: INTEGER): DataType RAISES {Error} =
VAR dt: DataType;
BEGIN
CASE sqltype OF
| SQL.SQL_TYPE_NULL => dt := DataType.Null;
| SQL.SQL_CHAR => dt := DataType.Char;
| SQL.SQL_NUMERIC => dt := DataType.Numeric;
| SQL.SQL_DECIMAL => dt := DataType.Decimal;
| SQL.SQL_INTEGER => dt := DataType.Integer;
| SQL.SQL_SMALLINT => dt := DataType.SmallInt;
| SQL.SQL_FLOAT => dt := DataType.Float;
| SQL.SQL_REAL => dt := DataType.Real;
| SQL.SQL_DOUBLE => dt := DataType.Double;
| SQL.SQL_VARCHAR => dt := DataType.VarChar;
| SQL.SQL_DATE => dt := DataType.Date;
| SQL.SQL_TIME => dt := DataType.Time;
| SQL.SQL_TIMESTAMP => dt := DataType.Timestamp;
| SQL.SQL_LONGVARCHAR => dt := DataType.LongVarChar;
| SQL.SQL_BINARY => dt := DataType.Binary;
| SQL.SQL_VARBINARY => dt := DataType.VarBinary;
| SQL.SQL_LONGVARBINARY => dt := DataType.LongVarBinary;
| SQL.SQL_BIGINT => dt := DataType.BigInt;
| SQL.SQL_TINYINT => dt := DataType.TinyInt;
| SQL.SQL_BIT => dt := DataType.Bit;
ELSE Die (7, "DB.MapDatatype: unknown SQL datatype: " & Fmt.Int(ORD(sqltype)));
END;
RETURN dt;
END MapSqlType;
PROCEDURE MapNullable (nullable: INTEGER): Nullable RAISES {Error} =
VAR nn: Nullable;
BEGIN
IF (nullable = SQL.SQL_NULLABLE) THEN nn := Nullable.Yes;
ELSIF (nullable = SQL.SQL_NO_NULLS) THEN nn := Nullable.No;
ELSIF (nullable = SQL.SQL_NULLABLE_UNKNOWN) THEN nn := Nullable.Unknown;
ELSE Die (8, "DB.MapNullable: unknown 'nullable' value");
END;
RETURN nn;
END MapNullable;
PROCEDURE CheckStmt (st: Stmt; err: INTEGER; verb: TEXT; check_exec := FALSE)
RAISES {Error} =
BEGIN
IF (st.hstmt = SQL.SQL_NULL_HSTMT) THEN
Die (err, "Attempted to " & verb & " a closed DB.Stmt");
END;
IF (check_exec) AND (NOT st.executed) THEN
Die (err+1, "Attempted to " & verb & " an unexecuted DB.Stmt");
END;
IF (st.conn = NIL) OR (st.conn.hdbc = SQL.SQL_NULL_HDBC) THEN
Die (err+2, "Attempted to " & verb & " a DB.Stmt on a disconnected DB.T.");
END;
END CheckStmt;
--------------------------------------- misc. DB server information ---
PROCEDURE------------------------------------------------------------- DBRep ---GetDataSources (): DescList RAISES {Error} = VAR direction := SQL.SQL_FETCH_FIRST; err : SQLRETURN; srclen : SQLSMALLINT; desclen : SQLSMALLINT; source : ARRAY [0..255] OF CHAR; desc : ARRAY [0..255] OF CHAR; results : DescList := NIL; a, b : DescList; BEGIN Init (); LOOP err := SQL.SQLDataSources (henv, direction, ADR (source[0]), BYTESIZE (source), ADR(srclen), ADR (desc[0]), BYTESIZE (desc), ADR(desclen)); IF (err = SQL.SQL_NO_DATA_FOUND) THEN EXIT; END; IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, NIL); END; a := NEW (DescList); srclen := MAX (0, MIN (srclen, NUMBER (source))); a.name := Text.FromChars (SUBARRAY (source, 0, srclen)); desclen := MAX (0, MIN (desclen, NUMBER (source))); a.description := Text.FromChars (SUBARRAY (desc, 0, desclen)); a.next := results; results := a; direction := SQL.SQL_FETCH_NEXT; END; (*loop*) (* put the results back in the order that the database returned them... *) a := results; b := NIL; results := NIL; WHILE (a # NIL) DO b := a.next; a.next := results; results := a; a := b; END; RETURN results; END GetDataSources; PROCEDUREGetDrivers (): DescList RAISES {Error} = VAR direction := SQL.SQL_FETCH_FIRST; err : SQLRETURN; srclen : SQLSMALLINT; desclen : SQLSMALLINT; source : ARRAY [0..255] OF CHAR; desc : ARRAY [0..255] OF CHAR; results : DescList := NIL; a, b : DescList; BEGIN Init (); LOOP err := SQLext.SQLDrivers (henv, direction, ADR (source[0]), BYTESIZE (source), ADR(srclen), ADR (desc[0]), BYTESIZE (desc), ADR(desclen)); IF (err = SQL.SQL_NO_DATA_FOUND) THEN EXIT; END; IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, NIL); END; a := NEW (DescList); srclen := MAX (0, MIN (srclen, NUMBER (source))); a.name := Text.FromChars (SUBARRAY (source, 0, srclen)); desclen := MAX (0, MIN (desclen, NUMBER (source))); a.description := Text.FromChars (SUBARRAY (desc, 0, desclen)); a.next := results; results := a; direction := SQL.SQL_FETCH_NEXT; END; (*loop*) (* put the results back in the order that the database returned them... *) a := results; b := NIL; results := NIL; WHILE (a # NIL) DO b := a.next; a.next := results; results := a; a := b; END; RETURN results; END GetDrivers;
PROCEDURE--------------------------------------------- errors and exceptions ---GetHENV (): SQLHENV = BEGIN RETURN henv; END GetHENV; PROCEDUREGetHDBC (t: T): SQLHDBC = BEGIN RETURN t.hdbc; END GetHDBC; PROCEDUREGetHSTMT (st: Stmt): SQLHSTMT = BEGIN RETURN st.hstmt; END GetHSTMT;
PROCEDURE----------------------------------------- misc. internal functions ---CheckErr (err: SQLRETURN; stmt: Stmt; conn: T := NIL) RAISES {Error} = VAR HDBC := SQL.SQL_NULL_HDBC; hstmt := SQL.SQL_NULL_HSTMT; desc := NEW (ErrorDesc); msg : ARRAY [0..255] OF CHAR; len : SQLSMALLINT; xxx : SQLRETURN; BEGIN IF (err = SQL.SQL_SUCCESS) OR (err = SQL.SQL_SUCCESS_WITH_INFO) THEN RETURN; END; IF (stmt # NIL) THEN hstmt := stmt.hstmt; conn := stmt.conn; END; IF (conn # NIL) THEN HDBC := conn.hdbc; END; xxx := SQL.SQLError (henv, HDBC, hstmt, ADR (desc.state), ADR (desc.native_err), ADR (msg[0]), BYTESIZE (msg), ADR (len)); IF (len > 0) THEN len := MIN (len, NUMBER (msg)); desc.description := Text.FromChars (SUBARRAY (msg, 0, len)); END; RAISE Error (desc); END CheckErr; PROCEDUREDie (id: [0..999]; msg: TEXT) RAISES {Error} = CONST Zero = ORD ('0'); VAR desc := NEW (ErrorDesc); BEGIN desc.state[5] := '\000'; desc.state[4] := VAL (Zero + id MOD 10, CHAR); id := id DIV 10; desc.state[3] := VAL (Zero + id MOD 10, CHAR); id := id DIV 10; desc.state[2] := VAL (Zero + id MOD 10, CHAR); desc.state[1] := '3'; desc.state[0] := 'M'; desc.native_err := 0; desc.description := "[Modula-3 DB]" & msg; RAISE Error (desc); END Die;
PROCEDUREInit () RAISES {Error} = VAR err: SQLRETURN; BEGIN IF (henv = SQL.SQL_NULL_HENV) THEN LOCK mu DO IF (henv = SQL.SQL_NULL_HENV) THEN err := SQL.SQLAllocEnv (ADR (henv)); IF (err # SQL.SQL_SUCCESS) THEN CheckErr (err, NIL); END; Process.RegisterExitor (ShutDown); END; END; END; END Init; PROCEDUREShutDown () = BEGIN IF (henv # SQL.SQL_NULL_HENV) THEN EVAL SQL.SQLFreeEnv (henv); (* ignore the errors! *) henv := SQL.SQL_NULL_HENV; END; END ShutDown; BEGIN END DB.