mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-18 10:53:40 +00:00
Code Issues Projects Releases Wiki Activity
Files
083d376e6598628362ee91c2da170febd83590f4
mercury/extras/odbc/odbc.m
Julien Fischer 2a366cf295 Deprecate --no-ansi and --no-ansi-c. 
--no-ansi (mgnuc) and --no-ansi-c (mmc) have not actually done anything for
many years now. Deprecate these options and remove their "use" throughout most
of the Mercury system. (The remaining uses are in the Makefiles for the Boehm
GC, which need to be updated separately.)

Also deprecate the internal compiler option --cflags-for-ansi.

compiler/options.m:
    Document that --no-ansi-c is now deprecated.

    Document that the internal option --cflags-for-ansi is now
    deprecated.

compiler/compile_target_code.m:
    Do not pass the ANSI options to the C compiler.

scripts/mgnuc.in:
scripts/mgnuc_file_opts.sh-subr:
    Deprecate the --no-ansi option; delete code that no longer does
    anything useful.

configure.ac:
    Delete the configuration variable CFLAGS_FOR_ANSI; it is only ever
    set to be empty. (The comment talks about --no-ansi doing other things
    in the mgnuc script. It used to also cause some preprocessor macros
    to be defined for compatibility with the system headers on some
    platforms -- that has not been the case since 2013.)

doc/user_guide.texi:
    Document that --no-ansi-c is deprecated.

bytecode/Mmakefile:
compiler/Mercury.options:
library/Mercury.options:
extras/odbc/odbc.m:
runtime/Mmakefile:
scripts/Mercury.config.bootstrap.in:
scripts/Mercury.config.in:
tests/hard_coded/Mercury.options:
tests/valid/Mercury.options:
trace/Mmakefile:
util/Mmakefile:
    Conform to the above change.

NEWS.md:
    Announce the above.
2023-05-31 17:44:26 +10:00

