mssqlconn.pp 26 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896
  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. CharSet - if you use Microsoft DB-Lib and set to 'UTF-8' then char/varchar fields will be UTF8Encoded/Decoded
  25. 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
  26. Params - "AutoCommit=true" - if you don't want explicitly commit/rollback transactions
  27. "TextSize=16777216 - set maximum size of text/image data returned
  28. }
  29. unit mssqlconn;
  30. {$mode objfpc}{$H+}
  31. interface
  32. uses
  33. Classes, SysUtils, sqldb, db, BufDataset,
  34. dblib;
  35. type
  36. TClientCharset = (ccNone, ccUTF8, ccISO88591, ccUnknown);
  37. { TMSSQLConnection }
  38. TMSSQLConnection = class(TSQLConnection)
  39. private
  40. FDBLogin: PLOGINREC;
  41. FDBProc : PDBPROCESS;
  42. Ftds : integer; // TDS protocol version
  43. Fstatus : STATUS; // current result/rows fetch status
  44. procedure DBExecute(const cmd: string);
  45. function TranslateFldType(SQLDataType: integer): TFieldType;
  46. function ClientCharset: TClientCharset;
  47. function AutoCommit: boolean;
  48. function IsSybase: boolean;
  49. protected
  50. // Overrides from TSQLConnection
  51. function GetHandle:pointer; override;
  52. function GetAsSQLText(Param : TParam) : string; overload; override;
  53. // - Connect/disconnect
  54. procedure DoInternalConnect; override;
  55. procedure DoInternalDisconnect; override;
  56. // - Handle (de)allocation
  57. function AllocateCursorHandle:TSQLCursor; override;
  58. procedure DeAllocateCursorHandle(var cursor:TSQLCursor); override;
  59. function AllocateTransactionHandle:TSQLHandle; override;
  60. // - Statement handling
  61. function StrToStatementType(s : string) : TStatementType; override;
  62. procedure PrepareStatement(cursor:TSQLCursor; ATransaction:TSQLTransaction; buf:string; AParams:TParams); override;
  63. procedure UnPrepareStatement(cursor:TSQLCursor); override;
  64. // - Transaction handling
  65. function GetTransactionHandle(trans:TSQLHandle):pointer; override;
  66. function StartDBTransaction(trans:TSQLHandle; AParams:string):boolean; override;
  67. function Commit(trans:TSQLHandle):boolean; override;
  68. function Rollback(trans:TSQLHandle):boolean; override;
  69. procedure CommitRetaining(trans:TSQLHandle); override;
  70. procedure RollbackRetaining(trans:TSQLHandle); override;
  71. // - Statement execution
  72. procedure Execute(cursor:TSQLCursor; ATransaction:TSQLTransaction; AParams:TParams); override;
  73. function RowsAffected(cursor: TSQLCursor): TRowsCount; override;
  74. // - Result retrieving
  75. procedure AddFieldDefs(cursor:TSQLCursor; FieldDefs:TFieldDefs); override;
  76. function Fetch(cursor:TSQLCursor):boolean; override;
  77. function LoadField(cursor:TSQLCursor; FieldDef:TFieldDef; buffer:pointer; out CreateBlob : boolean):boolean; override;
  78. procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction : TSQLTransaction); override;
  79. procedure FreeFldBuffers(cursor:TSQLCursor); override;
  80. // - UpdateIndexDefs
  81. procedure UpdateIndexDefs(IndexDefs:TIndexDefs; TableName:string); override;
  82. // - Schema info
  83. function GetSchemaInfoSQL(SchemaType:TSchemaType; SchemaObjectName, SchemaObjectPattern:string):string; override;
  84. public
  85. constructor Create(AOwner : TComponent); override;
  86. //property TDS:integer read Ftds;
  87. published
  88. // Redeclare properties from TSQLConnection
  89. property Password;
  90. property Transaction;
  91. property UserName;
  92. property CharSet;
  93. property HostName;
  94. // Redeclare properties from TDatabase
  95. property Connected;
  96. property Role;
  97. property DatabaseName;
  98. property KeepConnection;
  99. property LoginPrompt;
  100. property Params;
  101. property OnLogin;
  102. end;
  103. { TSybaseConnection }
  104. TSybaseConnection = class(TMSSQLConnection)
  105. public
  106. constructor Create(AOwner : TComponent); override;
  107. end;
  108. { EMSSQLDatabaseError }
  109. EMSSQLDatabaseError = class(EDatabaseError)
  110. public
  111. DBErrorCode : integer;
  112. end;
  113. { TMSSQLConnectionDef }
  114. TMSSQLConnectionDef = Class(TConnectionDef)
  115. Class Function TypeName : String; override;
  116. Class Function ConnectionClass : TSQLConnectionClass; override;
  117. Class Function Description : String; override;
  118. end;
  119. { TSybaseConnectionDef }
  120. TSybaseConnectionDef = Class(TConnectionDef)
  121. Class Function TypeName : String; override;
  122. Class Function ConnectionClass : TSQLConnectionClass; override;
  123. Class Function Description : String; override;
  124. end;
  125. var
  126. DBLibLibraryName: string = DBLIBDLL;
  127. implementation
  128. uses DBConst, StrUtils, FmtBCD;
  129. type
  130. { TDBLibCursor }
  131. TDBLibCursor = class(TSQLCursor)
  132. protected
  133. FQuery: string; //:ParamNames converted to $1,$2,..,$n
  134. FCanOpen: boolean; //can return rows?
  135. FRowsAffected: integer;
  136. FParamReplaceString: string;
  137. function ReplaceParams(AParams: TParams; ASQLConnection: TMSSQLConnection): string; //replaces parameters placeholders $1,$2,..$n in FQuery with supplied values in AParams
  138. end;
  139. const
  140. SBeginTransaction = 'BEGIN TRANSACTION';
  141. SAutoCommit = 'AUTOCOMMIT';
  142. STextSize = 'TEXTSIZE';
  143. var
  144. DBErrorStr, DBMsgStr: string;
  145. DBErrorNo, DBMsgNo: integer;
  146. function DBErrHandler(dbproc: PDBPROCESS; severity, dberr, oserr:INT; dberrstr, oserrstr:PChar):INT; cdecl;
  147. begin
  148. DBErrorStr:=DBErrorStr+#13+dberrstr;
  149. DBErrorNo :=dberr;
  150. Result :=INT_CANCEL;
  151. end;
  152. function DBMsgHandler(dbproc: PDBPROCESS; msgno: DBINT; msgstate, severity:INT; msgtext, srvname, procname:PChar; line:DBUSMALLINT):INT; cdecl;
  153. begin
  154. DBMsgStr:=DBMsgStr+#13+msgtext;
  155. DBMsgNo :=msgno;
  156. Result :=0;
  157. end;
  158. function CheckError(const Ret: RETCODE): RETCODE;
  159. var E: EMSSQLDatabaseError;
  160. begin
  161. if Ret=FAIL then
  162. begin
  163. E:=EMSSQLDatabaseError.Create(DBErrorStr+#13+DBMsgStr);
  164. E.DBErrorCode:=DBErrorNo;
  165. DBErrorStr:='';
  166. DBMsgStr:='';
  167. raise E;
  168. end;
  169. Result:=Ret;
  170. end;
  171. { TDBLibCursor }
  172. function TDBLibCursor.ReplaceParams(AParams: TParams; ASQLConnection: TMSSQLConnection): string;
  173. var i:integer;
  174. ParamNames, ParamValues: array of string;
  175. begin
  176. if Assigned(AParams) and (AParams.Count > 0) then //taken from mysqlconn, pqconnection
  177. begin
  178. setlength(ParamNames, AParams.Count);
  179. setlength(ParamValues, AParams.Count);
  180. for i := 0 to AParams.Count -1 do
  181. begin
  182. ParamNames[AParams.Count-i-1] := format('%s%d', [FParamReplaceString, AParams[i].Index+1]);
  183. ParamValues[AParams.Count-i-1] := ASQLConnection.GetAsSQLText(AParams[i]);
  184. //showmessage(ParamNames[AParams.Count-i-1] + '=' + ParamValues[AParams.Count-i-1]);
  185. end;
  186. Result := stringsreplace(FQuery, ParamNames, ParamValues, [rfReplaceAll]);
  187. end
  188. else
  189. Result := FQuery;
  190. end;
  191. { TSybaseConnection }
  192. constructor TSybaseConnection.Create(AOwner: TComponent);
  193. begin
  194. inherited Create(AOwner);
  195. Ftds := DBTDS_50;
  196. end;
  197. { TMSSQLConnection }
  198. function TMSSQLConnection.IsSybase: boolean;
  199. begin
  200. Result := (Ftds=DBTDS_50) or (Ftds=DBTDS_42);
  201. end;
  202. constructor TMSSQLConnection.Create(AOwner: TComponent);
  203. begin
  204. inherited Create(AOwner);
  205. FConnOptions := FConnOptions + [sqEscapeRepeat];
  206. //FieldNameQuoteChars:=DoubleQuotes; //default
  207. Ftds := DBTDS_UNKNOWN;
  208. end;
  209. function TMSSQLConnection.GetHandle: pointer;
  210. begin
  211. Result:=FDBProc;
  212. end;
  213. function TMSSQLConnection.GetAsSQLText(Param: TParam): string;
  214. function IsBinary(const s: string): boolean;
  215. var i: integer;
  216. begin
  217. for i:=1 to length(s) do if s[i] < #9 then Exit(true);
  218. Exit(false);
  219. end;
  220. function StrToHex(const s: string): string;
  221. begin
  222. setlength(Result, 2*length(s));
  223. BinToHex(PChar(s), PChar(Result), length(s));
  224. end;
  225. begin
  226. if not Param.IsNull then
  227. case Param.DataType of
  228. ftBoolean:
  229. if Param.AsBoolean then
  230. Result:='1'
  231. else
  232. Result:='0';
  233. ftString, ftFixedChar, ftMemo:
  234. //if IsBinary(Param.AsString) then
  235. // Result := '0x' + StrToHex(Param.AsString)
  236. //else
  237. begin
  238. Result := QuotedStr(Param.AsString);
  239. if (Ftds >= DBTDS_70) then
  240. Result := 'N' + Result
  241. else if (Ftds = 0) and (ClientCharset = ccUTF8) then //hack: Microsoft DB-Lib used
  242. Result := UTF8Decode(Result);
  243. end;
  244. ftBlob, ftBytes, ftVarBytes:
  245. Result := '0x' + StrToHex(Param.AsString);
  246. else
  247. Result := inherited GetAsSQLText(Param);
  248. end
  249. else
  250. Result:=inherited GetAsSQLText(Param);
  251. end;
  252. procedure TMSSQLConnection.DoInternalConnect;
  253. const
  254. DBVERSION: array[boolean] of BYTE = (DBVER60, DBVERSION_100);
  255. IMPLICIT_TRANSACTIONS_OFF: array[boolean] of shortstring = ('SET IMPLICIT_TRANSACTIONS OFF', 'SET CHAINED OFF');
  256. ANSI_DEFAULTS_ON: array[boolean] of shortstring = ('SET ANSI_DEFAULTS ON', 'SET QUOTED_IDENTIFIER ON');
  257. CURSOR_CLOSE_ON_COMMIT_OFF: array[boolean] of shortstring = ('SET CURSOR_CLOSE_ON_COMMIT OFF', 'SET CLOSE ON ENDTRAN OFF');
  258. begin
  259. inherited DoInternalConnect;
  260. InitialiseDBLib(DBLibLibraryName);
  261. if not DBLibInit then
  262. begin
  263. dbinit();
  264. dberrhandle(@DBErrHandler);
  265. dbmsghandle(@DBMsgHandler);
  266. DBLibInit:=true;
  267. end;
  268. FDBLogin:=dblogin();
  269. if FDBLogin=nil then DatabaseError('dblogin() failed!');
  270. // DBVERSION_100 is ATM not implemented by FreeTDS 0.91;
  271. // set environment variable TDSVER to 5.0: Windows: SET TDSVER=5.0, Unix/Linux: TDSVER=5.0
  272. // or in freetds.conf: include "tds version=5.0"
  273. dbsetlversion(FDBLogin, DBVERSION[IsSybase]);
  274. if UserName = '' then
  275. dbsetlsecure(FDBLogin)
  276. else
  277. begin
  278. dbsetlname(FDBLogin, PChar(UserName), DBSETUSER);
  279. dbsetlname(FDBLogin, PChar(Password), DBSETPWD);
  280. end;
  281. if CharSet = '' then
  282. dbsetlcharset(FDBLogin, 'UTF-8')
  283. else
  284. dbsetlcharset(FDBLogin, PChar(CharSet));
  285. //dbsetlname(FDBLogin, PChar(TIMEOUT_IGNORE), DBSET_LOGINTIME);
  286. dbsetlogintime(10);
  287. FDBProc := dbopen(FDBLogin, PChar(HostName));
  288. if FDBProc=nil then CheckError(FAIL);
  289. Ftds := dbtds(FDBProc);
  290. //CheckError( dbsetopt(FDBProc, DBQUOTEDIDENT, '') ); //in FreeTDS executes: "SET QUOTED_IDENTIFIER ON"
  291. //CheckError( dbsetopt(FDBProc, DBTEXTSIZE, '2147483647') ); //in FreeTDS: unimplemented, returns FAIL
  292. //CheckError( dbsetopt(FDBProc, DBTEXTLIMIT, '2147483647') ); //in FreeTDS: unimplemented, returns FAIL, but required by ntwdblib.dll
  293. //CheckError( dbsqlexec(FDBProc) ); //after setting DBTEXTSIZE option
  294. //CheckError (dbresults(FDBProc));
  295. //while dbresults(FDBProc) = SUCCEED do ;
  296. // Also SQL Server ODBC driver and Microsoft OLE DB Provider for SQL Server set ANSI_DEFAULTS to ON when connecting
  297. //DBExecute(ANSI_DEFAULTS_ON[IsSybase]);
  298. DBExecute('SET QUOTED_IDENTIFIER ON');
  299. if Params.IndexOfName(STextSize) <> -1 then
  300. DBExecute('SET TEXTSIZE '+Params.Values[STextSize])
  301. else
  302. DBExecute('SET TEXTSIZE 16777216');
  303. if AutoCommit then DBExecute(IMPLICIT_TRANSACTIONS_OFF[IsSybase]); //set connection to autocommit mode - default
  304. CheckError( dbuse(FDBProc, PChar(DatabaseName)) );
  305. end;
  306. procedure TMSSQLConnection.DoInternalDisconnect;
  307. begin
  308. inherited DoInternalDisconnect;
  309. dbclose(FDBProc);
  310. dbfreelogin(FDBLogin);
  311. ReleaseDBLib;
  312. end;
  313. function TMSSQLConnection.AllocateCursorHandle: TSQLCursor;
  314. begin
  315. Result:=TDBLibCursor.Create;
  316. end;
  317. procedure TMSSQLConnection.DeAllocateCursorHandle(var cursor: TSQLCursor);
  318. begin
  319. FreeAndNil(cursor);
  320. end;
  321. function TMSSQLConnection.StrToStatementType(s: string): TStatementType;
  322. begin
  323. if s = 'EXEC' then
  324. Result:=stExecProcedure
  325. else
  326. Result:=inherited StrToStatementType(s);
  327. end;
  328. procedure TMSSQLConnection.PrepareStatement(cursor: TSQLCursor;
  329. ATransaction: TSQLTransaction; buf: string; AParams: TParams);
  330. var
  331. ParamBinding : TParamBinding;
  332. begin
  333. with cursor as TDBLibCursor do
  334. begin
  335. if assigned(AParams) and (AParams.Count > 0) then
  336. FQuery:=AParams.ParseSQL(buf, false, sqEscapeSlash in ConnOptions, sqEscapeRepeat in ConnOptions, psSimulated, ParamBinding, FParamReplaceString)
  337. else
  338. FQuery:=buf;
  339. end;
  340. end;
  341. procedure TMSSQLConnection.UnPrepareStatement(cursor: TSQLCursor);
  342. begin
  343. if assigned(FDBProc) and (Fstatus <> NO_MORE_ROWS) then
  344. dbcanquery(FDBProc);
  345. end;
  346. function TMSSQLConnection.AllocateTransactionHandle: TSQLHandle;
  347. begin
  348. Result:=nil;
  349. end;
  350. function TMSSQLConnection.GetTransactionHandle(trans: TSQLHandle): pointer;
  351. begin
  352. Result:=nil;
  353. end;
  354. function TMSSQLConnection.StartDBTransaction(trans: TSQLHandle; AParams: string): boolean;
  355. begin
  356. Result := not AutoCommit;
  357. if Result then
  358. DBExecute(SBeginTransaction);
  359. end;
  360. function TMSSQLConnection.Commit(trans: TSQLHandle): boolean;
  361. begin
  362. DBExecute('COMMIT');
  363. Result:=true;
  364. end;
  365. function TMSSQLConnection.Rollback(trans: TSQLHandle): boolean;
  366. begin
  367. DBExecute('ROLLBACK');
  368. Result:=true;
  369. end;
  370. procedure TMSSQLConnection.CommitRetaining(trans: TSQLHandle);
  371. begin
  372. if Commit(trans) then
  373. DBExecute(SBeginTransaction);
  374. end;
  375. procedure TMSSQLConnection.RollbackRetaining(trans: TSQLHandle);
  376. begin
  377. if Rollback(trans) then
  378. DBExecute(SBeginTransaction);
  379. end;
  380. function TMSSQLConnection.AutoCommit: boolean;
  381. begin
  382. Result := StrToBoolDef(Params.Values[SAutoCommit], False);
  383. end;
  384. procedure TMSSQLConnection.DBExecute(const cmd: string);
  385. begin
  386. DBErrorStr:='';
  387. DBMsgStr :='';
  388. CheckError( dbcmd(FDBProc, PChar(cmd)) );
  389. CheckError( dbsqlexec(FDBProc) );
  390. CheckError( dbresults(FDBProc) );
  391. end;
  392. function TMSSQLConnection.ClientCharset: TClientCharset;
  393. begin
  394. {$IF (FPC_VERSION>=2) AND (FPC_RELEASE>4)}
  395. case CharSet of
  396. '' : Result := ccNone;
  397. 'UTF-8' : Result := ccUTF8;
  398. 'ISO-8859-1' : Result := ccISO88591;
  399. else Result := ccUnknown;
  400. end;
  401. {$ELSE}
  402. if CharSet = '' then
  403. Result := ccNone
  404. else if CharSet = 'UTF-8' then
  405. Result := ccUTF8
  406. else if CharSet = 'ISO-8859-1' then
  407. Result := ccISO88591
  408. else
  409. Result := ccUnknown;
  410. {$ENDIF}
  411. end;
  412. procedure TMSSQLConnection.Execute(cursor: TSQLCursor; ATransaction: TSQLTransaction; AParams: TParams);
  413. var c: TDBLibCursor;
  414. cmd: string;
  415. res: RETCODE;
  416. begin
  417. c:=cursor as TDBLibCursor;
  418. cmd := c.ReplaceParams(AParams, Self);
  419. DBExecute(cmd);
  420. res := SUCCEED;
  421. repeat
  422. c.FCanOpen := dbcmdrow(FDBProc)=SUCCEED;
  423. c.FRowsAffected := dbcount(FDBProc);
  424. if assigned(dbiscount) and not dbiscount(FDBProc) then
  425. c.FRowsAffected := -1;
  426. if not c.FCanOpen then //Sybase stored proc.
  427. begin
  428. repeat until dbnextrow(FDBProc) = NO_MORE_ROWS;
  429. res := CheckError( dbresults(FDBProc) );
  430. end;
  431. until (res = NO_MORE_RESULTS) or c.FCanOpen;
  432. if res = NO_MORE_RESULTS then
  433. Fstatus := NO_MORE_ROWS
  434. else
  435. Fstatus := MORE_ROWS;
  436. end;
  437. function TMSSQLConnection.RowsAffected(cursor: TSQLCursor): TRowsCount;
  438. begin
  439. if assigned(cursor) then
  440. Result := (cursor as TDBLibCursor).FRowsAffected
  441. else
  442. Result := inherited RowsAffected(cursor);
  443. end;
  444. function TMSSQLConnection.TranslateFldType(SQLDataType: integer): TFieldType;
  445. begin
  446. case SQLDataType of
  447. SQLCHAR: Result:=ftFixedChar;
  448. SQLVARCHAR: Result:=ftString;
  449. SQLINT1, SQLINT2: Result:=ftSmallInt;
  450. SQLINT4, SQLINTN: Result:=ftInteger;
  451. SYBINT8: Result:=ftLargeInt;
  452. SQLFLT4, SQLFLT8,
  453. SQLFLTN: Result:=ftFloat;
  454. SQLMONEY4, SQLMONEY,
  455. SQLMONEYN: Result:=ftCurrency;
  456. SQLDATETIM4, SQLDATETIME,
  457. SQLDATETIMN: Result:=ftDateTime;
  458. SQLIMAGE: Result:=ftBlob;
  459. SQLTEXT: Result:=ftMemo;
  460. SQLDECIMAL, SQLNUMERIC: Result:=ftBCD;
  461. SQLBIT: Result:=ftBoolean;
  462. SQLBINARY: Result:=ftBytes;
  463. SQLVARBINARY: Result:=ftVarBytes;
  464. SYBUNIQUE: Result:=ftGuid;
  465. else
  466. DatabaseErrorFmt('Unsupported SQL DataType %d "%s"', [SQLDataType, dbprtype(SQLDataType)]);
  467. Result:=ftUnknown;
  468. end;
  469. end;
  470. procedure TMSSQLConnection.AddFieldDefs(cursor: TSQLCursor; FieldDefs: TFieldDefs);
  471. var i, FieldSize: integer;
  472. FieldName: string;
  473. FieldType: TFieldType;
  474. col: DBCOL;
  475. begin
  476. col.SizeOfStruct:=sizeof(col);
  477. for i:=1 to dbnumcols(FDBProc) do
  478. begin
  479. if dbtablecolinfo(FDBProc, i, @col) = FAIL then continue;
  480. FieldName := col.Name;
  481. FieldType := TranslateFldType(col.Typ);
  482. case FieldType of
  483. ftString, ftFixedChar:
  484. begin
  485. FieldSize := col.MaxLength;
  486. if FieldSize > dsMaxStringSize then FieldSize := dsMaxStringSize;
  487. end;
  488. ftMemo, ftBlob,
  489. ftBytes, ftVarBytes:
  490. FieldSize := col.MaxLength;
  491. ftBCD:
  492. begin
  493. FieldSize := col.Scale;
  494. if (FieldSize > MaxBCDScale) or (col.Precision-col.Scale > MaxBCDPrecision-MaxBCDScale) then
  495. FieldType := ftFmtBCD;
  496. end;
  497. ftGuid:
  498. FieldSize := 38;
  499. else
  500. FieldSize := 0;
  501. if col.Identity and (FieldType = ftInteger) then
  502. FieldType := ftAutoInc;
  503. end;
  504. { // dbcolinfo(), dbcoltype() maps VARCHAR->CHAR, VARBINARY->BINARY:
  505. if col.VarLength {true also when column is nullable} then
  506. case FieldType of
  507. ftFixedChar: FieldType := ftString;
  508. ftBytes : FieldType := ftVarBytes;
  509. end;
  510. }
  511. with TFieldDef.Create(FieldDefs, FieldDefs.MakeNameUnique(FieldName), FieldType, FieldSize, (col.Null=0) and (not col.Identity), i) do
  512. begin
  513. //if col.Updatable = 0 then Attributes := Attributes + [faReadonly];
  514. case FieldType of
  515. ftBCD,
  516. ftFmtBCD: Precision := col.Precision;
  517. end;
  518. end;
  519. end;
  520. end;
  521. function TMSSQLConnection.Fetch(cursor: TSQLCursor): boolean;
  522. begin
  523. //Compute rows resulting from the COMPUTE clause are not processed
  524. repeat
  525. Fstatus := dbnextrow(FDBProc);
  526. Result := Fstatus=REG_ROW;
  527. until Result or (Fstatus = NO_MORE_ROWS);
  528. if Fstatus = NO_MORE_ROWS then
  529. while dbresults(FDBProc) <> NO_MORE_RESULTS do //process remaining results if there are any
  530. repeat until dbnextrow(FDBProc) = NO_MORE_ROWS;
  531. end;
  532. function TMSSQLConnection.LoadField(cursor: TSQLCursor; FieldDef: TFieldDef;
  533. buffer: pointer; out CreateBlob: boolean): boolean;
  534. var i: integer;
  535. data, dest: PByte;
  536. datalen, destlen: DBINT;
  537. srctype, desttype: INT;
  538. dbdt: DBDATETIME;
  539. dbdr: DBDATEREC;
  540. bcdstr: array[0..MaxFmtBCDFractionSize+2] of char;
  541. f: double;
  542. begin
  543. CreateBlob:=false;
  544. i:=FieldDef.FieldNo;
  545. srctype:=dbcoltype(FDBProc,i);
  546. data:=dbdata(FDBProc,i);
  547. datalen:=dbdatlen(FDBProc,i);
  548. Result:=assigned(data) and (datalen<>0);
  549. if not Result then
  550. Exit;
  551. dest:=buffer;
  552. destlen:=FieldDef.Size;
  553. case FieldDef.DataType of
  554. ftString, ftFixedChar:
  555. desttype:=SQLCHAR;
  556. ftBytes:
  557. desttype:=SQLBINARY;
  558. ftVarBytes:
  559. begin
  560. PWord(dest)^:=datalen;
  561. inc(dest, sizeof(Word));
  562. desttype:=SQLBINARY;
  563. end;
  564. ftSmallInt:
  565. begin
  566. desttype:=SQLINT2;
  567. destlen:=sizeof(DBSMALLINT); //smallint
  568. end;
  569. ftAutoInc,
  570. ftInteger:
  571. begin
  572. desttype:=SQLINT4;
  573. destlen:=sizeof(DBINT); //integer
  574. end;
  575. ftLargeInt:
  576. begin
  577. desttype:=SYBINT8;
  578. destlen:=sizeof(int64);
  579. end;
  580. ftCurrency,
  581. ftFloat:
  582. begin
  583. desttype:=SQLFLT8;
  584. destlen:=sizeof(DBFLT8); //double
  585. end;
  586. ftDateTime:
  587. begin
  588. dest:=@dbdt;
  589. desttype:=SQLDATETIME;
  590. destlen:=sizeof(dbdt);
  591. end;
  592. ftBCD:
  593. begin
  594. dest:=@f;
  595. desttype:=SQLFLT8;
  596. destlen:=sizeof(DBFLT8); //double
  597. end;
  598. ftFmtBCD:
  599. begin
  600. {
  601. dbnum.precision:=FieldDef.Precision;
  602. dbnum.scale :=FieldDef.Size;
  603. dest:=@dbnum;
  604. desttype:=SQLNUMERIC;
  605. destlen:=sizeof(dbnum);
  606. }
  607. dest:=@bcdstr[0];
  608. desttype:=SQLCHAR;
  609. destlen:=sizeof(bcdstr);
  610. fillchar(bcdstr, destlen, 0); //required when used ntwdblib.dll
  611. end;
  612. ftBoolean:
  613. begin
  614. desttype:=SQLBIT;
  615. destlen:=sizeof(WordBool);
  616. end;
  617. ftGuid:
  618. begin
  619. desttype:=SQLCHAR;
  620. end;
  621. ftMemo,
  622. ftBlob:
  623. begin
  624. CreateBlob:=true;
  625. Exit;
  626. end
  627. else
  628. //DatabaseErrorFmt('Tried to load field of unsupported field type %s',[FieldTypeNames[FieldDef.DataType]]);
  629. Result:=false;
  630. end;
  631. dbconvert(FDBProc, srctype, data , datalen, desttype, dest, destlen);
  632. case FieldDef.DataType of
  633. ftString, ftFixedChar:
  634. begin
  635. PChar(dest + datalen)^ := #0; //strings must be null-terminated
  636. if ((Ftds = 0) and (ClientCharset = ccUTF8)) {hack: MS DB-Lib used} or
  637. (ClientCharset = ccISO88591) {hack: FreeTDS} then
  638. StrPLCopy(PChar(dest), UTF8Encode(PChar(dest)), destlen);
  639. end;
  640. ftDateTime:
  641. begin
  642. //detect DBDATEREC version by pre-setting dbdr
  643. dbdr.millisecond := -1;
  644. if dbdatecrack(FDBProc, @dbdr, @dbdt) = SUCCEED then
  645. begin
  646. if dbdr.millisecond = -1 then
  647. PDateTime(buffer)^ := composedatetime(
  648. encodedate(dbdr.oldyear, dbdr.oldmonth, dbdr.oldday),
  649. encodetime(dbdr.oldhour, dbdr.oldminute, dbdr.oldsecond, dbdr.oldmillisecond))
  650. else
  651. PDateTime(buffer)^ := composedatetime(
  652. encodedate(dbdr.year, dbdr.month, dbdr.day),
  653. encodetime(dbdr.hour, dbdr.minute, dbdr.second, dbdr.millisecond));
  654. end;
  655. end;
  656. ftBCD:
  657. PCurrency(buffer)^:=FloatToCurr(f);
  658. ftFmtBCD:
  659. PBCD(buffer)^:=StrToBCD(bcdstr, FSQLFormatSettings); //PBCD(buffer)^:=dbnumerictobcd(dbnum);
  660. end;
  661. end;
  662. procedure TMSSQLConnection.LoadBlobIntoBuffer(FieldDef: TFieldDef;
  663. ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction: TSQLTransaction);
  664. var data: PByte;
  665. datalen: DBINT;
  666. srctype: INT;
  667. begin
  668. //see also LoadField
  669. srctype:=dbcoltype(FDBProc, FieldDef.FieldNo);
  670. data:=dbdata(FDBProc, FieldDef.FieldNo);
  671. datalen:=dbdatlen(FDBProc, FieldDef.FieldNo);
  672. ReAllocMem(ABlobBuf^.BlobBuffer^.Buffer, datalen);
  673. ABlobBuf^.BlobBuffer^.Size :=
  674. dbconvert(FDBProc, srctype, data , datalen, srctype, ABlobBuf^.BlobBuffer^.Buffer, datalen);
  675. end;
  676. procedure TMSSQLConnection.FreeFldBuffers(cursor: TSQLCursor);
  677. begin
  678. inherited FreeFldBuffers(cursor);
  679. end;
  680. procedure TMSSQLConnection.UpdateIndexDefs(IndexDefs: TIndexDefs; TableName: string);
  681. const INDEXES_QUERY: array[boolean] of string=(
  682. //MS SQL Server; TODO: we can use "execute dbo.sp_helpindex 'TableName'" when Open on Execute will fully work
  683. 'select i.name, i.indid, c.name as col_name,'+
  684. 'indexproperty(i.id, i.name, ''IsUnique''),'+
  685. 'objectproperty(o.id, ''IsPrimaryKey'') '+
  686. 'from sysindexes i '+
  687. ' join sysindexkeys k on i.id=k.id and i.indid=k.indid '+
  688. ' join syscolumns c on k.id=c.id and k.colid=c.colid '+
  689. ' left join sysobjects o on i.name=o.name and i.id=o.parent_obj '+
  690. 'where i.id=object_id(''%s'') '+
  691. 'order by k.indid, k.keyno'
  692. ,
  693. //Sybase; http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.infocenter.help.ase.15.7/title.htm
  694. 'select i.name, i.indid,' +
  695. 'index_col(object_name(i.id),i.indid,c.colid) as col_name,' +
  696. '(i.status & 2)/2 as IsUnique,' +
  697. '(i.status & 2048)/2048 as IsPrimaryKey ' +
  698. 'from sysindexes i '+
  699. ' join syscolumns c on c.id=i.id and c.colid<=i.keycnt-case i.indid when 1 then 0 else 1 end ' +
  700. 'where i.id=object_id(''%s'') '+
  701. ' and i.indid between 1 and 254 '+ // indid 0 is the table name, 255 is TEXT,IMAGE
  702. 'order by i.indid, c.colid'
  703. );
  704. var qry : TSQLQuery;
  705. begin
  706. //if not assigned(Transaction) then
  707. // DatabaseError(SErrConnTransactionnSet);
  708. qry := TSQLQuery.Create(nil);
  709. qry.Transaction := Transaction;
  710. qry.Database := Self;
  711. with qry do
  712. begin
  713. ReadOnly := True;
  714. SQL.Text := format(INDEXES_QUERY[IsSybase], [TableName]);
  715. Open;
  716. end;
  717. while not qry.Eof do with IndexDefs.AddIndexDef do
  718. begin
  719. Name := trim(qry.Fields[0].AsString);
  720. Fields := trim(qry.Fields[2].AsString);
  721. if qry.Fields[3].AsInteger=1 then Options := Options + [ixUnique];
  722. if qry.Fields[4].AsInteger=1 then Options := Options + [ixPrimary];
  723. qry.Next;
  724. while (Name = trim(qry.Fields[0].AsString)) and (not qry.Eof) do
  725. begin
  726. Fields := Fields + ';' + trim(qry.Fields[2].AsString);
  727. qry.Next;
  728. end;
  729. end;
  730. qry.Close;
  731. qry.Free;
  732. end;
  733. function TMSSQLConnection.GetSchemaInfoSQL(SchemaType: TSchemaType; SchemaObjectName, SchemaObjectPattern: string): string;
  734. const SCHEMA_QUERY='select name as %s from sysobjects where type=''%s'' order by 1';
  735. begin
  736. case SchemaType of
  737. stTables : Result := format(SCHEMA_QUERY, ['table_name','U']);
  738. stSysTables : Result := format(SCHEMA_QUERY, ['table_name','S']);
  739. stProcedures : Result := format(SCHEMA_QUERY, ['proc_name','P']);
  740. stColumns : Result := 'select name as column_name from syscolumns where id=object_id(''' + SchemaObjectName + ''') order by colorder';
  741. else
  742. DatabaseError(SMetadataUnavailable)
  743. end;
  744. end;
  745. { TMSSQLConnectionDef }
  746. class function TMSSQLConnectionDef.TypeName: String;
  747. begin
  748. Result:='MSSQLServer';
  749. end;
  750. class function TMSSQLConnectionDef.ConnectionClass: TSQLConnectionClass;
  751. begin
  752. Result:=TMSSQLConnection;
  753. end;
  754. class function TMSSQLConnectionDef.Description: String;
  755. begin
  756. Result:='Connect to MS SQL Server via Microsoft client library or via FreeTDS db-lib';
  757. end;
  758. { TSybaseConnectionDef }
  759. class function TSybaseConnectionDef.TypeName: String;
  760. begin
  761. Result:='Sybase';
  762. end;
  763. class function TSybaseConnectionDef.ConnectionClass: TSQLConnectionClass;
  764. begin
  765. Result:=TSybaseConnection;
  766. end;
  767. class function TSybaseConnectionDef.Description: String;
  768. begin
  769. Result:='Connect to Sybase SQL Server via FreeTDS db-lib';;
  770. end;
  771. initialization
  772. RegisterConnection(TMSSQLConnectionDef);
  773. RegisterConnection(TSybaseConnectionDef);
  774. finalization
  775. UnRegisterConnection(TMSSQLConnectionDef);
  776. UnRegisterConnection(TSybaseConnectionDef);
  777. end.