sdmss.pas

SQLDirect Component Library is a light-weight Borland Database Engine replacement for Borland Delphi

function dbconvert(dbproc: PDBPROCESS; srctype: INT; src: LPCBYTE; srclen: DBINT;
			desttype: INT; dest: LPBYTE; destlen: DBINT): INT; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbcount')]
function dbcount(dbproc: PDBPROCESS): DBINT; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbdata')]
function dbdata(dbproc: PDBPROCESS; column: INT): LPCBYTE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbdatecrack')]
function dbdatecrack(dbproc: PDBPROCESS; var dateinfo: DBDATEREC; datetime: TSDValueBuffer): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbdatlen')]
function dbdatlen(dbproc: PDBPROCESS; column: INT): DBINT; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbdead')]
function dbdead(dbproc: PDBPROCESS): BOOL; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbexit')]
procedure dbexit; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbfirstrow')]
function dbfirstrow(dbproc: PDBPROCESS): DBINT; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbfreebuf')]
procedure dbfreebuf(dbproc: PDBPROCESS); external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbfreelogin')]
procedure dbfreelogin(login: PLOGINREC); external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbgetmaxprocs')]
function dbgetmaxprocs: SHORT; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbgetpacket')]
function dbgetpacket(dbproc: PDBPROCESS): UINT; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbgetrow')]
function dbgetrow(dbproc: PDBPROCESS; row: DBINT): STATUS; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbgettime')]
function dbgettime: INT; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbhasretstat')]
function dbhasretstat(dbproc: PDBPROCESS): DBBOOL; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbinit')]
function dbinit: LPCSTR; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbisavail')]
function dbisavail(dbproc: PDBPROCESS): BOOL; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbiscount')]
function dbiscount(dbproc: PDBPROCESS): BOOL; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbisopt')]
function dbisopt(dbproc: PDBPROCESS; option: INT; param: LPCSTR): BOOL; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dblastrow')]
function dblastrow(dbproc: PDBPROCESS): DBINT; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dblogin')]
function dblogin: PLOGINREC; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbmorecmds')]
function dbmorecmds(dbproc: PDBPROCESS): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbmoretext')]
function dbmoretext(dbproc: PDBPROCESS; size: DBINT; text: LPCBYTE): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbname')]
function dbname(dbproc: PDBPROCESS): LPCSTR; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbnextrow')]
function dbnextrow(dbproc: PDBPROCESS): STATUS; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbnumcols')]
function dbnumcols(dbproc: PDBPROCESS): INT; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbnumrets')]
function dbnumrets(dbproc: PDBPROCESS): INT; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbopen')]
function dbopen(login: PLOGINREC; servername: LPCSTR): PDBPROCESS; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbordercol')]
function dbordercol(dbproc: PDBPROCESS; order: INT): INT; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbprocinfo')]
function dbprocinfo(dbproc: PDBPROCESS; var dbprcinfo: TDBPROCINFO): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbresults')]
function dbresults(dbproc: PDBPROCESS): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbretdata')]
function dbretdata(dbproc: PDBPROCESS; retnum: INT): LPCBYTE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbretlen')]
function dbretlen(dbproc: PDBPROCESS; retnum: INT): DBINT; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbretname')]
function dbretname(dbproc: PDBPROCESS; retnum: INT): LPCSTR; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbretstatus')]
function dbretstatus(dbproc: PDBPROCESS): DBINT; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbrettype')]
function dbrettype(dbproc: PDBPROCESS; retnum: INT): INT; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbrows')]
function dbrows(dbproc: PDBPROCESS): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbrowtype')]
function dbrowtype(dbproc: PDBPROCESS): STATUS; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbrpcinit')]
function dbrpcinit(dbproc: PDBPROCESS; rpcname: LPCSTR; options: DBSMALLINT): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbrpcparam')]
function dbrpcparam(dbproc: PDBPROCESS; paramname: LPCSTR; status: BYTE;
			datatype: INT; maxlen, datalen: DBINT; value: LPCBYTE): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbrpcsend')]
function dbrpcsend(dbproc: PDBPROCESS): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbrpcexec')]
function dbrpcexec(dbproc: PDBPROCESS): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbsetavail')]
procedure dbsetavail(dbproc: PDBPROCESS); external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbsetmaxprocs')]
function dbsetmaxprocs(maxprocs: SHORT): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbsetlname')]
function dbsetlname(login: PLOGINREC; value: LPCSTR; param: INT): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbsetlogintime')]
function dbsetlogintime(seconds: INT): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbsetlpacket')]
function dbsetlpacket(login: PLOGINREC; packet_size: USHORT): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbsetnull')]
function dbsetnull(dbproc: PDBPROCESS; bindtype, bindlen: INT; bindval: LPCBYTE): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Auto, SetLastError = True, EntryPoint = 'dbsetopt')]
function dbsetopt(dbproc: PDBPROCESS; option: INT; param: LPCSTR): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbsettime')]
function dbsettime(seconds: INT): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbsqlexec')]
function dbsqlexec(dbproc: PDBPROCESS): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbsqlok')]
function dbsqlok(dbproc: PDBPROCESS): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbsqlsend')]
function dbsqlsend(dbproc: PDBPROCESS): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbuse')]
function dbuse(dbproc: PDBPROCESS; dbname: LPCSTR): RETCODE; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbwillconvert')]
function dbwillconvert(srctype, desttype: INT): BOOL; external;