2217 lines
73 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1997 Mission Critical.
% Copyright (C) 1997-2000, 2002, 2004-2006, 2010 The University of Melbourne.
% Copyright (C) 2017-2018, 2020, 2023 The Mercury team.
% This file is distributed under the terms specified in COPYING.LIB.
%---------------------------------------------------------------------------%
%
% File: odbc.m.
% Authors: Renaud Paquay (rpa@miscrit.be), stayl.
% ODBC version: 2.0.
%
% The transaction interface used here is described in the following paper:
%
% Kemp, Conway, Harris, Henderson, Ramamohanarao and Somogyi,
% "Database transactions in a purely declarative logic programming language".
% In Proceedings of the Fifth International Conference on Database
% Systems for Advanced Applications, pp. 283-292.
% Melbourne, Australia, 1-4 April, 1997.
%
% An earlier(?) version of this paper is available as
% Technical Report 96/45, Department of Computer Science,
% University of Melbourne, December 1996,
% <https://mercurylang.org/documentation/papers/tr_96_45_cover.ps.gz>
% and <https://mercurylang.org/documentation/papers/tr_96_45.ps.gz>.
%
% This has been tested using the following platforms:
% - MySQL 3.20.19 and iODBC 2.12 under Solaris 2.5
% - MySQL 3.22.32 and iODBC 2.50.3 under Solaris 2.6
% - Microsoft SQL Server 6.5 under Windows NT 4.0 with the
% GNU-Win32 tools beta 17.1
%
% Notes:
%
% Binary data is converted to a string of hexadecimal digits.
%
% This module requires a compilation grade with conservative garbage
% collection. Any grade containing .gc in its name, such as asm_fast.gc,
% will do. See the section "Compilation model options" in the Mercury
% User's Guide for more information.
%
% The header files distributed with the Microsoft ODBC SDK require
% some modification for compilation with gcc. In particular,
% some conflicting typedefs for SQLUINTEGER and SQLSCHAR must be
% removed from sqltypes.h.
% (For legal reasons a patch cannot be included in the Mercury
% distribution.)
%
% To do:
%
% Improve the interface to the catalog functions.
%
% Add a nicer interface so the user does not need to manipulate
% SQL strings.
%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- module odbc.
:- interface.
:- import_module list.
:- import_module io.
:- import_module pair.
:- import_module string.
%-----------------------------------------------------------------------------%
%
% Predicates and types for transaction processing
%
:- type data_source == string.
:- type user_name == string.
:- type password == string.
% A closure to be executed atomically.
%
:- type transaction(T) == pred(T, odbc.state, odbc.state).
:- mode transaction == (pred(out, di, uo) is det).
:- type state.
% transaction(Source, UserName, Password, Transaction, Result).
%
% Open a connection to `Source' using the given `UserName'
% and `Password', perform `Transaction' within a transaction
% using that connection, then close the connection.
%
% `Result' is `ok(Results) - Messages' if the transaction
% succeeds or `error - Messages' if the transaction is aborted.
% Whether updates are rolled back if the transaction aborts depends
% on the database. MySQL will not roll back updates.
%
% If `Transaction' throws an exception, odbc.transaction will
% attempt to roll back the transaction, and will then rethrow
% the exception to the caller.
%
:- pred transaction(data_source::in, user_name::in, password::in,
transaction(T)::transaction, odbc.result(T)::out, io::di, io::uo) is det.
% Abort the current transaction, returning the given error message.
%
:- pred rollback(string::in, odbc.state::di, odbc.state::uo) is erroneous.
%-----------------------------------------------------------------------------%
%
% Predicates and types for execution of SQL statements
%
:- type row == list(odbc.attribute).
:- type attribute
---> null % SQL NULL value
; int(int)
; string(string)
; float(float)
; time(string). % Time string: "YYYY-MM-DD hh:mm:ss.mmm"
% The odbc.state arguments threaded through these predicates
% enforce the restriction that database activity can only occur
% within a transaction, since odbc.states are only available
% to the closure called by odbc.transaction/5.
% Execute an SQL statement which doesn't return any results, such
% as DELETE.
%
:- pred execute(string::in, odbc.state::di, odbc.state::uo) is det.
% Execute an SQL statement, returning a list of results in the
% order they are returned from the database.
%
:- pred solutions(string::in, list(odbc.row)::out,
odbc.state::di, odbc.state::uo) is det.
% Execute an SQL statement, applying the accumulator predicate
% to each element of the result set as it is returned from
% the database.
%
:- pred aggregate(string, pred(odbc.row, T, T), T, T,
odbc.state, odbc.state).
:- mode aggregate(in, pred(in, in, out) is det, in, out, di, uo) is det.
:- mode aggregate(in, pred(in, di, uo) is det, di, uo, di, uo) is det.
%-----------------------------------------------------------------------------%
%
% Predicates and types to get information about database tables.
%
% This is very incomplete, it would be nice to be able to get information
% about the columns in a table and about privileges for tables and columns.
:- type source_desc
---> source_desc(
odbc.data_source, % name
string % description
).
:- type search_pattern
---> any % _ matches any single character.
; pattern(string). % Matches a sequence of characters.
% Information about a table accessible by a transaction.
%
:- type table_desc
---> table_desc(
string, % table qualifier
string, % table owner
string, % table name
string, % table type
string, % description
list(odbc.attribute) % data source specific columns
).
% Get a list of all the available data sources.
% Note that iODBC 2.12 doesn't implement this.
%
:- pred data_sources(odbc.result(list(odbc.source_desc))::out,
io::di, io::uo) is det.
% tables(QualifierPattern, OwnerPattern, TableNamePattern, Result).
%
% Get a list of database tables matching the given description.
% Note that wildcards are not allowed in the QualifierPattern.
% This is fixed in ODBC 3.0.
%
:- pred tables(odbc.search_pattern::in, odbc.search_pattern::in,
odbc.search_pattern::in, list(odbc.table_desc)::out,
odbc.state::di, odbc.state::uo) is det.
%-----------------------------------------------------------------------------%
%
% The following types are used to return status and error information from
% ODBC calls.
%
:- type result == pair(odbc.status, list(odbc.message)).
:- type status
---> ok
; error.
% The message list returned from a transaction contains all errors
% and warnings reported by the driver during the transaction in
% the order that they were reported.
%
:- type result(T) == pair(odbc.status(T), list(odbc.message)).
:- type status(T)
---> ok(T)
; error.
:- type message == pair(odbc.message_type, string).
:- type message_type
---> warning(odbc.warning)
; error(odbc.error).
:- type warning
---> disconnect_error
; fractional_truncation
; general_warning
; null_value_in_set_function
; privilege_not_revoked
; privilege_not_granted
; string_data_truncated.
:- type error
---> connection_error(odbc.connection_error)
; execution_error(odbc.execution_error)
; feature_not_implemented
; general_error
; internal_error
; timeout_expired
; transaction_error(odbc.transaction_error)
; user_requested_rollback.
:- type connection_error
---> unable_to_establish
; invalid_authorization
; connection_name_in_use
; nonexistent_connection
; connection_rejected_by_server
; connection_failure
; timeout_expired.
:- type execution_error
---> column_already_exists
; column_not_found
; division_by_zero
; general_error
; incorrect_count_field
; incorrect_derived_table_arity
; index_already_exists
; index_not_found
; integrity_constraint_violation
; interval_field_overflow
; invalid_cast_specification
; invalid_date_time
; invalid_escape
; invalid_insert_value_list
; invalid_schema_name
; invalid_use_of_default_parameter
; length_mismatch_in_string_data
; no_default_for_column
; overflow
; range_error
; restricted_data_type_violation
; string_data_length_mismatch
; string_data_truncated
; syntax_error_or_access_violation
; table_or_view_already_exists
; table_or_view_not_found.
:- type transaction_error
---> rolled_back
; still_active
; serialization_failure
; invalid_state.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module assoc_list.
:- import_module bool.
:- import_module exception.
:- import_module int.
:- import_module require.
:- import_module unit.
:- import_module univ.
:- pragma require_feature_set([conservative_gc]).
%-----------------------------------------------------------------------------%
% We don't actually store anything in the odbc.state, since that
% would make the exception handling more inconvenient and error-prone.
% The odbc.state would have to be stored in a global anyway just
% before calling longjmp.
% All the data related to a transaction (ODBC handles, error messages)
% is stored in the global variables defined below.
%
:- type state == unit.
:- pragma foreign_decl("C", "
#include ""mercury_imp.h""
#include <stdio.h>
#include <stdlib.h>
#include <setjmp.h>
#include <assert.h>
// odbc.m allocates memory within may_call_mercury pragma C code,
// which is a bit dodgy in non-conservative GC grades.
// Allowing non-conservative GC grades would require a bit of fairly
// error-prone code to save/restore the heap pointer in the right
// places. When accurate garbage collection is implemented and a
// nicer way of allocating heap space from within C code is available,
// this should be revisited.
// Conservative garbage collection also makes restoring the state
// after an exception a bit simpler.
#ifndef MR_CONSERVATIVE_GC
#error ""The OBDC interface requires conservative garbage collection. \\
Use a compilation grade containing .gc.""
#endif // ! MR_CONSERVATIVE_GC
// For use with iODBC.
#ifdef MODBC_IODBC
#include ""isql.h""
#include ""isqlext.h""
// #include ""odbc_funcs.h""
#include ""sqltypes.h""
// iODBC 2.12 doesn't define this, so define it to something harmless.
#ifndef SQL_NO_DATA
#define SQL_NO_DATA SQL_NO_DATA_FOUND
#endif
#endif // MODBC_IODBC
// For use with unixODBC.
#ifdef MODBC_UNIX
#include ""sql.h""
#include ""sqlext.h""
#include ""sqltypes.h""
#endif // MODBC_UNIX
// For interfacing directly with ODBC driver bypassing driver managers
// such as iODBC.
#ifdef MODBC_ODBC
#include ""sql.h""
#include ""sqlext.h""
#include ""sqltypes.h""
#ifndef SQL_NO_DATA
#define SQL_NO_DATA SQL_NO_DATA_FOUND
#endif
#endif // MODBC_ODBC
#ifdef MODBC_MS
// ODBC_VER set to 0x0250 means that this uses only ODBC 2.0
// functionality but compiles with the ODBC 3.0 header files.
#define ODBC_VER 0x0250
// The following is needed to allow the Microsoft headers to
// compile with GNU C under gnu-win32.
#if defined(__GNUC__) && !defined(__stdcall)
#define __stdcall __attribute__((stdcall))
#endif
#if defined(__CYGWIN32__) && !defined(WIN32)
#define WIN32 1
#endif
#include <windows.h>
#include ""sql.h""
#include ""sqlext.h""
#include ""sqltypes.h""
#endif // MODBC_MS
// Assert the implication: a => b
#define MR_ASSERT_IMPLY(a,b) MR_assert( !(a) || (b) )
// All integers get converted to long by the driver, then to MR_Integer.
// All floats get converted to double by the driver, then to MR_Float.
typedef long MODBC_C_INT;
typedef double MODBC_C_FLOAT;
// Define some wrappers around setjmp and longjmp for exception
// handling. We need to use MR_setjmp and MR_longjmp because we'll
// be longjmping across C->Mercury calls, so we need to restore
// some state in runtime/engine.c.
// Beware: the Mercury registers must be valid when odbc_catch
// is called. odbc_throw will clobber the general-purpose registers
// r1, r2, etc.
#define odbc_catch(longjmp_label) \
MR_setjmp(&odbc_trans_jmp_buf, longjmp_label)
#define odbc_throw() MR_longjmp(&odbc_trans_jmp_buf)
// odbc_trans_jmp_buf stores information saved by odbc_catch (setjmp)
// to be used by odbc_throw (longjmp) when a database exception is found.
extern MR_jmp_buf odbc_trans_jmp_buf;
// odbc_env_handle is the output of SQLAllocEnv. SQLAllocEnv must
// be called before attempting to open any connections.
extern SQLHENV odbc_env_handle;
// The connection being acted on by the current transaction.
extern SQLHDBC odbc_connection;
// The last return code from an ODBC system call.
extern SQLRETURN odbc_ret_code;
// The list of accumulated warnings and errors for the transaction
// in reverse order.
extern MR_Word odbc_message_list;
extern void
odbc_transaction_c_code(MR_Word type_info, SQLHDBC Connection,
MR_Word Closure, MR_Word *Results, MR_Bool *GotMercuryException,
MR_Word *Exception, MR_Integer *Status, MR_Word *Msgs);
extern MR_bool
odbc_check(SQLHENV, SQLHDBC, SQLHSTMT, SQLRETURN);
").
:- pragma foreign_code("C", "
MR_jmp_buf odbc_trans_jmp_buf;
SQLHENV odbc_env_handle = SQL_NULL_HENV;
SQLHDBC odbc_connection = SQL_NULL_HDBC;
SQLRETURN odbc_ret_code = SQL_SUCCESS;
MR_Word odbc_message_list;
").
%-----------------------------------------------------------------------------%
transaction(Source, User, Password, Closure, Result, !IO) :-
% We could have separate open and close connection predicates in the
% interface, but that would just be more effort for the programmer
% for a very minor efficiency gain. The connection time will be
% insignificant for even trivial queries.
open_connection(Source, User, Password, ConnectStatus - ConnectMessages,
!IO),
(
ConnectStatus = ok(Connection),
% Do the transaction.
transaction_2(Connection, Closure, Data, GotMercuryException,
Exception, Status, RevMessages, !IO),
list.reverse(RevMessages, TransMessages),
close_connection(Connection, CloseStatus - CloseMessages, !IO),
% Pass on any exception that was found while
% processing the transaction.
(
GotMercuryException = yes,
rethrow(exception(Exception))
;
GotMercuryException = no,
list.condense([ConnectMessages, TransMessages, CloseMessages],
Messages),
( if odbc.ok(Status), CloseStatus = ok then
Result = ok(Data) - Messages
else
Result = error - Messages
)
)
;
ConnectStatus = error,
Result = error - ConnectMessages
).
:- pred transaction_2(connection::in,
pred(T, odbc.state, odbc.state)::in(pred(out, di, uo) is det),
T::out, bool::out, univ::out, int::out, list(odbc.message)::out,
io::di, io::uo) is det.
:- pragma foreign_proc("C",
transaction_2(Connection::in, Closure::in(pred(out, di, uo) is det),
Results::out, GotMercuryException::out, Exception::out,
Status::out, Msgs::out, IO0::di, IO::uo),
[promise_pure, may_call_mercury],
"
// The Mercury registers must be valid at the call to odbc_catch
// in odbc_transaction_c_code().
// odbc_transaction_c_code() may clobber the Mercury general-purpose
// registers r1, r2, ..., but that is OK, because this C code is
// declared as 'may_call_mercury', so the compiler assumes that it
// is allowed to clobber those registers.
MR_save_transient_registers();
odbc_transaction_c_code(TypeInfo_for_T, Connection, Closure,
&Results, &GotMercuryException, &Exception,
&Status, &Msgs);
MR_restore_transient_registers();
IO = IO0;
").
:- pragma foreign_code("C", "
void
odbc_transaction_c_code(MR_Word TypeInfo_for_T, SQLHDBC Connection,
MR_Word Closure, MR_Word *Results, MR_Bool *GotMercuryException,
MR_Word *Exception, MR_Integer *Status, MR_Word *Msgs)
{
MR_Word DB0 = (MR_Word) 0;
MR_Word DB = (MR_Word) 0;
SQLRETURN rc;
MR_restore_transient_registers();
// Mercury state to restore on rollback.
odbc_connection = Connection;
odbc_message_list = MR_list_empty();
// Set up a location to jump to on a database exception.
// The Mercury registers must be valid here.
odbc_catch(transaction_error);
// Anything changed between the call to odbc_catch() and the call to
// MODBC_odbc__do_transaction() must be declared volatile.
MODBC_odbc__do_transaction(TypeInfo_for_T, Closure,
GotMercuryException, Results, Exception);
// MR_longjmp() cannot be called after here.
if (*GotMercuryException == MR_NO) {
rc = SQLTransact(odbc_env_handle, odbc_connection, SQL_COMMIT);
if (! odbc_check(odbc_env_handle, odbc_connection, SQL_NULL_HSTMT,
rc))
{
goto transaction_error;
}
} else {
// There was a Mercury exception -- abort the transaction.
// The return value of the call to SQLTransact() is ignored
// because the caller won't look at the result --
// it will just rethrow the exception.
MR_DEBUG(printf(
""Mercury exception in transaction: aborting\\n""));
(void) SQLTransact(odbc_env_handle, odbc_connection, SQL_ROLLBACK);
}
*Status = SQL_SUCCESS;
goto transaction_done;
transaction_error:
// Make the database rollback the transaction, if it hasn't already.
*Status = odbc_ret_code;
*GotMercuryException = 0;
rc = SQLTransact(odbc_env_handle, odbc_connection, SQL_ROLLBACK);
odbc_check(odbc_env_handle, odbc_connection, SQL_NULL_HSTMT, rc);
// Fall through.
transaction_done:
*Msgs = odbc_message_list;
odbc_message_list = MR_list_empty();
odbc_connection = SQL_NULL_HDBC;
odbc_ret_code = SQL_SUCCESS;
MR_save_transient_registers();
}
").
%-----------------------------------------------------------------------------%
%
% Call the transaction closure
%
:- pred do_transaction(transaction(T)::transaction, bool::out, T::out,
univ::out, odbc.state::di, odbc.state::uo) is cc_multi.
:- pragma foreign_export("C",
do_transaction(transaction, out, out, out, di, uo),
"MODBC_odbc__do_transaction").
do_transaction(Closure, GotException, Results, Exception, State0, State) :-
try(
( pred(TryResult::out) is det :-
unsafe_promise_unique(State0, State1),
Closure(Result, State1, ResultState),
TryResult = Result - ResultState
), ExceptResult),
(
ExceptResult = succeeded(Results - State2),
unsafe_promise_unique(State2, State),
make_dummy_value(Exception),
GotException = no
;
ExceptResult = exception(Exception),
make_dummy_value(Results),
unsafe_promise_unique(State0, State),
GotException = yes
).
% Produce a value which is never looked at, for returning
% discriminated unions to C.
%
:- pred make_dummy_value(T::out) is det.
:- pragma foreign_proc("C",
make_dummy_value(T::out),
[promise_pure, will_not_call_mercury, thread_safe],
"
T = 0;
").
%-----------------------------------------------------------------------------%
rollback(Error, !DB) :-
odbc.add_message(error(user_requested_rollback) - Error, !DB),
odbc.throw(!DB).
:- pred add_message(odbc.message::in, odbc.state::di, odbc.state::uo) is det.
:- pragma foreign_proc("C",
add_message(Error::in, DB0::di, DB::uo),
[promise_pure, will_not_call_mercury],
"
odbc_message_list = MR_list_cons(Error, odbc_message_list);
DB = DB0;
").
:- pred throw(odbc.state::di, odbc.state::uo) is erroneous.
:- pragma foreign_proc("C",
throw(DB0::di, DB::uo),
[promise_pure, will_not_call_mercury],
"
odbc_ret_code = SQL_ERROR;
odbc_throw();
// DB = DB0; (not reached)
").
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
%
% Predicates and types to manage connections
%
% A connection to a specific source.
%
:- type connection.
% Given the data source to connect to and a user name and password,
% open a connection.
%
:- pred open_connection(data_source::in, user_name::in,
password::in, odbc.result(odbc.connection)::out, io::di, io::uo) is det.
% Close the connection to the given data source.
%
:- pred close_connection(odbc.connection::in, odbc.result::out,
io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
:- pragma foreign_type("C", connection, "SQLHDBC").
open_connection(Source, User, Password, Result - Messages, !IO) :-
do_open_connection(Source, User, Password, Handle, ConnectStatus,
RevMessages, !IO),
list.reverse(RevMessages, Messages),
( if odbc.ok(ConnectStatus) then
Result = ok(Handle)
else
Result = error
).
%-----------------------------------------------------------------------------%
:- pred do_open_connection(string::in, string::in, string::in,
odbc.connection::uo, int::out, list(odbc.message)::out, io::di, io::uo)
is det.
:- pragma foreign_proc("C",
do_open_connection(Source::in, User::in, Password::in, Handle::uo,
Status::out, Messages::out, _IO0::di, _IO::uo),
[promise_pure, may_call_mercury],
"
SQLHDBC connect_handle;
if (odbc_env_handle == SQL_NULL_HENV) {
Status = SQLAllocEnv(&odbc_env_handle);
} else {
Status = SQL_SUCCESS;
}
MR_DEBUG(printf(""SQLAllocEnv status: %d\\n"", (int) Status));
if (odbc_check(odbc_env_handle, SQL_NULL_HDBC,
SQL_NULL_HSTMT, Status)) {
Status = SQLAllocConnect(odbc_env_handle, &connect_handle);
MR_DEBUG(printf(""SQLAllocConnect status: %d\\n"", (int) Status));
if (odbc_check(odbc_env_handle, connect_handle,
SQL_NULL_HSTMT, Status)) {
// Put the connection into manual commit mode.
Status = SQLSetConnectOption(connect_handle,
SQL_AUTOCOMMIT, SQL_AUTOCOMMIT_OFF);
MR_DEBUG(printf(""manual commit status: %d\\n"",
(int) Status));
odbc_check(odbc_env_handle, connect_handle,
SQL_NULL_HSTMT, Status);
}
}
Status = SQLConnect(connect_handle,
(UCHAR *)Source, strlen(Source),
(UCHAR *)User, strlen(User),
(UCHAR *)Password, strlen(Password));
MR_DEBUG(printf(""connect status: %d\\n"", (int) Status));
odbc_check(odbc_env_handle, connect_handle, SQL_NULL_HSTMT, Status);
Messages = odbc_message_list;
odbc_message_list = MR_list_empty();
Handle = connect_handle;
odbc_connection = SQL_NULL_HDBC;
").
%-----------------------------------------------------------------------------%
close_connection(Connection, Result, !IO) :-
do_close_connection(Connection, Status, RevMessages, !IO),
list.reverse(RevMessages, Messages),
( if Status = 0 then
Result = ok - Messages
else
Result = error - Messages
).
:- pred do_close_connection(odbc.connection::in, int::out,
list(odbc.message)::out, io::di, io::uo) is det.
:- pragma foreign_proc("C",
do_close_connection(Handle::in, Status::out, Messages::out,
_IO0::di, _IO::uo),
[promise_pure, may_call_mercury],
"
Status = SQLDisconnect(Handle);
if (odbc_check(odbc_env_handle, Handle,
SQL_NULL_HSTMT, Status)) {
Status = SQLFreeConnect(Handle);
odbc_check(odbc_env_handle, Handle,
SQL_NULL_HSTMT, Status);
}
Messages = odbc_message_list;
odbc_message_list = MR_list_empty();
").
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
execute(SQLString, !DB) :-
some [!Statement] (
odbc.alloc_statement(!:Statement, !DB),
odbc.execute_statement(SQLString, !Statement, !DB),
odbc.cleanup_statement_check_error(!.Statement, !DB)
).
solutions(SQLString, Results, !DB) :-
% XXX optimize this when we have better support
% for last call optimization.
odbc.do_aggregate(odbc.execute_statement(SQLString), list.cons, [],
Results0, !DB),
list.reverse(Results0, Results).
aggregate(SQLString, Accumulator, !Acc, !DB) :-
do_aggregate(odbc.execute_statement(SQLString), Accumulator, !Acc, !DB).
%-----------------------------------------------------------------------------%
:- pred do_aggregate(
pred(odbc.statement, odbc.statement, odbc.state, odbc.state),
pred(odbc.row, T, T), T, T, odbc.state, odbc.state).
:- mode do_aggregate(
pred(di, uo, di, uo) is det,
pred(in, in, out) is det, in, out, di, uo) is det.
:- mode do_aggregate(
pred(di, uo, di, uo) is det,
pred(in, di, uo) is det, di, uo, di, uo) is det.
do_aggregate(Execute, Accumulate, !Result, !DB) :-
some [!Statement] (
alloc_statement(!:Statement, !DB),
Execute(!Statement, !DB),
bind_columns(!Statement, !DB),
get_rows(Accumulate, !Result, !Statement, !DB),
cleanup_statement_check_error(!.Statement, !DB)
).
%-----------------------------------------------------------------------------%
% Get the set of result rows from the statement.
%
:- pred get_rows(pred(odbc.row, T, T), T, T, odbc.statement, odbc.statement,
odbc.state, odbc.state).
:- mode get_rows(pred(in, in, out) is det, in, out, di, uo, di, uo) is det.
:- mode get_rows(pred(in, di, uo) is det, di, uo, di, uo, di, uo) is det.
get_rows(Accumulate, !Result, !Statement, !DB) :-
get_number_of_columns(NumColumns, !Statement, !DB),
get_rows_2(NumColumns, Accumulate, !Result, !Statement, !DB).
:- pred get_rows_2(int, pred(odbc.row, T, T), T, T,
odbc.statement, odbc.statement, odbc.state, odbc.state).
:- mode get_rows_2(in, pred(in, in, out) is det, in, out, di, uo,
di, uo) is det.
:- mode get_rows_2(in, pred(in, di, uo) is det, di, uo, di, uo,
di, uo) is det.
get_rows_2(NumColumns, Accumulate, !Result, !Statement, !DB) :-
% Try to fetch a new row.
fetch_row(!Statement, Status, !DB),
( if no_data(Status) then
true
else
get_attributes(1, NumColumns, Row, !Statement, !DB),
Accumulate(Row, !Result),
get_rows_2(NumColumns, Accumulate, !Result, !Statement, !DB)
).
%-----------------------------------------------------------------------------%
% Get the values from the current fetched row.
%
:- pred get_attributes(int::in, int::in, list(odbc.attribute)::out,
odbc.statement::di, odbc.statement::uo,
odbc.state::di, odbc.state::uo) is det.
get_attributes(CurrCol, NumCols, Row, !Statement, !DB) :-
( if CurrCol =< NumCols then
NextCol = CurrCol + 1,
get_attribute(CurrCol, Attribute, !Statement, !DB),
get_attributes(NextCol, NumCols, Row1, !Statement, !DB),
Row = [Attribute | Row1]
else
Row = []
).
%-----------------------------------------------------------------------------%
% Get the value of a column in the current fetched row.
%
:- pred get_attribute(int::in, odbc.attribute::out,
odbc.statement::di, odbc.statement::uo, odbc.state::di, odbc.state::uo)
is det.
get_attribute(NumColumn, Value, !Statement, !DB) :-
get_data(NumColumn, Int, Float, String, TypeInt, !Statement, !DB),
int_to_attribute_type(TypeInt, Type),
(
Type = null,
Value = null
;
Type = string,
Value = string(String)
;
Type = time,
Value = time(String)
;
Type = int,
Value = int(Int)
;
Type = float,
Value = float(Float)
).
%-----------------------------------------------------------------------------%
:- type attribute_type
---> int
; float
; time
; string
; null.
:- pred int_to_attribute_type(int::in, odbc.attribute_type::out) is det.
int_to_attribute_type(Int, Type) :-
( if int_to_attribute_type_2(Int, Type1) then
Type = Type1
else
error("odbc.int_to_attribute_type: invalid type")
).
% Keep this in sync with the C enum MODBC_AttrType below.
%
:- pred int_to_attribute_type_2(int::in, odbc.attribute_type::out) is semidet.
int_to_attribute_type_2(0, int).
int_to_attribute_type_2(1, float).
int_to_attribute_type_2(2, time).
int_to_attribute_type_2(3, string).
int_to_attribute_type_2(4, string).
int_to_attribute_type_2(5, null).
%-----------------------------------------------------------------------------%
:- type statement.
:- pragma foreign_type("C", statement, "MODBC_Statement *",
[can_pass_as_mercury_type]).
:- pragma foreign_decl("C", "
// Notes on memory allocation:
//
// C data structures (MODBC_Statement and MODBC_Column) are allocated
// using MR_GC_malloc/MR_GC_free.
//
// MODBC_Statement contains a statement handle which must be freed
// using SQLFreeStmt.
//
// Variable length data types are collected in chunks allocated on
// the Mercury heap using MR_incr_hp_atomic. The chunks are then
// condensed into memory allocated on the Mercury heap using
// string.append_list.
// XXX this may need revisiting when accurate garbage collection
// is implemented to make sure the collector can see the data when
// it is stored within a MODBC_Column.
//
// Other data types have a buffer which is allocated once using
// MR_GC_malloc.
// If the driver can't work out how much data is in a blob in advance,
// get the data in chunks. The chunk size is fairly arbitrary.
// MODBC_CHUNK_SIZE must be a multiple of sizeof(MR_Word).
#define MODBC_CHUNK_WORDS 1024
#define MODBC_CHUNK_SIZE (MODBC_CHUNK_WORDS * sizeof(MR_Word))
typedef enum {
MODBC_INT = 0, // Word-sized Integer
MODBC_FLOAT = 1, // Mercury Float
MODBC_TIME = 2, // time and/or date converted to a string
MODBC_STRING = 3, // string, or type converted to a string
MODBC_VAR_STRING = 4, // string with no maximum length
MODBC_NULL = 5
} MODBC_AttrType;
typedef enum { MODBC_BIND_COL, MODBC_GET_DATA } MODBC_BindType;
// Information about a column in a result set.
typedef struct {
size_t size; // size of allocated buffer
MODBC_AttrType attr_type;
SWORD sql_type; // the actual type, e.g. SQL_LONG_VAR_CHAR
SWORD conversion_type;
// the type the data is being converted
// into, e.g SQL_C_CHAR
SDWORD value_info; // size of returned data, or SQL_NULL_DATA
MR_Word *data;
} MODBC_Column;
// Information about a result set.
typedef struct {
SQLHSTMT stat_handle; // statement handle
int num_columns; // columns per row
MODBC_Column *row; // array of columns in the current row
int num_rows; // number of fetched rows
MODBC_BindType binding_type; // are we using SQL_BIND_COL
// or SQL_GET_DATA
} MODBC_Statement;
extern SQLRETURN
odbc_do_cleanup_statement(MODBC_Statement *statement);
extern size_t
odbc_sql_type_to_size(SWORD sql_type, UDWORD cbColDef, SWORD ibScale,
SWORD fNullable);
extern MODBC_AttrType
odbc_sql_type_to_attribute_type(SWORD sql_type);
extern SWORD
odbc_attribute_type_to_sql_c_type(MODBC_AttrType AttrType);
extern MR_bool
odbc_is_variable_length_sql_type(SWORD);
extern void
odbc_do_get_data(MODBC_Statement *statement, int column_id);
extern void
odbc_get_data_in_chunks(MODBC_Statement *statement, int column_id);
extern void
odbc_get_data_in_one_go(MODBC_Statement *statement, int column_id);
").
%-----------------------------------------------------------------------------%
:- pred alloc_statement(odbc.statement::uo,
odbc.state::di, odbc.state::uo) is det.
:- pragma foreign_proc("C",
alloc_statement(Statement::uo, DB0::di, DB::uo),
[promise_pure, may_call_mercury],
"
SQLRETURN rc;
// Doing manual deallocation of the statement object.
Statement = MR_GC_NEW(MODBC_Statement);
Statement->num_columns = 0;
Statement->row = NULL;
Statement->num_rows = 0;
Statement->stat_handle = SQL_NULL_HSTMT;
rc = SQLAllocStmt(odbc_connection, &(Statement->stat_handle));
if (! odbc_check(odbc_env_handle, odbc_connection,
Statement->stat_handle, rc))
{
odbc_throw();
// not reached
}
MR_assert(Statement->stat_handle != SQL_NULL_HSTMT);
DB = DB0;
").
%-----------------------------------------------------------------------------%
:- pred execute_statement(string::in, odbc.statement::di, odbc.statement::uo,
odbc.state::di, odbc.state::uo) is det.
:- pragma foreign_proc("C",
execute_statement(SQLString::in, Statement0::di, Statement::uo,
DB0::di, DB::uo),
[promise_pure, may_call_mercury],
"
SQLRETURN rc;
SQLHSTMT stat_handle;
Statement = Statement0;
stat_handle = Statement->stat_handle;
MR_DEBUG(printf(""executing SQL string: %s\\n"", SQLString));
rc = SQLPrepare(stat_handle, (SQLCHAR *)SQLString, strlen(SQLString));
if (! odbc_check(odbc_env_handle, odbc_connection, stat_handle, rc)) {
// We don't check the return status of this because the programmer
// is likely to be more interested in the earlier error.
odbc_do_cleanup_statement(Statement);
odbc_throw();
// not reached
}
rc = SQLExecute(stat_handle);
if (! odbc_check(odbc_env_handle, odbc_connection, stat_handle, rc)) {
odbc_do_cleanup_statement(Statement);
odbc_throw();
// not reached
}
MR_DEBUG(printf(""execution succeeded\\n""));
DB = DB0;
").
%-----------------------------------------------------------------------------%
% There are two methods to get data back from an ODBC application.
%
% One involves binding a buffer to each column using SQLBindCol,
% then calling SQLFetch repeatedly to read rows into the buffers.
% The problem with this method is it doesn't work with variable
% length data, since if the data doesn't fit into the allocated
% buffer it gets truncated and there's no way to have a second
% try with a larger buffer.
%
% The other method is to not bind any columns. Instead, after
% SQLFetch is called to update the cursor, SQLGetData is used
% on each column to get the data. SQLGetData can be called repeatedly
% to get all the data if it doesn't fit in the buffer. The problem
% with this method is that it requires an extra ODBC function call
% for each attribute received, which may have a significant impact
% on performance if the database is being accessed over a network.
%
% Hybrid methods are also possible if all the variable length columns
% come after the fixed length columns in the result set, but that
% is probably overkill. (SQLGetData can only be used on columns
% after those bound using SQLBindCol).
%
% The first method is used if there are no variable length columns,
% otherwise the second method is used.
%
:- pred bind_columns(odbc.statement::di, odbc.statement::uo,
odbc.state::di, odbc.state::uo) is det.
:- pragma foreign_proc("C",
bind_columns(Statement0::di, Statement::uo, DB0::di, DB::uo),
[promise_pure, may_call_mercury],
"
int column_no;
SQLSMALLINT num_columns;
MODBC_Column *column;
SQLRETURN rc;
SQLHSTMT stat_handle;
Statement = Statement0;
stat_handle = Statement->stat_handle;
// Retrieve the number of columns of the statement.
rc = SQLNumResultCols(stat_handle, &num_columns);
if (! odbc_check(odbc_env_handle, odbc_connection, stat_handle, rc)) {
odbc_do_cleanup_statement(Statement);
odbc_throw();
// not reached
}
Statement->num_columns = num_columns;
// Allocate an array containing the info for each column.
// The extra column is because ODBC counts columns starting from 1.
Statement->row = MR_GC_NEW_ARRAY(MODBC_Column, num_columns + 1);
// Use SQLBindCol unless there are columns with no set maximum length.
Statement->binding_type = MODBC_BIND_COL;
// Get information about the result set columns.
// ODBC counts columns from 1.
for (column_no = 1; column_no <= Statement->num_columns; column_no++) {
char col_name[1]; // Not looked at
SWORD col_name_len;
SWORD col_type;
UDWORD pcbColDef;
SWORD pibScale;
SWORD pfNullable;
column = &(Statement->row[column_no]);
column->size = 0;
column->data = NULL;
// Retrieve the C type of the column.
// (SQL type mapped to a conversion type).
// Create an attribute object with room to store the
// attribute value.
rc = SQLDescribeCol(stat_handle, column_no,
(UCHAR *) col_name, sizeof(col_name),
&col_name_len, &col_type, &pcbColDef,
&pibScale, &pfNullable);
// SQL_SUCCESS_WITH_INFO means there wasn't
// enough space for the column name, but we
// aren't collecting the column name anyway.
if (rc != SQL_SUCCESS_WITH_INFO &&
! odbc_check(odbc_env_handle, odbc_connection,
stat_handle, rc))
{
odbc_do_cleanup_statement(Statement);
odbc_throw();
// not reached
}
column->sql_type = col_type;
column->size = odbc_sql_type_to_size(col_type, pcbColDef,
pibScale, pfNullable);
column->attr_type = odbc_sql_type_to_attribute_type(col_type);
// Request a conversion into one of the supported types.
column->conversion_type =
odbc_attribute_type_to_sql_c_type(column->attr_type);
MR_DEBUG(printf(""Column %i: size %i - sql_type %i - attr_type %i - conversion_type %i\\n"",
column_no, column->size, column->sql_type,
column->attr_type, column->conversion_type));
if (odbc_is_variable_length_sql_type(col_type)) {
Statement->binding_type = MODBC_GET_DATA;
} else {
// Do the buffer allocation once for columns which have
// a fixed maximum length.
column->data = MR_GC_malloc(column->size);
}
} // for
if (Statement->binding_type == MODBC_BIND_COL) {
for (column_no = 1; column_no <= Statement->num_columns; column_no++) {
MR_DEBUG(printf(""Binding column %d/%d\\n"",
column_no, Statement->num_columns));
column = &(Statement->row[column_no]);
rc = SQLBindCol(stat_handle, column_no,
column->conversion_type, (SQLPOINTER) column->data,
column->size, &(column->value_info));
if (! odbc_check(odbc_env_handle, odbc_connection, stat_handle,
rc))
{
odbc_do_cleanup_statement(Statement);
odbc_throw();
// not reached
}
}
}
DB = DB0;
").
%-----------------------------------------------------------------------------%
% Fetch the next row of the current statement.
%
:- pred fetch_row(odbc.statement::di, odbc.statement::uo, int::out,
odbc.state::di, odbc.state::uo) is det.
:- pragma foreign_proc("C",
fetch_row(Statement0::di, Statement::uo, Status::out, DB0::di, DB::uo),
[promise_pure, may_call_mercury],
"
Statement = Statement0;
MR_assert(Statement != NULL);
if (Statement->num_rows == 0 ) {
MR_DEBUG(printf(""Fetching rows...\\n""));
}
// Fetching new row
Status = SQLFetch(Statement->stat_handle);
if (Status != SQL_NO_DATA_FOUND &&
! odbc_check(odbc_env_handle, odbc_connection,
Statement->stat_handle, Status))
{
odbc_do_cleanup_statement(Statement);
odbc_throw();
// not reached
}
// Update number of rows fetched.
if (Status == SQL_SUCCESS) {
Statement->num_rows++;
}
if (Status == SQL_NO_DATA_FOUND) {
MR_DEBUG(printf(""Fetched %d rows\\n"", Statement->num_rows));
}
DB = DB0;
").
%-----------------------------------------------------------------------------%
:- pred get_number_of_columns(int::out,
odbc.statement::di, odbc.statement::uo, odbc.state::di, odbc.state::uo)
is det.
:- pragma foreign_proc("C",
get_number_of_columns(NumColumns::out, Statement0::di, Statement::uo,
DB0::di, DB::uo),
[promise_pure, will_not_call_mercury],
"
Statement = Statement0;
MR_assert(Statement != NULL);
NumColumns = Statement->num_columns;
DB = DB0;
").
%-----------------------------------------------------------------------------%
:- pred get_data(int::in, int::out, float::out, string::out, int::out,
odbc.statement::di, odbc.statement::uo, odbc.state::di, odbc.state::uo)
is det.
:- pragma foreign_proc("C",
get_data(Column::in, Int::out, Flt::out, Str::out, Type::out,
Statement0::di, Statement::uo, DB0::di, DB::uo),
[promise_pure, may_call_mercury],
"
MODBC_Column *col;
SQLRETURN rc;
SDWORD column_info;
Statement = Statement0;
MR_assert(Statement != NULL);
MR_assert(Statement->row != NULL);
MR_DEBUG(printf(""Getting column %i\\n"", (int) Column));
if (Statement->binding_type == MODBC_GET_DATA) {
// Slurp up the data for this column.
odbc_do_get_data(Statement, Column);
}
col = &(Statement->row[Column]);
if (col->value_info == SQL_NULL_DATA) {
Type = MODBC_NULL;
} else {
Type = col->attr_type;
}
switch ((int) Type) {
case MODBC_NULL:
break;
case MODBC_INT: {
MODBC_C_INT data = *(MODBC_C_INT *)(col->data);
Int = (MR_Integer) data;
MR_DEBUG(printf(""got integer %ld\\n"", (long) Int));
// Check for overflow.
if (Int != data) {
MR_Word overflow_message;
MODBC_overflow_message(&overflow_message);
odbc_message_list =
MR_list_cons(overflow_message,
odbc_message_list);
odbc_do_cleanup_statement(Statement);
odbc_throw();
}
break;
}
case MODBC_FLOAT:
Flt = (MR_Float) *(MODBC_C_FLOAT *)(col->data);
MR_DEBUG(printf(""got float %f\\n"", Flt));
break;
case MODBC_STRING:
case MODBC_TIME:
MR_assert(col->data);
MR_make_aligned_string_copy(Str, (char *) col->data);
MR_DEBUG(printf(""got string %s\\n"", (char *) Str));
break;
case MODBC_VAR_STRING:
// The data was allocated on the Mercury heap,
// get it then kill the pointer so it can be GC'ed.
MR_make_aligned_string(Str, (char *) col->data);
MR_DEBUG(printf(""got var string %s\\n"", (char *) col->data));
col->data = NULL;
// As far as Mercury is concerned it's an ordinary string.
Type = MODBC_STRING;
break;
default:
MR_external_fatal_error(\"odbc.m\",
\"invalid attribute type in odbc.get_data\");
break;
} // end switch (Type)
DB = DB0;
").
:- pragma foreign_code("C", "
void
odbc_do_get_data(MODBC_Statement *statement, int column_id)
{
MODBC_Column *column;
SQLRETURN rc;
SDWORD column_info;
char dummy_buffer[1]; // Room for the NUL termination byte
// and nothing else.
column = &(statement->row[column_id]);
if (column->attr_type == MODBC_VAR_STRING) {
// Just get the length first time through.
rc = SQLGetData(statement->stat_handle, column_id,
column->conversion_type, dummy_buffer,
1, &(column->value_info));
// SQL_SUCCESS_WITH_INFO is expected here, since we didn't allocate
// any space for the data, so don't collect the ""data truncated""
// message.
if (rc != SQL_SUCCESS_WITH_INFO &&
! odbc_check(odbc_env_handle, odbc_connection,
statement->stat_handle, rc))
{
odbc_do_cleanup_statement(statement);
odbc_throw();
}
if (column->value_info == SQL_NULL_DATA) {
// The column is NULL, so there is no data to get.
return;
} else if (column->value_info == SQL_NO_TOTAL) {
// The driver couldn't work out the length in advance, so
// get the data in chunks of some arbitrary size, and append
// the chunks together.
// This method must be used with MODBC_IODBC,
// since iODBC-2.12 uses a different interpretation
// of the ODBC standard to Microsoft, for which
// the length returned by the first call to SQLGetData
// above is the minimum of the buffer length and the
// length of the available data, rather than the
// total length of data available.
odbc_get_data_in_chunks(statement, column_id);
} else {
MR_Word data;
// column->value_info == length of data
column->size = column->value_info + 1;
MR_incr_hp_atomic(data,
(column->size + sizeof(MR_Word)) / sizeof(MR_Word));
column->data = (MR_Word *) data;
odbc_get_data_in_one_go(statement, column_id);
}
} else {
// It's a fixed length column, so we can get the lot in one go.
odbc_get_data_in_one_go(statement, column_id);
}
}
void
odbc_get_data_in_one_go(MODBC_Statement *statement, int column_id)
{
MODBC_Column *col;
SQLRETURN rc;
MR_DEBUG(printf(""getting column %i in one go\\n"", column_id));
col = &(statement->row[column_id]);
rc = SQLGetData(statement->stat_handle, column_id,
col->conversion_type,
(SQLPOINTER) col->data, col->size, &(col->value_info));
if (! odbc_check(odbc_env_handle, odbc_connection,
statement->stat_handle, rc))
{
odbc_do_cleanup_statement(statement);
odbc_throw();
}
}
void
odbc_get_data_in_chunks(MODBC_Statement *statement, int column_id)
{
MODBC_Column *col;
SQLRETURN rc;
MR_Word this_bit;
MR_Word chunk_list;
MR_String result;
MR_DEBUG(printf(""getting column %i in chunks\\n"", column_id));
chunk_list = MR_list_empty();
col = &(statement->row[column_id]);
rc = SQL_SUCCESS_WITH_INFO;
MR_incr_hp_atomic(this_bit, MODBC_CHUNK_WORDS);
// Keep collecting chunks until we run out.
while (rc == SQL_SUCCESS_WITH_INFO) {
rc = SQLGetData(statement->stat_handle, column_id,
col->conversion_type, (SQLPOINTER) this_bit,
MODBC_CHUNK_SIZE - 1, &(col->value_info));
if (rc == SQL_NO_DATA_FOUND) {
break;
}
if (rc != SQL_SUCCESS_WITH_INFO &&
! odbc_check(odbc_env_handle, odbc_connection,
statement->stat_handle, rc))
{
odbc_do_cleanup_statement(statement);
odbc_throw();
}
chunk_list = MR_list_cons(this_bit, chunk_list);
MR_incr_hp_atomic(this_bit, MODBC_CHUNK_WORDS);
}
MODBC_odbc_condense_chunks(chunk_list, &result);
col->data = (MR_Word *) result;
}
").
:- pragma foreign_export("C", overflow_message(out), "MODBC_overflow_message").
:- pred overflow_message(odbc.message::out) is det.
overflow_message(Error) :-
ErrorType = error(execution_error(overflow)),
ErrorMsg = "[Mercury][odbc.m]Integer overflow detected in result set." ++
" Integers must be no larger than a word.",
Error = ErrorType - ErrorMsg.
:- pragma foreign_export("C", condense_chunks(in, out),
"MODBC_odbc_condense_chunks").
:- pred condense_chunks(list(string)::in, string::out) is det.
condense_chunks(RevChunks, String) :-
list.reverse(RevChunks, Chunks),
string.append_list(Chunks, String).
%-----------------------------------------------------------------------------%
:- pred cleanup_statement_check_error(odbc.statement::di,
odbc.state::di, odbc.state::uo) is det.
:- pragma foreign_proc("C",
cleanup_statement_check_error(Statement::di, DB0::di, DB::uo),
[promise_pure, may_call_mercury],
"{
MODBC_Statement *statement;
SQLRETURN rc;
statement = (MODBC_Statement *) Statement;
rc = odbc_do_cleanup_statement(statement);
if (! odbc_check(odbc_env_handle, odbc_connection, SQL_NULL_HSTMT, rc)) {
odbc_throw();
}
DB = DB0;
}").
:- pragma foreign_code("C", "
SQLRETURN
odbc_do_cleanup_statement(MODBC_Statement *statement)
{
int i;
SQLRETURN rc;
if (statement != NULL) {
MR_DEBUG(printf(""cleaning up statement\\n""));
if (statement->row != NULL) {
for (i = 1; i <= statement->num_columns; i++) {
// Variable length types are allocated directly
// onto the Mercury heap, so don't free them here.
if (!odbc_is_variable_length_sql_type(
statement->row[i].sql_type))
{
MR_GC_free(statement->row[i].data);
}
}
MR_GC_free(statement->row);
}
rc = SQLFreeStmt(statement->stat_handle, SQL_DROP);
MR_GC_free(statement);
return rc;
} else {
return SQL_SUCCESS;
}
}
").
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- pragma foreign_code("C", "
// Map an ODBC SQL type to a supported attribute type.
// Currently, supported attribute types are minimal,
// but this function will allow us to ask ODBC to make
// conversion from SQL types to supported types.
// Binary types are currently converted to strings.
MODBC_AttrType
odbc_sql_type_to_attribute_type(SWORD sql_type)
{
switch (sql_type) {
case SQL_BIGINT: return MODBC_STRING;
case SQL_BINARY: return MODBC_STRING;
case SQL_BIT: return MODBC_STRING;
case SQL_CHAR: return MODBC_STRING;
case SQL_DATE: return MODBC_TIME;
case SQL_DECIMAL: return MODBC_STRING; // ?
case SQL_DOUBLE: return MODBC_FLOAT;
case SQL_FLOAT: return MODBC_FLOAT;
case SQL_INTEGER: return MODBC_INT;
// For MySQL, SQLGetData does not work correctly (multiple calls
// return the same data, not successive pieces of the data).
// It seems to be guaranteed to be able to find the maximum length
// of the data in the column, so we treat those columns as if
// they were fixed length.
#ifdef MODBC_MYSQL
case SQL_LONGVARBINARY: return MODBC_STRING;
case SQL_LONGVARCHAR: return MODBC_STRING;
#else // ! MODBC_MYSQL
case SQL_LONGVARBINARY: return MODBC_VAR_STRING;
case SQL_LONGVARCHAR: return MODBC_VAR_STRING;
#endif // ! MODBC_MYSQL
case SQL_NUMERIC: return MODBC_STRING;
case SQL_REAL: return MODBC_FLOAT;
case SQL_SMALLINT: return MODBC_INT;
case SQL_TIME: return MODBC_TIME;
case SQL_TIMESTAMP: return MODBC_TIME;
case SQL_TINYINT: return MODBC_INT;
case SQL_VARBINARY: return MODBC_STRING;
case SQL_VARCHAR: return MODBC_STRING;
default:
MR_external_fatal_error(\"odbc.m\",
\"sql_type_to_attribute_type: unknown type\");
}
}
// Return the SQL_C type corresponding to a supported attribute type.
SWORD
odbc_attribute_type_to_sql_c_type(MODBC_AttrType AttrType)
{
switch (AttrType) {
case MODBC_FLOAT: return SQL_C_DOUBLE;
case MODBC_INT: return SQL_C_SLONG;
case MODBC_TIME: return SQL_C_CHAR;
case MODBC_STRING: return SQL_C_CHAR;
case MODBC_VAR_STRING: return SQL_C_CHAR;
default:
// Unsupported MODBC_xxx type.
MR_external_fatal_error(\"odbc.m\",
\"attribute_type_to_sql_c_type: unknown type\");
}
}
// Does the data have no maximum length?
// Note: the implementation of SQLGetData for MySQL does not follow the same
// standard as SQL Server, but from examination of the sources SQLDescribeCol
// seems guaranteed to find the maximum length of a result column containing
// variable length data. SQL_NO_TOTAL, which should be returned if the length
// cannot be determined, is not defined by the iODBC header files.
MR_bool
odbc_is_variable_length_sql_type(SWORD sql_type) {
#ifdef MODBC_MYSQL
return MR_FALSE;
#else // ! MODBC_MYSQL
return (
sql_type == SQL_LONGVARBINARY ||
sql_type == SQL_LONGVARCHAR
);
#endif // !MODBC_MYSQL
}
// This function computes to total number of bytes needed
// to store an attribute value, returning -1 if there is no
// maximum size.
// [SqlType] is the ODBC SQL type of the column
// [cbColDef] is the size returned by SQLDescribeCol
// [ibScaler] is the scale returned by SQLDescribeCol
// [fNullable] is whether the column can be NULL
size_t
odbc_sql_type_to_size(SWORD sql_type, UDWORD cbColDef,
SWORD ibScale, SWORD fNullable)
{
switch (sql_type)
{
// 64-bit signed int converted to SQL_C_CHAR.
case SQL_BIGINT:
return 1 + cbColDef + 1; // +1 for sign, +1 for NUL
// Binary data converted to SQL_C_CHAR
// Each byte is converted to 2-digit Hex.
case SQL_BINARY:
return cbColDef * 2 + 1; // +1 for NUL
// Bit converted to SQL_C_CHAR.
case SQL_BIT:
return cbColDef + 1; // +1 for NUL
// Fixed char to SQL_C_CHAR.
case SQL_CHAR:
return cbColDef + 1; // 1 for NUL
// Date YYYY-MM-DD converted to SQL_C_CHAR.
case SQL_DATE:
return cbColDef + 1; // 1 for NUL
// Signed decimal ddd.dd converted to SQL_C_CHAR.
case SQL_DECIMAL:
return 1 + cbColDef + 1 + ibScale + 1;
// 1 for sign 1, 1 for decimal point, 1, for NUL
// 32-bit float converted to MODBC_SQL_C_FLOAT.
case SQL_DOUBLE:
return sizeof(MODBC_C_FLOAT);
// 32-bit float converted to MODBC_SQL_C_FLOAT.
case SQL_FLOAT:
return sizeof(MODBC_C_FLOAT);
// 32-bit integer converted to SQL_C_SLONG.
case SQL_INTEGER:
return sizeof(MODBC_C_INT);
// Any length binary convert to SQL_C_CHAR
// For MySQL, there are no column types for
// which the maximum length cannot be determined before
// starting to fetch data, hence the #ifdefs below.
case SQL_LONGVARBINARY:
#ifdef MODBC_MYSQL
return cbColDef * 2 + 1; // 1 for NUL
#else // !MODBC_MYSQL
return -1;
#endif // !MODBC_MYSQL
// Any length char convert to SQL_C_CHAR
// For MySQL, there are no column types for
// which the maximum length cannot be determined before
// starting to fetch data, hence the #ifdefs below.
case SQL_LONGVARCHAR:
#ifdef MODBC_MYSQL
return cbColDef + 1; // 1 for NUL
#else // !MODBC_MYSQL
return -1;
#endif // !MODBC_MYSQL
// Signed numeric ddd.dd converted to SQL_C_CHAR.
case SQL_NUMERIC:
return 1 + cbColDef + 1 + ibScale + 1; // 1 for NUL
// 32-bit float converted to MODBC_SQL_C_FLOAT.
case SQL_REAL:
return sizeof(MODBC_C_FLOAT);
// 16-bit integer converted to SQL_C_SLONG.
case SQL_SMALLINT:
return sizeof(MODBC_C_INT);
// Time hh:mm:ss converted to SQL_C_CHAR.
case SQL_TIME:
return cbColDef + 1; // 1 for NUL
// Time YYYY-MM-DD hh:mm:ss converted to SQL_C_CHAR.
case SQL_TIMESTAMP:
return cbColDef + 1; // 1 for NUL
// 8-bit integer converted to MODBC_SQL_INT.
case SQL_TINYINT:
return sizeof(MODBC_C_INT);
// Binary data converted to SQL_C_CHAR.
// Each byte is converted to 2-digit Hex.
case SQL_VARBINARY:
return cbColDef * 2 + 1; // 1 for NUL
// Fixed char to SQL_C_CHAR.
case SQL_VARCHAR:
return cbColDef + 1; // 1 for NUL
default:
MR_external_fatal_error(\"odbc.m\",
\"sql_type_to_size: unknown type\");
}
}
").
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
%
% Catalog functions
%
data_sources(MaybeSources - Messages, !IO) :-
sql_data_sources(RevSourceNames, RevDescs, Status, RevMessages, !IO),
( if odbc.ok(Status) then
list.reverse(RevMessages, Messages),
list.reverse(RevSourceNames, SourceNames),
list.reverse(RevDescs, Descs),
assoc_list.from_corresponding_lists(SourceNames, Descs, SourceAL),
MakeSource =
( pred(Pair::in, SourceDesc::out) is det :-
Pair = SourceName - Desc,
SourceDesc = odbc.source_desc(SourceName, Desc)
),
list.map(MakeSource, SourceAL, Sources),
MaybeSources = ok(Sources)
else if odbc.no_data(Status)then
% iODBC 2.12 doesn't implement this function.
Messages = [
error(feature_not_implemented) -
"[Mercury][odbc.m]SQLDataSources not implemented."
],
MaybeSources = error
else
list.reverse(RevMessages, Messages),
MaybeSources = error
).
:- pred sql_data_sources(list(string)::out, list(string)::out, int::out,
list(odbc.message)::out, io::di, io::uo) is det.
:- pragma foreign_proc("C",
sql_data_sources(SourceNames::out, SourceDescs::out, Status::out,
Messages::out, IO0::di, IO::uo),
[promise_pure, may_call_mercury],
"
Status = odbc_do_get_data_sources(&SourceNames, &SourceDescs, &Messages);
IO = IO0;
").
:- pragma foreign_decl("C", "
SQLRETURN
odbc_do_get_data_sources(MR_Word *SourceNames, MR_Word *SourceDescs,
MR_Word *Messages);
").
:- pragma foreign_code("C", "
SQLRETURN
odbc_do_get_data_sources(MR_Word *SourceNames, MR_Word *SourceDescs,
MR_Word *Messages)
{
SQLCHAR dsn[SQL_MAX_DSN_LENGTH];
SQLCHAR desc[128];
// Arbitrary size, only needs to hold a
// descriptive string like ""SQL Server"".
MR_String new_dsn;
MR_String new_desc;
SWORD dsn_len;
SWORD desc_len;
SQLRETURN rc;
odbc_message_list = MR_list_empty();
*SourceNames = MR_list_empty();
*SourceDescs = MR_list_empty();
if (odbc_env_handle == SQL_NULL_HENV) {
rc = SQLAllocEnv(&odbc_env_handle);
} else {
rc = SQL_SUCCESS;
}
MR_DEBUG(printf(""SQLAllocEnv status: %d\\n"", rc));
if (odbc_check(odbc_env_handle, SQL_NULL_HDBC, SQL_NULL_HSTMT, rc)) {
rc = SQLDataSources(odbc_env_handle, SQL_FETCH_FIRST,
dsn, SQL_MAX_DSN_LENGTH - 1,
&dsn_len, desc, sizeof(desc), &desc_len);
// The documentation varies on whether the driver
// returns SQL_NO_DATA_FOUND or SQL_NO_DATA, so check for both.
while (rc != SQL_NO_DATA_FOUND && rc != SQL_NO_DATA &&
odbc_check(odbc_env_handle, SQL_NULL_HDBC,
SQL_NULL_HSTMT, rc))
{
// Copy the new data onto the Mercury heap
MR_make_aligned_string_copy(new_dsn, (MR_String)dsn);
*SourceNames = MR_list_cons((MR_Word)new_dsn, *SourceNames);
MR_make_aligned_string_copy(new_desc, (MR_String)desc);
*SourceDescs = MR_list_cons((MR_Word)new_desc, *SourceDescs);
rc = SQLDataSources(odbc_env_handle,
SQL_FETCH_NEXT, dsn, SQL_MAX_DSN_LENGTH - 1, &dsn_len,
desc, sizeof(desc), &desc_len);
}
}
if (rc == SQL_NO_DATA_FOUND) {
rc = SQL_SUCCESS;
}
*Messages = odbc_message_list;
odbc_message_list = MR_list_empty();
return rc;
}").
%-----------------------------------------------------------------------------%
tables(Qualifier, Owner, TableName, Tables, !DB) :-
convert_pattern_argument(Qualifier, QualifierStr, QualifierStatus),
convert_pattern_argument(Owner, OwnerStr, OwnerStatus),
convert_pattern_argument(TableName, TableStr, TableStatus),
do_aggregate(odbc.sql_tables(QualifierStr, QualifierStatus,
OwnerStr, OwnerStatus, TableStr, TableStatus),
list.cons, [], Results0, !DB),
list.reverse(Results0, Results),
( if list.map(convert_table_desc, Results, Tables0)then
Tables = Tables0
else
add_message(error(internal_error) -
"[Mercury][odbc.m]Invalid results from SQLTables.", !DB),
odbc.throw(!DB)
).
:- pred convert_table_desc(odbc.row::in, odbc.table_desc::out) is semidet.
convert_table_desc(Row0, Table) :-
NullToEmptyStr =
( pred(Data0::in, Data::out) is det :-
( if Data0 = null then Data = string("") else Data = Data0 )
),
list.map(NullToEmptyStr, Row0, Row),
Row = [string(Qualifier), string(Owner), string(Name),
string(Type), string(Description) | DriverColumns],
Table = odbc.table_desc(Qualifier, Owner, Name,
Type, Description, DriverColumns).
%-----------------------------------------------------------------------------%
% convert_pattern_argument(Pattern, String, Status).
% This is used in a fairly crude interface to C. If the Status is 0,
% the corresponding argument to the ODBC function should be NULL,
% meaning no constraint on the search. If the Status is 1, the
% argument to the ODBC function should be the given string.
%
:- pred convert_pattern_argument(search_pattern::in, string::out, int::out)
is det.
convert_pattern_argument(any, "", 0).
convert_pattern_argument(pattern(Str), Str, 1).
:- pred sql_tables(string::in, int::in, string::in, int::in, string::in,
int::in, odbc.statement::di, odbc.statement::uo,
odbc.state::di, odbc.state::uo) is det.
:- pragma foreign_proc("C",
sql_tables(QualifierStr::in, QualifierStatus::in,
OwnerStr::in, OwnerStatus::in, TableStr::in, TableStatus::in,
Statement0::di, Statement::uo, DB0::di, DB::uo),
[may_call_mercury, promise_pure],
"
char *qualifier_str = NULL;
char *owner_str = NULL;
char *table_str = NULL;
int qualifier_len = 0;
int owner_len = 0;
int table_len = 0;
SQLRETURN rc;
Statement = Statement0;
// A NULL pointer in any of the string pattern fields
// means no constraint on the search for that field.
if (QualifierStatus) {
qualifier_str = (char *) QualifierStr;
qualifier_len = strlen(qualifier_str);
}
if (OwnerStatus) {
owner_str = (char *) OwnerStr;
owner_len = strlen(owner_str);
}
if (TableStatus) {
table_str = (char *) TableStr;
table_len = strlen(table_str);
}
rc = SQLTables(Statement->stat_handle, (SQLCHAR *)qualifier_str,
qualifier_len, (SQLCHAR *)owner_str, owner_len,
(SQLCHAR *)table_str, table_len, NULL, 0);
if (! odbc_check(odbc_env_handle, odbc_connection,
Statement->stat_handle, rc))
{
odbc_do_cleanup_statement(Statement);
odbc_throw();
}
DB = DB0;
").
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
%
% Error checking
%
:- pred odbc.ok(int::in) is semidet.
:- pragma foreign_proc("C",
odbc.ok(Status::in),
[promise_pure, will_not_call_mercury, thread_safe],
"
SUCCESS_INDICATOR =
(Status == SQL_SUCCESS || Status == SQL_SUCCESS_WITH_INFO);
").
:- pred odbc.no_data(int::in) is semidet.
:- pragma foreign_proc("C",
odbc.no_data(Status::in),
[promise_pure, will_not_call_mercury, thread_safe],
"
SUCCESS_INDICATOR = (Status == SQL_NO_DATA_FOUND);
").
%-----------------------------------------------------------------------------%
% Handle ODBC error codes. Refer to the ODBC API Reference
% provided with the ODBC SDK. The first two characters of the
% SQLSTATE are meant to specify an error class. Looking at the
% predicates below, the classes weren't terribly well chosen.
%
:- pred sql_state_to_message(string::in, string::in,
odbc.message::out) is det.
:- pragma foreign_export("C", sql_state_to_message(in, in, out),
"MODBC_odbc_sql_state_to_message").
sql_state_to_message(SQLState, String, Message - String) :-
string.split(SQLState, 2, Class, SubClass),
( if Class = "01" then
( if sql_state_to_warning(SubClass, Warning) then
Message = warning(Warning)
else
Message = warning(general_warning)
)
else
( if sql_state_to_error(Class, SubClass, Error) then
Message = error(Error)
else
Message = error(general_error)
)
).
:- pred sql_state_to_warning(string::in, odbc.warning::out) is semidet.
sql_state_to_warning("000", general_warning).
sql_state_to_warning("001", general_warning).
sql_state_to_warning("002", disconnect_error).
sql_state_to_warning("003", null_value_in_set_function).
sql_state_to_warning("004", string_data_truncated).
sql_state_to_warning("006", privilege_not_revoked).
sql_state_to_warning("007", privilege_not_granted).
sql_state_to_warning("S03", general_warning).
sql_state_to_warning("S04", general_warning).
:- pred sql_state_to_error(string::in, string::in, odbc.error::out) is semidet.
sql_state_to_error("07", "002", execution_error(incorrect_count_field)).
sql_state_to_error("07", "005", general_error).
sql_state_to_error("07", "006",
execution_error(restricted_data_type_violation)).
sql_state_to_error("07", "009", general_error).
sql_state_to_error("07", "S01", internal_error).
sql_state_to_error("08", "001", connection_error(unable_to_establish)).
sql_state_to_error("08", "002", connection_error(connection_name_in_use)).
sql_state_to_error("08", "003", connection_error(nonexistent_connection)).
sql_state_to_error("08", "004",
connection_error(connection_rejected_by_server)).
sql_state_to_error("08", "007", connection_error(connection_failure)).
sql_state_to_error("08", "S01", connection_error(connection_failure)).
sql_state_to_error("21", "S01", execution_error(invalid_insert_value_list)).
sql_state_to_error("21", "S02", execution_error(incorrect_derived_table_arity)).
sql_state_to_error("22", "001", execution_error(string_data_truncated)).
sql_state_to_error("22", "002", execution_error(general_error)).
sql_state_to_error("22", "003", execution_error(range_error)).
sql_state_to_error("22", "007", execution_error(invalid_date_time)).
sql_state_to_error("22", "008", execution_error(overflow)).
sql_state_to_error("22", "012", execution_error(division_by_zero)).
sql_state_to_error("22", "015", execution_error(overflow)).
sql_state_to_error("22", "018", execution_error(invalid_cast_specification)).
sql_state_to_error("22", "019", execution_error(invalid_escape)).
sql_state_to_error("22", "025", execution_error(invalid_escape)).
sql_state_to_error("22", "026", execution_error(string_data_length_mismatch)).
sql_state_to_error("23", "000",
execution_error(integrity_constraint_violation)).
sql_state_to_error("24", "000", execution_error(general_error)).
sql_state_to_error("25", "S00", transaction_error(invalid_state)).
sql_state_to_error("25", "S01", transaction_error(invalid_state)).
sql_state_to_error("25", "S02", transaction_error(still_active)).
sql_state_to_error("25", "S03", transaction_error(rolled_back)).
sql_state_to_error("28", "000", connection_error(invalid_authorization)).
sql_state_to_error("37", "000",
execution_error(syntax_error_or_access_violation)).
sql_state_to_error("3C", "000", execution_error(general_error)).
sql_state_to_error("3D", "000", execution_error(general_error)).
sql_state_to_error("3F", "000", execution_error(invalid_schema_name)).
sql_state_to_error("40", "001", transaction_error(serialization_failure)).
sql_state_to_error("40", "003", execution_error(general_error)).
sql_state_to_error("42", "000",
execution_error(syntax_error_or_access_violation)).
sql_state_to_error("42", "S01", execution_error(table_or_view_already_exists)).
sql_state_to_error("42", "S02", execution_error(table_or_view_not_found)).
sql_state_to_error("42", "S11", execution_error(index_already_exists)).
sql_state_to_error("42", "S12", execution_error(index_not_found)).
sql_state_to_error("42", "S21", execution_error(column_already_exists)).
sql_state_to_error("42", "S22", execution_error(column_not_found)).
sql_state_to_error("44", "000", execution_error(general_error)).
sql_state_to_error("IM", _, internal_error).
sql_state_to_error("HY", SubClass, Error) :-
( if SubClass = "000" then
Error = general_error
else if SubClass = "109" then
Error = feature_not_implemented
else if SubClass = "T00" then
Error = timeout_expired
else if SubClass = "T01" then
Error = connection_error(timeout_expired)
else
Error = internal_error
).
sql_state_to_error("S0", "001", execution_error(table_or_view_already_exists)).
sql_state_to_error("S0", "002", execution_error(table_or_view_not_found)).
sql_state_to_error("S0", "011", execution_error(index_already_exists)).
sql_state_to_error("S0", "012", execution_error(index_not_found)).
sql_state_to_error("S0", "021", execution_error(column_already_exists)).
sql_state_to_error("S0", "022", execution_error(column_not_found)).
sql_state_to_error("S0", "023", execution_error(no_default_for_column)).
sql_state_to_error("S1", SubClass, Error) :-
( if SubClass = "000" then
Error = general_error
else if SubClass = "C00" then
Error = feature_not_implemented
else if SubClass = "T01" then
Error = connection_error(timeout_expired)
else
Error = internal_error
).
:- pragma foreign_code("C", "
// Return MR_TRUE if the last ODBC call succeeded.
// Return MR_FALSE if the ODBC call failed.
// Add any error messages to odbc_message_list.
MR_bool
odbc_check(SQLHENV env_handle, SQLHDBC connection_handle,
SQLHSTMT statement_handle, SQLRETURN rc)
{
SQLRETURN status;
SQLINTEGER native_error;
SQLSMALLINT msg_len;
UCHAR message[SQL_MAX_MESSAGE_LENGTH];
UCHAR sql_state[SQL_SQLSTATE_SIZE + 1];
MR_String mercury_message;
MR_Word new_message;
MR_ASSERT_IMPLY(connection_handle == SQL_NULL_HDBC,
statement_handle == SQL_NULL_HSTMT);
odbc_ret_code = rc;
// Check type of error.
if (rc == SQL_SUCCESS) {
return MR_TRUE;
} else {
MR_DEBUG(printf(""getting error message for status %i\\n"", rc));
while (1) {
status = SQLError(env_handle, connection_handle,
statement_handle, sql_state, &native_error,
message, SQL_MAX_MESSAGE_LENGTH - 1, &msg_len);
MR_DEBUG(printf(""SQLError status: %i\\n"", status));
MR_DEBUG(printf(""SQL_STATE: %s\\n"", sql_state));
MR_DEBUG(printf(""Error: %s\\n"", message));
if (status != SQL_SUCCESS) {
break;
}
// Copy the error string to the Mercury heap.
MR_make_aligned_string_copy(mercury_message, (char *)message);
// Convert the SQL state to an odbc__message.
MODBC_odbc_sql_state_to_message((MR_String)sql_state,
mercury_message, &new_message);
// Append the message onto the list.
odbc_message_list =
MR_list_cons(new_message, odbc_message_list);
}
if (rc == SQL_SUCCESS_WITH_INFO) {
return MR_TRUE;
} else {
return MR_FALSE;
}
}
}
").
%-----------------------------------------------------------------------------%
:- end_module odbc.
%-----------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink