mssqlconn.pp 34 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102
  1. {
  2. This file is part of the Free Component Library (FCL)
  3. MS SQL Server connection using DB-Library
  4. See the file COPYING.FPC, included in this distribution,
  5. for details about the copyright.
  6. This program is distributed in the hope that it will be useful,
  7. but WITHOUT ANY WARRANTY; without even the implied warranty of
  8. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  9. The Original Code was created by (c) 2010 Ladislav Karrach (Windows)
  10. for the Free Pascal project.
  11. **********************************************************************
  12. MS SQL Server Client Library is required (ntwdblib.dll)
  13. - or -
  14. FreeTDS (dblib.dll)
  15. freetds.conf: (http://www.freetds.org/userguide/freetdsconf.htm)
  16. [global]
  17. tds version = 7.1
  18. client charset = UTF-8
  19. port = 1433 or instance = ... (optional)
  20. dump file = freetds.log (optional)
  21. text size = 2147483647 (optional)
  22. TMSSQLConnection properties:
  23. HostName - can be specified also as 'servername:port' or 'servername\instance'
  24. (SQL Server Browser Service must be running on server to connect to specific instance)
  25. CharSet - if you use Microsoft DB-Lib and set to 'UTF-8' then char/varchar fields will be UTF8Encoded/Decoded
  26. if you use FreeTDS DB-Lib then you must compile with iconv support (requires libiconv2.dll) or cast char/varchar to nchar/nvarchar in SELECTs
  27. Params - "AutoCommit=true" - if you don't want explicitly commit/rollback transactions
  28. "TextSize=16777216" - set maximum size of text/image data returned
  29. "ApplicationName=YourAppName" - Set the app name for the connection. MSSQL 2000 and higher only
  30. }
  31. unit mssqlconn;
  32. {$mode objfpc}{$H+}
  33. interface
  34. uses
  35. Classes, SysUtils, sqldb, db, BufDataset,
  36. dblib;
  37. type
  38. { TMSSQLConnection }
  39. TMSSQLConnection = class(TSQLConnection)
  40. private
  41. type
  42. TServerInfo = record
  43. ServerVersion: string;
  44. ServerVersionString: string;
  45. UserName: string;
  46. end;
  47. var
  48. FDBLogin: PLOGINREC;
  49. FDBProc : PDBPROCESS;
  50. Ftds : integer; // TDS protocol version
  51. Fstatus : STATUS; // current result/rows fetch status
  52. FServerInfo: TServerInfo;
  53. function CheckError(const Ret: RETCODE): RETCODE;
  54. procedure Execute(const cmd: string); overload;
  55. procedure ExecuteDirectSQL(const Query: string);
  56. procedure GetParameters(cursor: TSQLCursor; AParams: TParams);
  57. function TranslateFldType(SQLDataType: integer): TFieldType;
  58. function AutoCommit: boolean;
  59. function IsSybase: boolean;
  60. protected
  61. // Overrides from TSQLConnection
  62. function GetHandle:pointer; override;
  63. function GetAsSQLText(Param : TParam) : string; overload; override;
  64. function GetConnectionCharSet: string; override;
  65. // - Connect/disconnect
  66. procedure DoInternalConnect; override;
  67. procedure DoInternalDisconnect; override;
  68. // - Handle (de)allocation
  69. function AllocateCursorHandle:TSQLCursor; override;
  70. procedure DeAllocateCursorHandle(var cursor:TSQLCursor); override;
  71. function AllocateTransactionHandle:TSQLHandle; override;
  72. // - Transaction handling
  73. function GetTransactionHandle(trans:TSQLHandle):pointer; override;
  74. function StartDBTransaction(trans:TSQLHandle; AParams:string):boolean; override;
  75. function Commit(trans:TSQLHandle):boolean; override;
  76. function Rollback(trans:TSQLHandle):boolean; override;
  77. procedure CommitRetaining(trans:TSQLHandle); override;
  78. procedure RollbackRetaining(trans:TSQLHandle); override;
  79. // - Statement handling
  80. function StrToStatementType(s : string) : TStatementType; override;
  81. procedure PrepareStatement(cursor:TSQLCursor; ATransaction:TSQLTransaction; buf:string; AParams:TParams); override;
  82. procedure UnPrepareStatement(cursor:TSQLCursor); override;
  83. // - Statement execution
  84. procedure Execute(cursor:TSQLCursor; ATransaction:TSQLTransaction; AParams:TParams); override;
  85. function RowsAffected(cursor: TSQLCursor): TRowsCount; override;
  86. function RefreshLastInsertID(Query : TCustomSQLQuery; Field : TField): boolean; override;
  87. // - Result retrieving
  88. procedure AddFieldDefs(cursor:TSQLCursor; FieldDefs:TFieldDefs); override;
  89. function Fetch(cursor:TSQLCursor):boolean; override;
  90. function LoadField(cursor:TSQLCursor; FieldDef:TFieldDef; buffer:pointer; out CreateBlob : boolean):boolean; override;
  91. procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction : TSQLTransaction); override;
  92. procedure FreeFldBuffers(cursor:TSQLCursor); override;
  93. // - UpdateIndexDefs
  94. procedure UpdateIndexDefs(IndexDefs:TIndexDefs; TableName:string); override;
  95. // - Schema info
  96. function GetSchemaInfoSQL(SchemaType:TSchemaType; SchemaObjectName, SchemaObjectPattern:string):string; override;
  97. public
  98. constructor Create(AOwner : TComponent); override;
  99. function GetConnectionInfo(InfoType:TConnInfoType): string; override;
  100. procedure CreateDB; override;
  101. procedure DropDB; override;
  102. //property TDS:integer read Ftds;
  103. published
  104. // Redeclare properties from TSQLConnection
  105. property Password;
  106. property Transaction;
  107. property UserName;
  108. property CharSet;
  109. property HostName;
  110. // Redeclare properties from TDatabase
  111. property Connected;
  112. property Role;
  113. property DatabaseName;
  114. property KeepConnection;
  115. property LoginPrompt;
  116. property Params;
  117. property OnLogin;
  118. end;
  119. { TSybaseConnection }
  120. TSybaseConnection = class(TMSSQLConnection)
  121. public
  122. constructor Create(AOwner : TComponent); override;
  123. end;
  124. { EMSSQLDatabaseError }
  125. EMSSQLDatabaseError = class(ESQLDatabaseError)
  126. public
  127. property DBErrorCode: integer read ErrorCode; deprecated 'Please use ErrorCode instead of DBErrorCode'; // Feb 2014
  128. end;
  129. { TMSSQLConnectionDef }
  130. TMSSQLConnectionDef = Class(TConnectionDef)
  131. Class Function TypeName : String; override;
  132. Class Function ConnectionClass : TSQLConnectionClass; override;
  133. Class Function Description : String; override;
  134. Class Function DefaultLibraryName : String; override;
  135. Class Function LoadFunction : TLibraryLoadFunction; override;
  136. Class Function UnLoadFunction : TLibraryUnLoadFunction; override;
  137. Class Function LoadedLibraryName: string; override;
  138. end;
  139. { TSybaseConnectionDef }
  140. TSybaseConnectionDef = Class(TMSSQLConnectionDef)
  141. Class Function TypeName : String; override;
  142. Class Function ConnectionClass : TSQLConnectionClass; override;
  143. Class Function Description : String; override;
  144. end;
  145. var
  146. DBLibLibraryName: string = DBLIBDLL;
  147. implementation
  148. uses StrUtils, FmtBCD;
  149. type
  150. { TDBLibCursor }
  151. TDBLibCursor = class(TSQLCursor)
  152. private
  153. FConnection: TMSSQLConnection; // owner connection
  154. FQuery: string; // :ParamNames converted to $1,$2,..,$n
  155. FParamReplaceString: string;
  156. protected
  157. FRowsAffected: integer;
  158. function ReplaceParams(AParams: TParams): string; // replaces parameters placeholders $1,$2,..$n in FQuery with supplied values in AParams
  159. procedure Prepare(Buf: string; AParams: TParams);
  160. procedure Execute(AParams: TParams);
  161. function Fetch: boolean;
  162. procedure Put(column: integer; out s: string); overload;
  163. public
  164. constructor Create(AConnection: TMSSQLConnection); overload;
  165. end;
  166. const
  167. SBeginTransaction = 'BEGIN TRANSACTION';
  168. SAutoCommit = 'AUTOCOMMIT';
  169. STextSize = 'TEXTSIZE';
  170. SAppName = 'APPLICATIONNAME';
  171. var
  172. DBErrorStr, DBMsgStr: AnsiString;
  173. DBErrorNo, DBMsgNo: integer;
  174. function DBErrHandler(dbproc: PDBPROCESS; severity, dberr, oserr:INT; dberrstr, oserrstr:PAnsiChar):INT; cdecl;
  175. begin
  176. DBErrorStr:=DBErrorStr+LineEnding+dberrstr;
  177. DBErrorNo :=dberr;
  178. Result :=INT_CANCEL;
  179. // for server messages with severity greater than 10 error handler is also called
  180. end;
  181. function DBMsgHandler(dbproc: PDBPROCESS; msgno: DBINT; msgstate, severity:INT; msgtext, srvname, procname:PAnsiChar; line:DBUSMALLINT):INT; cdecl;
  182. begin
  183. DBMsgStr:=DBMsgStr+LineEnding+msgtext;
  184. DBMsgNo :=msgno;
  185. Result :=0;
  186. end;
  187. { TDBLibCursor }
  188. procedure TDBLibCursor.Prepare(Buf: string; AParams: TParams);
  189. var
  190. ParamBinding : TParamBinding;
  191. begin
  192. if assigned(AParams) and (AParams.Count > 0) then
  193. FQuery:=AParams.ParseSQL(Buf, false, sqEscapeSlash in FConnection.ConnOptions, sqEscapeRepeat in FConnection.ConnOptions, psSimulated, ParamBinding, FParamReplaceString)
  194. else
  195. FQuery:=Buf;
  196. FPrepared := True;
  197. end;
  198. function TDBLibCursor.ReplaceParams(AParams: TParams): string;
  199. var i: integer;
  200. ParamNames, ParamValues: array of string;
  201. begin
  202. if Assigned(AParams) and (AParams.Count > 0) then //taken from mysqlconn, pqconnection
  203. begin
  204. setlength(ParamNames, AParams.Count);
  205. setlength(ParamValues, AParams.Count);
  206. for i := 0 to AParams.Count -1 do
  207. begin
  208. ParamNames[AParams.Count-i-1] := format('%s%d', [FParamReplaceString, AParams[i].Index+1]);
  209. ParamValues[AParams.Count-i-1] := FConnection.GetAsSQLText(AParams[i]);
  210. end;
  211. Result := stringsreplace(FQuery, ParamNames, ParamValues, [rfReplaceAll]);
  212. end
  213. else
  214. Result := FQuery;
  215. end;
  216. procedure TDBLibCursor.Execute(AParams: TParams);
  217. begin
  218. Fconnection.Execute(Self, nil, AParams);
  219. end;
  220. function TDBLibCursor.Fetch: boolean;
  221. begin
  222. Result := Fconnection.Fetch(Self);
  223. end;
  224. procedure TDBLibCursor.Put(column: integer; out s: string);
  225. var
  226. data: PByte;
  227. datalen: DBINT;
  228. begin
  229. data := dbdata(Fconnection.FDBProc, column);
  230. datalen := dbdatlen(Fconnection.FDBProc, column);
  231. SetString(s, PAnsiChar(data), datalen);
  232. end;
  233. constructor TDBLibCursor.Create(AConnection: TMSSQLConnection);
  234. begin
  235. inherited Create;
  236. FConnection := AConnection;
  237. end;
  238. { TSybaseConnection }
  239. constructor TSybaseConnection.Create(AOwner: TComponent);
  240. begin
  241. inherited Create(AOwner);
  242. Ftds := DBTDS_50;
  243. end;
  244. { TMSSQLConnection }
  245. function TMSSQLConnection.IsSybase: boolean;
  246. begin
  247. Result := (Ftds=DBTDS_50) or (Ftds=DBTDS_42);
  248. end;
  249. function TMSSQLConnection.CheckError(const Ret: RETCODE): RETCODE;
  250. var E: EMSSQLDatabaseError;
  251. begin
  252. if (Ret=FAIL) or (DBErrorStr<>'') then
  253. begin
  254. // try clear all pending results to allow ROLLBACK and prevent error 10038 "Results pending"
  255. if assigned(FDBProc) then dbcancel(FDBProc);
  256. if DBErrorStr = '' then
  257. case DBErrorNo of
  258. SYBEFCON: DBErrorStr:='SQL Server connection failed!';
  259. end;
  260. E:=EMSSQLDatabaseError.CreateFmt('Error %d : %s'+LineEnding+'%s', [DBErrorNo, DBErrorStr, DBMsgStr], Self, DBErrorNo, '');
  261. DBErrorStr:='';
  262. DBMsgStr:='';
  263. raise E;
  264. end;
  265. Result:=Ret;
  266. end;
  267. constructor TMSSQLConnection.Create(AOwner: TComponent);
  268. begin
  269. inherited Create(AOwner);
  270. FConnOptions := [sqSupportEmptyDatabaseName, sqEscapeRepeat, sqImplicitTransaction, sqLastInsertID];
  271. //FieldNameQuoteChars:=DoubleQuotes; //default
  272. Ftds := DBTDS_UNKNOWN;
  273. end;
  274. procedure TMSSQLConnection.CreateDB;
  275. begin
  276. ExecuteDirectSQL('CREATE DATABASE '+DatabaseName);
  277. end;
  278. procedure TMSSQLConnection.DropDB;
  279. begin
  280. ExecuteDirectSQL('DROP DATABASE '+DatabaseName);
  281. end;
  282. procedure TMSSQLConnection.ExecuteDirectSQL(const Query: string);
  283. var ADatabaseName: string;
  284. begin
  285. CheckDisConnected;
  286. ADatabaseName:=DatabaseName;
  287. DatabaseName:='';
  288. try
  289. Open;
  290. Execute(Query);
  291. finally
  292. Close;
  293. DatabaseName:=ADatabaseName;
  294. end;
  295. end;
  296. function TMSSQLConnection.GetHandle: pointer;
  297. begin
  298. Result:=FDBProc;
  299. end;
  300. function TMSSQLConnection.GetAsSQLText(Param: TParam): string;
  301. function IsBinary(const s: string): boolean;
  302. var i: integer;
  303. begin
  304. for i:=1 to length(s) do if s[i] < #9 then Exit(true);
  305. Exit(false);
  306. end;
  307. function StrToHex(const s: string): string;
  308. begin
  309. setlength(Result, 2*length(s));
  310. BinToHex(PChar(s), PChar(Result), length(s));
  311. end;
  312. begin
  313. if not Param.IsNull then
  314. case Param.DataType of
  315. ftBoolean:
  316. if Param.AsBoolean then
  317. Result:='1'
  318. else
  319. Result:='0';
  320. ftString, ftFixedChar, ftMemo:
  321. //if IsBinary(Param.AsString) then
  322. // Result := '0x' + StrToHex(Param.AsString)
  323. //else
  324. Result := 'N' + inherited GetAsSQLText(Param);
  325. ftBlob, ftBytes, ftVarBytes:
  326. Result := '0x' + StrToHex(Param.AsString);
  327. else
  328. Result := inherited GetAsSQLText(Param);
  329. end
  330. else
  331. Result:=inherited GetAsSQLText(Param);
  332. end;
  333. function TMSSQLConnection.GetConnectionCharSet: string;
  334. begin
  335. if CharSet = '' then
  336. Result := 'utf-8'
  337. else
  338. Result := CharSet;
  339. end;
  340. procedure TMSSQLConnection.DoInternalConnect;
  341. const
  342. DBVERSION: array[boolean] of BYTE = (DBVER60, DBVERSION_100);
  343. IMPLICIT_TRANSACTIONS_OFF: array[boolean] of shortstring = ('SET IMPLICIT_TRANSACTIONS OFF', 'SET CHAINED OFF');
  344. ANSI_DEFAULTS_ON: array[boolean] of shortstring = ('SET ANSI_DEFAULTS ON', 'SET QUOTED_IDENTIFIER ON');
  345. CURSOR_CLOSE_ON_COMMIT_OFF: array[boolean] of shortstring = ('SET CURSOR_CLOSE_ON_COMMIT OFF', 'SET CLOSE ON ENDTRAN OFF');
  346. VERSION_NUMBER: array[boolean] of shortstring = ('SERVERPROPERTY(''ProductVersion'')', '@@version_number');
  347. begin
  348. // empty DatabaseName=default database defined for login
  349. inherited DoInternalConnect;
  350. InitialiseDBLib(DBLibLibraryName);
  351. if not DBLibInit then
  352. begin
  353. dbinit();
  354. dberrhandle(@DBErrHandler);
  355. dbmsghandle(@DBMsgHandler);
  356. DBLibInit:=true;
  357. end;
  358. FDBLogin:=dblogin();
  359. if FDBLogin=nil then DatabaseError('dblogin() failed!');
  360. // DBVERSION_100 is ATM not implemented by FreeTDS 0.91;
  361. // set environment variable TDSVER to 5.0: Windows: SET TDSVER=5.0, Unix/Linux: TDSVER=5.0
  362. // or in freetds.conf: include "tds version=5.0"
  363. dbsetlversion(FDBLogin, DBVERSION[IsSybase]);
  364. if UserName = '' then
  365. dbsetlsecure(FDBLogin)
  366. else
  367. begin
  368. dbsetlname(FDBLogin, PAnsiChar(UserName), DBSETUSER);
  369. dbsetlname(FDBLogin, PAnsiChar(Password), DBSETPWD);
  370. end;
  371. if CharSet = '' then
  372. dbsetlcharset(FDBLogin, 'UTF-8')
  373. else
  374. dbsetlcharset(FDBLogin, PAnsiChar(CharSet));
  375. if Params.IndexOfName(SAppName) <> -1 then
  376. dbsetlname(FDBLogin, PAnsiChar(Params.Values[SAppName]), DBSETAPP);
  377. //dbsetlname(FDBLogin, PAnsiChar(TIMEOUT_IGNORE), DBSET_LOGINTIME);
  378. dbsetlogintime(10);
  379. FDBProc := dbopen(FDBLogin, PAnsiChar(HostName));
  380. if FDBProc=nil then CheckError(FAIL);
  381. Ftds := dbtds(FDBProc);
  382. //CheckError( dbsetopt(FDBProc, DBQUOTEDIDENT, '') ); //in FreeTDS executes: "SET QUOTED_IDENTIFIER ON"
  383. //CheckError( dbsetopt(FDBProc, DBTEXTSIZE, '2147483647') ); //in FreeTDS: unimplemented, returns FAIL
  384. //CheckError( dbsetopt(FDBProc, DBTEXTLIMIT, '2147483647') ); //in FreeTDS: unimplemented, returns FAIL, but required by ntwdblib.dll
  385. //CheckError( dbsqlexec(FDBProc) ); //after setting DBTEXTSIZE option
  386. //CheckError (dbresults(FDBProc));
  387. //while dbresults(FDBProc) = SUCCEED do ;
  388. // Also SQL Server ODBC driver and Microsoft OLE DB Provider for SQL Server set ANSI_DEFAULTS to ON when connecting
  389. //Execute(ANSI_DEFAULTS_ON[IsSybase]);
  390. Execute('SET QUOTED_IDENTIFIER ON');
  391. if Params.IndexOfName(STextSize) <> -1 then
  392. Execute('SET TEXTSIZE '+Params.Values[STextSize])
  393. else
  394. Execute('SET TEXTSIZE 16777216');
  395. if AutoCommit then
  396. Execute(IMPLICIT_TRANSACTIONS_OFF[IsSybase]); //set connection to autocommit mode - default
  397. if DatabaseName <> '' then
  398. CheckError( dbuse(FDBProc, PAnsiChar(DatabaseName)) );
  399. with TDBLibCursor.Create(Self) do
  400. begin
  401. try
  402. Prepare(format('SELECT cast(%s as varchar), @@version, user_name()', [VERSION_NUMBER[IsSybase]]), nil);
  403. Execute(nil);
  404. while Fetch do
  405. begin
  406. Put(1, FServerInfo.ServerVersion);
  407. Put(2, FServerInfo.ServerVersionString);
  408. Put(3, FServerInfo.UserName);
  409. end;
  410. except
  411. FServerInfo.ServerVersion:='';
  412. FServerInfo.ServerVersionString:='';
  413. FServerInfo.UserName:='';
  414. end;
  415. Free;
  416. end;
  417. end;
  418. procedure TMSSQLConnection.DoInternalDisconnect;
  419. begin
  420. inherited DoInternalDisconnect;
  421. dbclose(FDBProc);
  422. dbfreelogin(FDBLogin);
  423. ReleaseDBLib;
  424. end;
  425. function TMSSQLConnection.AllocateCursorHandle: TSQLCursor;
  426. begin
  427. Result:=TDBLibCursor.Create(Self);
  428. end;
  429. procedure TMSSQLConnection.DeAllocateCursorHandle(var cursor: TSQLCursor);
  430. begin
  431. FreeAndNil(cursor);
  432. end;
  433. function TMSSQLConnection.StrToStatementType(s: string): TStatementType;
  434. begin
  435. s:=LowerCase(s);
  436. if s = 'exec' then
  437. Result:=stExecProcedure
  438. else
  439. Result:=inherited StrToStatementType(s);
  440. end;
  441. function TMSSQLConnection.AllocateTransactionHandle: TSQLHandle;
  442. begin
  443. Result:=nil;
  444. end;
  445. function TMSSQLConnection.GetTransactionHandle(trans: TSQLHandle): pointer;
  446. begin
  447. Result:=nil;
  448. end;
  449. function TMSSQLConnection.StartDBTransaction(trans: TSQLHandle; AParams: string): boolean;
  450. begin
  451. Result := not AutoCommit;
  452. if Result then
  453. Execute(SBeginTransaction);
  454. end;
  455. function TMSSQLConnection.Commit(trans: TSQLHandle): boolean;
  456. begin
  457. Execute('COMMIT');
  458. Result:=true;
  459. end;
  460. function TMSSQLConnection.Rollback(trans: TSQLHandle): boolean;
  461. begin
  462. Execute('IF @@TRANCOUNT>0 ROLLBACK');
  463. Result:=true;
  464. end;
  465. procedure TMSSQLConnection.CommitRetaining(trans: TSQLHandle);
  466. begin
  467. if Commit(trans) then
  468. Execute(SBeginTransaction);
  469. end;
  470. procedure TMSSQLConnection.RollbackRetaining(trans: TSQLHandle);
  471. begin
  472. if Rollback(trans) then
  473. Execute(SBeginTransaction);
  474. end;
  475. function TMSSQLConnection.AutoCommit: boolean;
  476. begin
  477. Result := StrToBoolDef(Params.Values[SAutoCommit], False);
  478. end;
  479. procedure TMSSQLConnection.PrepareStatement(cursor: TSQLCursor;
  480. ATransaction: TSQLTransaction; buf: string; AParams: TParams);
  481. begin
  482. (cursor as TDBLibCursor).Prepare(buf, AParams);
  483. end;
  484. procedure TMSSQLConnection.UnPrepareStatement(cursor: TSQLCursor);
  485. begin
  486. if assigned(FDBProc) and (Fstatus <> NO_MORE_ROWS) then
  487. dbcanquery(FDBProc);
  488. end;
  489. procedure TMSSQLConnection.Execute(const cmd: string);
  490. begin
  491. DBErrorStr:='';
  492. DBMsgStr :='';
  493. CheckError( dbcmd(FDBProc, PAnsiChar(cmd)) );
  494. CheckError( dbsqlexec(FDBProc) );
  495. CheckError( dbresults(FDBProc) );
  496. end;
  497. procedure TMSSQLConnection.Execute(cursor: TSQLCursor; ATransaction: TSQLTransaction; AParams: TParams);
  498. var c: TDBLibCursor;
  499. cmd: string;
  500. res: RETCODE;
  501. begin
  502. c:=cursor as TDBLibCursor;
  503. if LogEvent(detParamValue) then
  504. LogParams(AParams);
  505. cmd := c.ReplaceParams(AParams);
  506. if LogEvent(detActualSQL) then
  507. Log(detActualSQL,Cmd);
  508. Execute(cmd);
  509. res := SUCCEED;
  510. repeat
  511. c.FSelectable := dbcmdrow(FDBProc)=SUCCEED;
  512. c.FRowsAffected := dbcount(FDBProc);
  513. if assigned(dbiscount) and not dbiscount(FDBProc) then
  514. c.FRowsAffected := -1;
  515. if not c.FSelectable then //Sybase stored proc.
  516. begin
  517. repeat
  518. Fstatus := dbnextrow(FDBProc);
  519. until (Fstatus = NO_MORE_ROWS) or (Fstatus = FAIL);
  520. res := CheckError( dbresults(FDBProc) );
  521. // stored procedure information (return status and output parameters)
  522. // are available only after normal results are processed
  523. //if res = NO_MORE_RESULTS then GetParameters(cursor, AParams);
  524. end;
  525. until c.FSelectable or (res = NO_MORE_RESULTS) or (res = FAIL);
  526. if res = NO_MORE_RESULTS then
  527. Fstatus := NO_MORE_ROWS
  528. else
  529. Fstatus := MORE_ROWS;
  530. end;
  531. procedure TMSSQLConnection.GetParameters(cursor: TSQLCursor; AParams: TParams);
  532. var Param: TParam;
  533. begin
  534. // Microsoft SQL Server no more returns OUTPUT parameters as a special result row
  535. // so we can not use dbret*() functions, but instead we must use dbrpc*() functions
  536. // only procedure return status number is returned
  537. if dbhasretstat(FDBProc) = 1 then
  538. begin
  539. Param := AParams.FindParam('RETURN_STATUS');
  540. if not assigned(Param) then
  541. Param := AParams.CreateParam(ftInteger, 'RETURN_STATUS', ptOutput);
  542. Param.AsInteger := dbretstatus(FDBProc);
  543. end;
  544. end;
  545. function TMSSQLConnection.RowsAffected(cursor: TSQLCursor): TRowsCount;
  546. begin
  547. if assigned(cursor) then
  548. Result := (cursor as TDBLibCursor).FRowsAffected
  549. else
  550. Result := inherited RowsAffected(cursor);
  551. end;
  552. function TMSSQLConnection.RefreshLastInsertID(Query: TCustomSQLQuery; Field: TField): boolean;
  553. var Identity: int64;
  554. begin
  555. // global variable @@IDENTITY is NUMERIC(38,0)
  556. Result:=False;
  557. if dbcmd(FDBProc, 'SELECT @@IDENTITY') = FAIL then Exit;
  558. if dbsqlexec(FDBProc) = FAIL then Exit;
  559. if dbresults(FDBProc) = FAIL then Exit;
  560. if dbnextrow(FDBProc) = FAIL then Exit;
  561. if dbconvert(FDBProc, dbcoltype(FDBProc,1), dbdata(FDBProc,1), -1, SYBINT8, @Identity, sizeof(Identity)) = -1 then Exit;
  562. // by default identity columns are ReadOnly
  563. Field.AsLargeInt := Identity;
  564. Result:=True;
  565. end;
  566. function TMSSQLConnection.TranslateFldType(SQLDataType: integer): TFieldType;
  567. begin
  568. case SQLDataType of
  569. SQLCHAR: Result:=ftFixedChar;
  570. SQLVARCHAR: Result:=ftString;
  571. SQLINT1: Result:=ftWord;
  572. SQLINT2: Result:=ftSmallInt;
  573. SQLINT4, SQLINTN: Result:=ftInteger;
  574. SYBINT8: Result:=ftLargeInt;
  575. SQLFLT4, SQLFLT8,
  576. SQLFLTN: Result:=ftFloat;
  577. SQLMONEY4, SQLMONEY,
  578. SQLMONEYN: Result:=ftCurrency;
  579. SYBMSDATE: Result:=ftDate;
  580. SYBMSTIME: Result:=ftTime;
  581. SQLDATETIM4, SQLDATETIME,
  582. SQLDATETIMN,
  583. SYBMSDATETIME2,
  584. SYBMSDATETIMEOFFSET: Result:=ftDateTime;
  585. SYBMSXML,
  586. SQLTEXT: Result:=ftMemo;
  587. SQLIMAGE: Result:=ftBlob;
  588. SQLDECIMAL, SQLNUMERIC: Result:=ftBCD;
  589. SQLBIT: Result:=ftBoolean;
  590. SQLBINARY: Result:=ftBytes;
  591. SQLVARBINARY: Result:=ftVarBytes;
  592. SYBUNIQUE: Result:=ftGuid;
  593. SYBVARIANT: Result:=ftBlob;
  594. else
  595. DatabaseErrorFmt('Unsupported SQL DataType %d "%s"', [SQLDataType, dbprtype(SQLDataType)]);
  596. Result:=ftUnknown;
  597. end;
  598. end;
  599. procedure TMSSQLConnection.AddFieldDefs(cursor: TSQLCursor; FieldDefs: TFieldDefs);
  600. var i, FieldSize: integer;
  601. FieldName: string;
  602. FieldType: TFieldType;
  603. col: DBCOL;
  604. begin
  605. col.SizeOfStruct:=sizeof(col);
  606. for i:=1 to dbnumcols(FDBProc) do
  607. begin
  608. if dbtablecolinfo(FDBProc, i, @col) = FAIL then continue;
  609. FieldName := col.Name;
  610. FieldType := TranslateFldType(col.Typ);
  611. case FieldType of
  612. ftString, ftFixedChar:
  613. begin
  614. FieldSize := col.MaxLength;
  615. if FieldSize >= $3FFFFFFF then // varchar(max)
  616. FieldType := ftMemo;
  617. end;
  618. ftBytes, ftVarBytes:
  619. begin
  620. FieldSize := col.MaxLength;
  621. if FieldSize >= $3FFFFFFF then // varbinary(max)
  622. FieldType := ftBlob;
  623. end;
  624. ftBCD:
  625. begin
  626. FieldSize := col.Scale;
  627. if (FieldSize > MaxBCDScale) or (col.Precision-col.Scale > MaxBCDPrecision-MaxBCDScale) then
  628. FieldType := ftFmtBCD;
  629. end;
  630. ftGuid:
  631. FieldSize := 38;
  632. else
  633. FieldSize := 0;
  634. if col.Identity and (FieldType = ftInteger) then
  635. FieldType := ftAutoInc;
  636. end;
  637. // identity, timestamp and calculated column are not updatable
  638. AddFieldDef(FieldDefs, i, FieldName, FieldType, FieldSize, col.Precision, True, (col.Null=0) and (not col.Identity), col.Updatable=0);
  639. end;
  640. end;
  641. function TMSSQLConnection.Fetch(cursor: TSQLCursor): boolean;
  642. begin
  643. // Compute rows resulting from the COMPUTE clause are not processed
  644. repeat
  645. Fstatus := dbnextrow(FDBProc);
  646. // In case of network failure FAIL is returned
  647. // Use dbsettime() to specify query timeout, else on Windows TCP KeepAliveTime is used, which defaults to 2 hours
  648. Result := Fstatus=REG_ROW;
  649. until Result or (Fstatus = NO_MORE_ROWS) or (Fstatus = FAIL);
  650. if Fstatus = NO_MORE_ROWS then
  651. while dbresults(FDBProc) <> NO_MORE_RESULTS do // process remaining results if there are any
  652. repeat
  653. Fstatus := dbnextrow(FDBProc);
  654. until (Fstatus = NO_MORE_ROWS) or (Fstatus = FAIL);
  655. if Fstatus = FAIL then CheckError(FAIL);
  656. end;
  657. function TMSSQLConnection.LoadField(cursor: TSQLCursor; FieldDef: TFieldDef;
  658. buffer: pointer; out CreateBlob: boolean): boolean;
  659. var i: integer;
  660. data, dest: PByte;
  661. datalen, destlen: DBINT;
  662. srctype, desttype: INT;
  663. dbdt: DBDATETIME;
  664. dbdr: DBDATEREC;
  665. dbdta: DBDATETIMEALL;
  666. bcdstr: array[0..MaxFmtBCDFractionSize+2] of AnsiChar;
  667. begin
  668. CreateBlob:=false;
  669. i:=FieldDef.FieldNo;
  670. srctype:=dbcoltype(FDBProc,i);
  671. data:=dbdata(FDBProc,i);
  672. datalen:=dbdatlen(FDBProc,i);
  673. Result:=assigned(data) and (datalen>=0);
  674. if not Result then
  675. Exit;
  676. dest:=buffer;
  677. destlen:=FieldDef.Size;
  678. case FieldDef.DataType of
  679. ftString, ftFixedChar:
  680. begin
  681. desttype:=SQLCHAR;
  682. destlen:=FieldDef.Size*FieldDef.CharSize;
  683. end;
  684. ftBytes:
  685. desttype:=SQLBINARY;
  686. ftVarBytes:
  687. begin
  688. PWord(dest)^:=datalen;
  689. inc(dest, sizeof(Word));
  690. desttype:=SQLBINARY;
  691. end;
  692. ftSmallInt, ftWord:
  693. begin
  694. desttype:=SQLINT2;
  695. destlen:=sizeof(DBSMALLINT); //smallint
  696. end;
  697. ftAutoInc,
  698. ftInteger:
  699. begin
  700. desttype:=SQLINT4;
  701. destlen:=sizeof(DBINT); //integer
  702. end;
  703. ftLargeInt:
  704. begin
  705. desttype:=SYBINT8;
  706. destlen:=sizeof(int64);
  707. end;
  708. ftCurrency,
  709. ftFloat:
  710. begin
  711. desttype:=SQLFLT8;
  712. destlen:=sizeof(DBFLT8); //double
  713. end;
  714. ftDate, ftTime,
  715. ftDateTime:
  716. if srctype in [SYBMSDATE, SYBMSTIME, SYBMSDATETIME2, SYBMSDATETIMEOFFSET] then // dbwillconvert(srctype, SYBMSDATETIME2)
  717. begin
  718. dest:=@dbdta;
  719. desttype:=SYBMSDATETIME2;
  720. destlen:=sizeof(dbdta);
  721. end
  722. else
  723. begin
  724. dest:=@dbdt;
  725. desttype:=SQLDATETIME;
  726. destlen:=sizeof(dbdt);
  727. end;
  728. ftBCD:
  729. begin
  730. // FreeTDS 0.91 does not support converting from numeric to money
  731. //desttype:=SQLMONEY;
  732. desttype:=SQLFLT8;
  733. destlen:=sizeof(currency);
  734. end;
  735. ftFmtBCD:
  736. begin
  737. {
  738. dbnum.precision:=FieldDef.Precision;
  739. dbnum.scale :=FieldDef.Size;
  740. dest:=@dbnum;
  741. desttype:=SQLNUMERIC;
  742. destlen:=sizeof(dbnum);
  743. }
  744. dest:=@bcdstr[0];
  745. desttype:=SQLCHAR;
  746. destlen:=sizeof(bcdstr);
  747. fillchar(bcdstr, destlen, 0); //required when used ntwdblib.dll
  748. end;
  749. ftBoolean:
  750. begin
  751. desttype:=SQLBIT;
  752. destlen:=sizeof(WordBool);
  753. end;
  754. ftGuid:
  755. begin
  756. desttype:=SQLCHAR;
  757. end;
  758. ftMemo,
  759. ftBlob:
  760. begin
  761. CreateBlob:=true;
  762. Exit;
  763. end
  764. else
  765. //DatabaseErrorFmt('Tried to load field of unsupported field type %s',[FieldTypeNames[FieldDef.DataType]]);
  766. Result:=false;
  767. end;
  768. dbconvert(FDBProc, srctype, data , datalen, desttype, dest, destlen);
  769. case FieldDef.DataType of
  770. ftString, ftFixedChar:
  771. PAnsiChar(dest + datalen)^ := #0; //strings must be null-terminated
  772. ftDate, ftTime, ftDateTime:
  773. if desttype = SYBMSDATETIME2 then
  774. PDateTime(buffer)^ := dbdatetimeallcrack(@dbdta)
  775. else
  776. begin
  777. //detect DBDATEREC version by pre-setting dbdr
  778. dbdr.millisecond := -1;
  779. if dbdatecrack(FDBProc, @dbdr, @dbdt) = SUCCEED then
  780. begin
  781. if dbdr.millisecond = -1 then
  782. PDateTime(buffer)^ := composedatetime(
  783. encodedate(dbdr.oldyear, dbdr.oldmonth, dbdr.oldday),
  784. encodetime(dbdr.oldhour, dbdr.oldminute, dbdr.oldsecond, dbdr.oldmillisecond))
  785. else
  786. PDateTime(buffer)^ := composedatetime(
  787. encodedate(dbdr.year, dbdr.month, dbdr.day),
  788. encodetime(dbdr.hour, dbdr.minute, dbdr.second, dbdr.millisecond));
  789. end;
  790. end;
  791. ftBCD:
  792. PCurrency(buffer)^ := FloatToCurr(PDouble(buffer)^); //PCurrency(buffer)^ := dbmoneytocurr(buffer);
  793. ftFmtBCD:
  794. PBCD(buffer)^:=StrToBCD(bcdstr, FSQLFormatSettings); //PBCD(buffer)^:=dbnumerictobcd(dbnum);
  795. end;
  796. end;
  797. procedure TMSSQLConnection.LoadBlobIntoBuffer(FieldDef: TFieldDef;
  798. ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction: TSQLTransaction);
  799. var data: PByte;
  800. datalen: DBINT;
  801. begin
  802. // see also LoadField
  803. data:=dbdata(FDBProc, FieldDef.FieldNo);
  804. datalen:=dbdatlen(FDBProc, FieldDef.FieldNo);
  805. ReAllocMem(ABlobBuf^.BlobBuffer^.Buffer, datalen);
  806. Move(data^, ABlobBuf^.BlobBuffer^.Buffer^, datalen);
  807. ABlobBuf^.BlobBuffer^.Size := datalen;
  808. end;
  809. procedure TMSSQLConnection.FreeFldBuffers(cursor: TSQLCursor);
  810. begin
  811. inherited FreeFldBuffers(cursor);
  812. end;
  813. procedure TMSSQLConnection.UpdateIndexDefs(IndexDefs: TIndexDefs; TableName: string);
  814. const INDEXES_QUERY: array[boolean] of string=(
  815. //MS SQL Server; TODO: we can use "execute dbo.sp_helpindex 'TableName'" when Open on Execute will fully work
  816. 'select i.name, i.indid, c.name as col_name,'+
  817. 'indexproperty(i.id, i.name, ''IsUnique''),'+
  818. 'objectproperty(o.id, ''IsPrimaryKey'') '+
  819. 'from sysindexes i '+
  820. ' join sysindexkeys k on i.id=k.id and i.indid=k.indid '+
  821. ' join syscolumns c on k.id=c.id and k.colid=c.colid '+
  822. ' left join sysobjects o on i.name=o.name and i.id=o.parent_obj '+
  823. 'where i.id=object_id(''%s'') '+
  824. 'order by k.indid, k.keyno'
  825. ,
  826. //Sybase; http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.infocenter.help.ase.15.7/title.htm
  827. 'select i.name, i.indid,' +
  828. 'index_col(object_name(i.id),i.indid,c.colid) as col_name,' +
  829. '(i.status & 2)/2 as IsUnique,' +
  830. '(i.status & 2048)/2048 as IsPrimaryKey ' +
  831. 'from sysindexes i '+
  832. ' join syscolumns c on c.id=i.id and c.colid<=i.keycnt-case i.indid when 1 then 0 else 1 end ' +
  833. 'where i.id=object_id(''%s'') '+
  834. ' and i.indid between 1 and 254 '+ // indid 0 is the table name, 255 is TEXT,IMAGE
  835. 'order by i.indid, c.colid'
  836. );
  837. var qry : TSQLQuery;
  838. begin
  839. //if not assigned(Transaction) then
  840. // DatabaseError(SErrConnTransactionnSet);
  841. qry := TSQLQuery.Create(nil);
  842. qry.Transaction := Transaction;
  843. qry.Database := Self;
  844. with qry do
  845. begin
  846. ReadOnly := True;
  847. SQL.Text := format(INDEXES_QUERY[IsSybase], [TableName]);
  848. Open;
  849. end;
  850. while not qry.Eof do with IndexDefs.AddIndexDef do
  851. begin
  852. Name := trim(qry.Fields[0].AsString);
  853. Fields := trim(qry.Fields[2].AsString);
  854. if qry.Fields[3].AsInteger=1 then Options := Options + [ixUnique];
  855. if qry.Fields[4].AsInteger=1 then Options := Options + [ixPrimary];
  856. qry.Next;
  857. while (Name = trim(qry.Fields[0].AsString)) and (not qry.Eof) do
  858. begin
  859. Fields := Fields + ';' + trim(qry.Fields[2].AsString);
  860. qry.Next;
  861. end;
  862. end;
  863. qry.Close;
  864. qry.Free;
  865. end;
  866. function TMSSQLConnection.GetSchemaInfoSQL(SchemaType: TSchemaType; SchemaObjectName, SchemaObjectPattern: string): string;
  867. const SCHEMA_QUERY='select id as RECNO, db_name() as CATALOG_NAME, user_name(uid) as SCHEMA_NAME, name as %s '+
  868. 'from sysobjects '+
  869. 'where type in (%s) '+
  870. 'order by name';
  871. begin
  872. // for simplicity are used only system tables and columns, common to both MS SQL Server and Sybase
  873. case SchemaType of
  874. stTables : Result := format(SCHEMA_QUERY, ['TABLE_NAME, 1 as TABLE_TYPE', '''U''']);
  875. stSysTables : Result := format(SCHEMA_QUERY, ['TABLE_NAME, 4 as TABLE_TYPE', '''S''']);
  876. stProcedures : Result := format(SCHEMA_QUERY, ['PROCEDURE_NAME , case type when ''P'' then 1 else 2 end as PROCEDURE_TYPE', '''P'',''FN'',''IF'',''TF''']);
  877. stColumns : Result := 'select colid as RECNO, db_name() as CATALOG_NAME, user_name(uid) as SCHEMA_NAME, o.name as TABLE_NAME,'+
  878. 'c.name as COLUMN_NAME,'+
  879. 'colid as COLUMN_POSITION,'+
  880. '0 as COLUMN_TYPE,'+
  881. 'c.type as COLUMN_DATATYPE,'+
  882. ''''' as COLUMN_TYPENAME,'+
  883. 'usertype as COLUMN_SUBTYPE,'+
  884. 'prec as COLUMN_PRECISION,'+
  885. 'scale as COLUMN_SCALE,'+
  886. 'length as COLUMN_LENGTH,'+
  887. 'case when c.status&8=8 then 1 else 0 end as COLUMN_NULLABLE '+
  888. 'from syscolumns c join sysobjects o on c.id=o.id '+
  889. 'where c.id=object_id(''' + SchemaObjectName + ''') '+
  890. 'order by colid';
  891. else Result := inherited;
  892. end;
  893. end;
  894. function TMSSQLConnection.GetConnectionInfo(InfoType: TConnInfoType): string;
  895. const
  896. SERVER_TYPE: array[boolean] of string = ('Microsoft SQL Server', 'ASE'); // product_name returned in TDS login token; same like ODBC SQL_DBMS_NAME
  897. begin
  898. Result:='';
  899. try
  900. InitialiseDBLib(DBLibLibraryName);
  901. case InfoType of
  902. citServerType:
  903. Result:=SERVER_TYPE[IsSybase];
  904. citServerVersion:
  905. if Connected then
  906. Result:=FServerInfo.ServerVersion;
  907. citServerVersionString:
  908. if Connected then
  909. Result:=FServerInfo.ServerVersionString;
  910. citClientName:
  911. Result:=TMSSQLConnectionDef.LoadedLibraryName;
  912. else
  913. Result:=inherited GetConnectionInfo(InfoType);
  914. end;
  915. finally
  916. ReleaseDBLib;
  917. end;
  918. end;
  919. { TMSSQLConnectionDef }
  920. class function TMSSQLConnectionDef.TypeName: String;
  921. begin
  922. Result:='MSSQLServer';
  923. end;
  924. class function TMSSQLConnectionDef.ConnectionClass: TSQLConnectionClass;
  925. begin
  926. Result:=TMSSQLConnection;
  927. end;
  928. class function TMSSQLConnectionDef.Description: String;
  929. begin
  930. Result:='Connect to MS SQL Server via Microsoft client library or via FreeTDS db-lib';
  931. end;
  932. class function TMSSQLConnectionDef.DefaultLibraryName: String;
  933. begin
  934. Result:=DBLibLibraryName;
  935. end;
  936. class function TMSSQLConnectionDef.LoadFunction: TLibraryLoadFunction;
  937. begin
  938. Result:=@InitialiseDBLib;
  939. end;
  940. class function TMSSQLConnectionDef.UnLoadFunction: TLibraryUnLoadFunction;
  941. begin
  942. Result:=@ReleaseDBLib;
  943. end;
  944. class function TMSSQLConnectionDef.LoadedLibraryName: string;
  945. begin
  946. Result:=DBLibLoadedLibrary;
  947. end;
  948. { TSybaseConnectionDef }
  949. class function TSybaseConnectionDef.TypeName: String;
  950. begin
  951. Result:='Sybase';
  952. end;
  953. class function TSybaseConnectionDef.ConnectionClass: TSQLConnectionClass;
  954. begin
  955. Result:=TSybaseConnection;
  956. end;
  957. class function TSybaseConnectionDef.Description: String;
  958. begin
  959. Result:='Connect to Sybase SQL Server via FreeTDS db-lib';;
  960. end;
  961. initialization
  962. RegisterConnection(TMSSQLConnectionDef);
  963. RegisterConnection(TSybaseConnectionDef);
  964. finalization
  965. UnRegisterConnection(TMSSQLConnectionDef);
  966. UnRegisterConnection(TSybaseConnectionDef);
  967. end.