[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dberrhandle')]
function dberrhandle(handler: TDBERRHANDLE_PROC): TDBERRHANDLE_PROC; external;
[DllImport(DefSqlApiDLL, CallingConvention = CallingConvention.cdecl, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'dbmsghandle')]
function dbmsghandle(handler: TDBMSGHANDLE_PROC): TDBMSGHANDLE_PROC; external;

        // it is necessary to convert stdcall callback to cdecl callback function, which is not supported by Delphi 8
[DllImport(CLRHelperDLL, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'MssSetErrHandler')]
function MssSetErrHandler(const hLib: HModule; hErr: TDBERRHANDLE_PROC; hMsg: TDBMSGHANDLE_PROC): Integer; external;

{$ENDIF}

implementation

const
  APP_CONNECT_MAX	= 100;	// max connections permits

  IsolLevelCmd: array[TISqlTransIsolation] of string =
  	('SET TRANSACTION ISOLATION LEVEL READ UNCOMMITTED',
         'SET TRANSACTION ISOLATION LEVEL READ COMMITTED',
         'SET TRANSACTION ISOLATION LEVEL REPEATABLE READ'
        );

  SDummySelect  = 'select 1 from sysobjects where 1=0';

  OPT_DBTEXTLIMIT	= '2147483647';
  OPT_DBTEXTSIZE	= OPT_DBTEXTLIMIT;

  CRLF = #$0D#$0A;

  QuoteChar	= '"';	// for surroundings of the parameter's name, which can include, for example, spaces

const
  { Converting from TFieldType to SQL Data Type(SQLServer) - used in stored procedure bind }
  SrvNativeDataTypes: array[TFieldType] of Word = ( 0,	// ftUnknown
	// ftString, ftSmallint, ftInteger, ftWord, ftBoolean
	SQLVARCHAR, 	SQLINT2, SQLINT4, SQLINT2, SQLINT2,
	// ftFloat, ftCurrency, ftBCD, ftDate, ftTime
        SQLFLT8,	SQLFLT8,0, SQLDATETIME, SQLDATETIME,
        // ftDateTime, ftBytes, ftVarBytes, ftAutoInc, ftBlob
        SQLDATETIME, 	SQLBINARY, SQLBINARY,	0, 	SQLIMAGE,
        // ftMemo, ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle
        SQLTEXT,	0,	0,	0,	0,
        // ftTypedBinary, ftCursor
        0,	0
{$IFDEF SD_VCL4},
	// ftFixedChar, ftWideString, ftLargeint,
        0,	0,	0,
        // ftADT, ftArray, ftReference, ftDataSet
        0,	0,	0,	0
{$ENDIF}
{$IFDEF SD_VCL5},
        // ftOraBlob, ftOraClob, ftVariant,
        0,	0,	0,
        // ftInterface, ftIDispatch, ftGuid
        0,	0,	0
{$ENDIF}
{$IFDEF SD_VCL6},
        // ftTimeStamp, ftFMTBcd
        0,      0
{$ENDIF}
        );

var     // it is important in Delphi 8 for .NET
  RefErrHandler: TDBERRHANDLE_PROC;
  RefMsgHandler: TDBMSGHANDLE_PROC;

type
        // error list can contain errors for some dbprocesses (for example, in multithreaded application)
  TMssErrorList = class(TThreadList)
  private
    function GetError(Index: Integer): ESDMssError;
  public
    destructor Destroy; override;
    function Find(dbproc: PDBPROCESS; Remove: Boolean): ESDMssError;    
    property Errors[Index: Integer]: ESDMssError read GetError;
  end;

{ TMssErrorList }
destructor TMssErrorList.Destroy;
var
  i: Integer;
  L: TList;
begin
  L := LockList;
  try
    for i:=0 to L.Count-1 do
      ESDMssError( L[i] ).Free;
  finally
    UnlockList;
  end;

  inherited;
end;

function TMssErrorList.Find(dbproc: PDBPROCESS; Remove: Boolean): ESDMssError;
var
  i: Integer;
  L: TList;
  E: ESDMssError;
begin
  Result := nil;
  L := LockList;
  try
    for i := L.Count-1 downto 0 do begin
      E := ESDMssError( L[i] );
      // this is a bit weak - on dbopen() error we don't have dbproc, so pop last error
      if (E.HProcess = dbproc) or (dbproc = nil) then begin
        if Remove then
          L.Delete(i);
        Result := E;
        Break;
      end;
    end;
  finally
    UnlockList;
  end;
end;

function TMssErrorList.GetError(Index: Integer): ESDMssError;
var
  L: TList;
begin
  L := LockList;
  try
    Result := ESDMssError( L[Index] );
  finally
    UnlockList;
  end;
end;

resourcestring
  SErrLibLoading 	= 'Error loading library ''%s''';
  SErrLibUnloading	= 'Error unloading library ''%s''';
  SErrLibInit		= 'Error initialization of DB-library';
  SErrFuncNotFound	= 'Function ''%s'' not found in MS SQLServer DB-library';
  SErrDBProcIsNull	= 'Unable to allocate DBPROCESS connection structure';

var
  DbErrorList: TMssErrorList;
  hSqlLibModule: THandle;
  SqlLibRefCount: Integer;
  SqlLibLock: TCriticalSection;
  dwLoadedDBLIB: LongInt;

function InitSqlDatabase(ADbParams: TStrings): TISqlDatabase;
var
  s: string;
begin
  if hSqlLibModule = 0 then begin
    s := Trim( ADbParams.Values[GetSqlLibParamName( Ord(istSQLServer) )] );
    if s <> '' then
      SqlApiDLL := s;
  end;

  Result := TIMssDatabase.Create( ADbParams );
end;

(*******************************************************************************
			Load/Unload Sql-library
********************************************************************************)
procedure SetProcAddresses;
begin
{$IFNDEF SD_CLR}
  @abort_xact           := GetProcAddress(hSqlLibModule, 'abort_xact');  	ASSERT( @abort_xact       <>nil, Format(SErrFuncNotFound, ['abort_xact       ']) );
  @build_xact_string    := GetProcAddress(hSqlLibModule, 'build_xact_string');  ASSERT( @build_xact_string<>nil, Format(SErrFuncNotFound, ['build_xact_string']) );
  @close_commit         := GetProcAddress(hSqlLibModule, 'close_commit');  	ASSERT( @close_commit     <>nil, Format(SErrFuncNotFound, ['close_commit     ']) );
  @commit_xact          := GetProcAddress(hSqlLibModule, 'commit_xact');  	ASSERT( @commit_xact      <>nil, Format(SErrFuncNotFound, ['commit_xact      ']) );
  @open_commit          := GetProcAddress(hSqlLibModule, 'open_commit');  	ASSERT( @open_commit      <>nil, Format(SErrFuncNotFound, ['open_commit      ']) );
  @remove_xact          := GetProcAddress(hSqlLibModule, 'remove_xact');  	ASSERT( @remove_xact      <>nil, Format(SErrFuncNotFound, ['remove_xact      ']) );
//  @scan_xact            := GetProcAddress(hSqlLibModule, 'scan_xact');  	ASSERT( @scan_xact        <>nil, Format(SErrFuncNotFound, ['scan_xact        ']) );
  @start_xact           := GetProcAddress(hSqlLibModule, 'start_xact');  	ASSERT( @start_xact       <>nil, Format(SErrFuncNotFound, ['start_xact       ']) );
  @stat_xact            := GetProcAddress(hSqlLibModule, 'stat_xact');  	ASSERT( @stat_xact        <>nil, Format(SErrFuncNotFound, ['stat_xact        ']) );
  @bcp_batch            := GetProcAddress(hSqlLibModule, 'bcp_batch');  	ASSERT( @bcp_batch        <>nil, Format(SErrFuncNotFound, ['bcp_batch        ']) );
  @bcp_bind             := GetProcAddress(hSqlLibModule, 'bcp_bind');  		ASSERT( @bcp_bind         <>nil, Format(SErrFuncNotFound, ['bcp_bind         ']) );
  @bcp_colfmt           := GetProcAddress(hSqlLibModule, 'bcp_colfmt');  	ASSERT( @bcp_colfmt       <>nil, Format(SErrFuncNotFound, ['bcp_colfmt       ']) );
  @bcp_collen           := GetProcAddress(hSqlLibModule, 'bcp_collen');  	ASSERT( @bcp_collen       <>nil, Format(SErrFuncNotFound, ['bcp_collen       ']) );
  @bcp_colptr           := GetProcAddress(hSqlLibModule, 'bcp_colptr');  	ASSERT( @bcp_colptr       <>nil, Format(SErrFuncNotFound, ['bcp_colptr       ']) );
  @bcp_