sqlite3conn.pp 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872
  1. {
  2. This file is part of the Free Pascal Classes Library (FCL).
  3. Copyright (c) 2006 by the Free Pascal development team
  4. SQLite3 connection for SQLDB
  5. See the File COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. {
  12. Based on an implementation by Martin Schreiber, part of MSEIDE.
  13. Reworked all code so it conforms to FCL coding standards.
  14. }
  15. unit sqlite3conn;
  16. {$mode objfpc}
  17. {$h+}
  18. interface
  19. uses
  20. classes, db, bufdataset, sqldb, sqlite3dyn, types;
  21. const
  22. sqliteerrormax = 99;
  23. type
  24. PDateTime = ^TDateTime;
  25. TSqliteOption = (sloTransactions,sloDesignTransactions);
  26. TSqliteOptions = set of TSqliteOption;
  27. TStringArray = Array of string;
  28. PStringArray = ^TStringArray;
  29. TArrayStringArray = Array of TStringArray;
  30. PArrayStringArray = ^TArrayStringArray;
  31. { TSQLite3Connection }
  32. TSQLite3Connection = class(TSQLConnection)
  33. private
  34. fhandle: psqlite3;
  35. foptions: TSQLiteOptions;
  36. procedure setoptions(const avalue: tsqliteoptions);
  37. protected
  38. function stringsquery(const asql: string): TArrayStringArray;
  39. procedure checkerror(const aerror: integer);
  40. procedure DoInternalConnect; override;
  41. procedure DoInternalDisconnect; override;
  42. function GetHandle : pointer; override;
  43. Function AllocateCursorHandle : TSQLCursor; override;
  44. //aowner used as blob cache
  45. Procedure DeAllocateCursorHandle(var cursor : TSQLCursor); override;
  46. Function AllocateTransactionHandle : TSQLHandle; override;
  47. procedure PrepareStatement(cursor: TSQLCursor; ATransaction : TSQLTransaction;
  48. buf: string; AParams : TParams); override;
  49. procedure Execute(cursor: TSQLCursor;atransaction:tSQLtransaction; AParams : TParams); override;
  50. function Fetch(cursor : TSQLCursor) : boolean; override;
  51. procedure AddFieldDefs(cursor: TSQLCursor; FieldDefs : TfieldDefs); override;
  52. procedure UnPrepareStatement(cursor : TSQLCursor); override;
  53. procedure FreeFldBuffers(cursor : TSQLCursor); override;
  54. function LoadField(cursor : TSQLCursor;FieldDef : TfieldDef;buffer : pointer; out CreateBlob : boolean) : boolean; override;
  55. //if bufsize < 0 -> buffer was to small, should be -bufsize
  56. function GetTransactionHandle(trans : TSQLHandle): pointer; override;
  57. function Commit(trans : TSQLHandle) : boolean; override;
  58. function RollBack(trans : TSQLHandle) : boolean; override;
  59. function StartdbTransaction(trans : TSQLHandle; aParams : string) : boolean; override;
  60. procedure CommitRetaining(trans : TSQLHandle); override;
  61. procedure RollBackRetaining(trans : TSQLHandle); override;
  62. procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction : TSQLTransaction); override;
  63. // New methods
  64. procedure execsql(const asql: string);
  65. procedure UpdateIndexDefs(IndexDefs : TIndexDefs;TableName : string); override; // Differs from SQLDB.
  66. function RowsAffected(cursor: TSQLCursor): TRowsCount; override;
  67. function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; override;
  68. function StrToStatementType(s : string) : TStatementType; override;
  69. public
  70. constructor Create(AOwner : TComponent); override;
  71. function GetInsertID: int64;
  72. procedure GetFieldNames(const TableName : string; List : TStrings); override;
  73. published
  74. property Options: TSqliteOptions read FOptions write SetOptions;
  75. end;
  76. Var
  77. SQLiteLibraryName : String = sqlite3lib;
  78. implementation
  79. uses
  80. dbconst, sysutils, dateutils,FmtBCD;
  81. const
  82. JulianDateShift = 2415018.5; //distance from "julian day 0" (January 1, 4713 BC 12:00AM) to "1899-12-30 00:00AM"
  83. type
  84. TStorageType = (stNone,stInteger,stFloat,stText,stBlob,stNull);
  85. TSQLite3Cursor = class(tsqlcursor)
  86. private
  87. fhandle : psqlite3;
  88. fstatement: psqlite3_stmt;
  89. ftail: pchar;
  90. fstate: integer;
  91. fparambinding: array of Integer;
  92. procedure checkerror(const aerror: integer);
  93. procedure bindparams(AParams : TParams);
  94. Procedure Prepare(Buf : String; APArams : TParams);
  95. Procedure UnPrepare;
  96. Procedure Execute;
  97. Function Fetch : Boolean;
  98. public
  99. RowsAffected : Largeint;
  100. end;
  101. procedure freebindstring(astring: pointer); cdecl;
  102. begin
  103. StrDispose(AString);
  104. end;
  105. procedure TSQLite3Cursor.checkerror(const aerror: integer);
  106. Var
  107. S : String;
  108. begin
  109. if (aerror<>sqlite_ok) then
  110. begin
  111. S:=strpas(sqlite3_errmsg(fhandle));
  112. DatabaseError(S);
  113. end;
  114. end;
  115. Procedure TSQLite3Cursor.bindparams(AParams : TParams);
  116. Function PCharStr(Const S : String) : PChar;
  117. begin
  118. Result:=StrAlloc(Length(S)+1);
  119. If (Result<>Nil) then
  120. StrPCopy(Result,S);
  121. end;
  122. Var
  123. I : Integer;
  124. P : TParam;
  125. pc : pchar;
  126. str1: string;
  127. cu1: currency;
  128. do1: double;
  129. parms : array of Integer;
  130. wstr1: widestring;
  131. begin
  132. for I:=1 to high(fparambinding)+1 do
  133. begin
  134. P:=aparams[fparambinding[I-1]];
  135. if P.isnull then
  136. checkerror(sqlite3_bind_null(fstatement,I))
  137. else
  138. case P.datatype of
  139. ftinteger,
  140. ftboolean,
  141. ftsmallint: checkerror(sqlite3_bind_int(fstatement,I,p.asinteger));
  142. ftword: checkerror(sqlite3_bind_int(fstatement,I,P.asword));
  143. ftlargeint: checkerror(sqlite3_bind_int64(fstatement,I,P.aslargeint));
  144. ftbcd,
  145. ftfloat,
  146. ftcurrency:
  147. begin
  148. do1:= P.AsFloat;
  149. checkerror(sqlite3_bind_double(fstatement,I,do1));
  150. end;
  151. ftdatetime,
  152. ftdate,
  153. fttime: begin
  154. do1:= P.AsFloat + JulianDateShift;
  155. checkerror(sqlite3_bind_double(fstatement,I,do1));
  156. end;
  157. ftFMTBcd,
  158. ftstring,
  159. ftFixedChar,
  160. ftmemo: begin // According to SQLite documentation, CLOB's (ftMemo) have the Text affinity
  161. str1:= p.asstring;
  162. checkerror(sqlite3_bind_text(fstatement,I,pcharstr(str1), length(str1),@freebindstring));
  163. end;
  164. ftblob: begin
  165. str1:= P.asstring;
  166. checkerror(sqlite3_bind_blob(fstatement,I,pcharstr(str1), length(str1),@freebindstring));
  167. end;
  168. ftWideString, ftFixedWideChar, ftWideMemo:
  169. begin
  170. wstr1:=P.AsWideString;
  171. checkerror(sqlite3_bind_text16(fstatement,I, PWideChar(wstr1), length(wstr1)*sizeof(WideChar), sqlite3_destructor_type(SQLITE_TRANSIENT)));
  172. end
  173. else
  174. DatabaseErrorFmt(SUnsupportedParameter, [Fieldtypenames[P.DataType], Self]);
  175. end; { Case }
  176. end;
  177. end;
  178. Procedure TSQLite3Cursor.Prepare(Buf : String; APArams : TParams);
  179. begin
  180. if assigned(aparams) and (aparams.count > 0) then
  181. buf := aparams.parsesql(buf,false,false,false,psinterbase,fparambinding);
  182. checkerror(sqlite3_prepare(fhandle,pchar(buf),length(buf),@fstatement,@ftail));
  183. FPrepared:=True;
  184. end;
  185. Procedure TSQLite3Cursor.UnPrepare;
  186. begin
  187. sqlite3_finalize(fstatement); // No check.
  188. FPrepared:=False;
  189. end;
  190. Procedure TSQLite3Cursor.Execute;
  191. var
  192. wo1: word;
  193. begin
  194. {$ifdef i386}
  195. wo1:= get8087cw;
  196. set8087cw(wo1 or $1f); //mask exceptions, Sqlite3 has overflow
  197. Try // Why do people always forget this ??
  198. {$endif}
  199. fstate:= sqlite3_step(fstatement);
  200. {$ifdef i386}
  201. finally
  202. set8087cw(wo1); //restore
  203. end;
  204. {$endif}
  205. if (fstate<=sqliteerrormax) then
  206. checkerror(sqlite3_reset(fstatement));
  207. RowsAffected:=sqlite3_changes(fhandle);
  208. if (fstate=sqlite_row) then
  209. fstate:= sqliteerrormax; //first row
  210. end;
  211. Function TSQLite3Cursor.Fetch : Boolean;
  212. begin
  213. if (fstate=sqliteerrormax) then
  214. fstate:=sqlite_row //first row;
  215. else if (fstate=sqlite_row) then
  216. begin
  217. fstate:=sqlite3_step(fstatement);
  218. if (fstate<=sqliteerrormax) then
  219. checkerror(sqlite3_reset(fstatement)); //right error returned??
  220. end;
  221. result:=(fstate=sqlite_row);
  222. end;
  223. { TSQLite3Connection }
  224. procedure TSQLite3Connection.LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction : TSQLTransaction);
  225. var
  226. int1: integer;
  227. st: psqlite3_stmt;
  228. fnum: integer;
  229. p1: Pointer;
  230. begin
  231. st:=TSQLite3Cursor(cursor).fstatement;
  232. fnum:= FieldDef.fieldno - 1;
  233. case FieldDef.DataType of
  234. ftWideMemo:
  235. begin
  236. p1 := sqlite3_column_text16(st,fnum);
  237. int1 := sqlite3_column_bytes16(st,fnum);
  238. end;
  239. ftMemo:
  240. begin
  241. p1 := sqlite3_column_text(st,fnum);
  242. int1 := sqlite3_column_bytes(st,fnum);
  243. end;
  244. else //ftBlob
  245. begin
  246. p1 := sqlite3_column_blob(st,fnum);
  247. int1 := sqlite3_column_bytes(st,fnum);
  248. end;
  249. end;
  250. ReAllocMem(ABlobBuf^.BlobBuffer^.Buffer, int1);
  251. if int1 > 0 then
  252. move(p1^, ABlobBuf^.BlobBuffer^.Buffer^, int1);
  253. ABlobBuf^.BlobBuffer^.Size := int1;
  254. end;
  255. function TSQLite3Connection.AllocateTransactionHandle: TSQLHandle;
  256. begin
  257. result:= tsqlhandle.create;
  258. end;
  259. function TSQLite3Connection.AllocateCursorHandle: TSQLCursor;
  260. Var
  261. Res : TSQLite3Cursor;
  262. begin
  263. Res:= TSQLite3Cursor.create;
  264. Result:=Res;
  265. end;
  266. procedure TSQLite3Connection.DeAllocateCursorHandle(var cursor: TSQLCursor);
  267. begin
  268. freeandnil(cursor);
  269. end;
  270. procedure TSQLite3Connection.PrepareStatement(cursor: TSQLCursor;
  271. ATransaction: TSQLTransaction; buf: string; AParams: TParams);
  272. begin
  273. TSQLite3Cursor(cursor).fhandle:=self.fhandle;
  274. TSQLite3Cursor(cursor).Prepare(Buf,AParams);
  275. end;
  276. procedure TSQLite3Connection.UnPrepareStatement(cursor: TSQLCursor);
  277. begin
  278. TSQLite3Cursor(cursor).UnPrepare;
  279. TSQLite3Cursor(cursor).fhandle:=nil;
  280. end;
  281. Type
  282. TFieldMap = Record
  283. N : String;
  284. T : TFieldType;
  285. end;
  286. Const
  287. FieldMapCount = 24;
  288. FieldMap : Array [1..FieldMapCount] of TFieldMap = (
  289. (n:'INT'; t: ftInteger),
  290. (n:'LARGEINT'; t:ftlargeInt),
  291. (n:'BIGINT'; t:ftlargeInt),
  292. (n:'WORD'; t: ftWord),
  293. (n:'SMALLINT'; t: ftSmallint),
  294. (n:'BOOLEAN'; t: ftBoolean),
  295. (n:'REAL'; t: ftFloat),
  296. (n:'FLOAT'; t: ftFloat),
  297. (n:'DOUBLE'; t: ftFloat),
  298. (n:'TIMESTAMP'; t: ftDateTime),
  299. (n:'DATETIME'; t: ftDateTime), // MUST be before date
  300. (n:'DATE'; t: ftDate),
  301. (n:'TIME'; t: ftTime),
  302. (n:'CURRENCY'; t: ftCurrency),
  303. (n:'VARCHAR'; t: ftString),
  304. (n:'CHAR'; t: ftString),
  305. (n:'NUMERIC'; t: ftBCD),
  306. (n:'DECIMAL'; t: ftBCD),
  307. (n:'TEXT'; t: ftmemo),
  308. (n:'CLOB'; t: ftmemo),
  309. (n:'BLOB'; t: ftBlob),
  310. (n:'NCHAR'; t: ftFixedWideChar),
  311. (n:'NVARCHAR'; t: ftWideString),
  312. (n:'NCLOB'; t: ftWideMemo)
  313. { Template:
  314. (n:''; t: ft)
  315. }
  316. );
  317. procedure TSQLite3Connection.AddFieldDefs(cursor: TSQLCursor;
  318. FieldDefs: TfieldDefs);
  319. var
  320. i : integer;
  321. FN,FD : string;
  322. ft1 : tfieldtype;
  323. size1 : word;
  324. ar1 : TStringArray;
  325. fi : integer;
  326. st : psqlite3_stmt;
  327. begin
  328. st:=TSQLite3Cursor(cursor).fstatement;
  329. for i:= 0 to sqlite3_column_count(st) - 1 do
  330. begin
  331. FN:=sqlite3_column_name(st,i);
  332. FD:=uppercase(sqlite3_column_decltype(st,i));
  333. ft1:= ftUnknown;
  334. size1:= 0;
  335. for fi := 1 to FieldMapCount do if pos(FieldMap[fi].N,FD)=1 then
  336. begin
  337. ft1:=FieldMap[fi].t;
  338. break;
  339. end;
  340. // In case of an empty fieldtype (FD='', which is allowed and used in calculated
  341. // columns (aggregates) and by pragma-statements) or an unknown fieldtype,
  342. // use the field's affinity:
  343. if ft1=ftUnknown then
  344. case TStorageType(sqlite3_column_type(st,i)) of
  345. stInteger: ft1:=ftLargeInt;
  346. stFloat: ft1:=ftFloat;
  347. stBlob: ft1:=ftBlob;
  348. else ft1:=ftString;
  349. end;
  350. // handle some specials.
  351. size1:=0;
  352. case ft1 of
  353. ftString,
  354. ftFixedChar,
  355. ftFixedWideChar,
  356. ftWideString:
  357. begin
  358. fi:=pos('(',FD);
  359. if (fi>0) then
  360. begin
  361. System.Delete(FD,1,fi);
  362. fi:=pos(')',FD);
  363. size1:=StrToIntDef(trim(copy(FD,1,fi-1)),255);
  364. if size1 > dsMaxStringSize then size1 := dsMaxStringSize;
  365. end
  366. else size1 := 255;
  367. end;
  368. ftBCD: begin
  369. fi:=pos(',',FD);
  370. if (fi>0) then
  371. begin
  372. System.Delete(FD,1,fi);
  373. fi:=pos(')',FD);
  374. size1:=StrToIntDef(trim(copy(FD,1,fi-1)), 0);
  375. if size1>4 then
  376. ft1 := ftFMTBcd;
  377. end
  378. else size1 := 0;
  379. end;
  380. ftUnknown : DatabaseError('Unknown record type: '+FN);
  381. end; // Case
  382. tfielddef.create(fielddefs,FieldDefs.MakeNameUnique(FN),ft1,size1,false,i+1);
  383. end;
  384. end;
  385. procedure TSQLite3Connection.Execute(cursor: TSQLCursor; atransaction: tsqltransaction; AParams: TParams);
  386. var
  387. SC : TSQLite3Cursor;
  388. begin
  389. SC:=TSQLite3Cursor(cursor);
  390. checkerror(sqlite3_reset(sc.fstatement));
  391. If (AParams<>Nil) and (AParams.count > 0) then
  392. SC.BindParams(AParams);
  393. SC.Execute;
  394. end;
  395. Function NextWord(Var S : ShortString; Sep : Char) : String;
  396. Var
  397. P : Integer;
  398. begin
  399. P:=Pos(Sep,S);
  400. If (P=0) then
  401. P:=Length(S)+1;
  402. Result:=Copy(S,1,P-1);
  403. Delete(S,1,P);
  404. end;
  405. Function ParseSQLiteDate(S : ShortString) : TDateTime;
  406. Var
  407. Year, Month, Day : Integer;
  408. begin
  409. Result:=0;
  410. If TryStrToInt(NextWord(S,'-'),Year) then
  411. if TryStrToInt(NextWord(S,'-'),Month) then
  412. if TryStrToInt(NextWord(S,'-'),Day) then
  413. Result:=EncodeDate(Year,Month,Day);
  414. end;
  415. Function ParseSQLiteTime(S : ShortString; Interval: boolean) : TDateTime;
  416. Var
  417. Hour, Min, Sec, MSec : Integer;
  418. begin
  419. Result:=0;
  420. If TryStrToInt(NextWord(S,':'),Hour) then
  421. if TryStrToInt(NextWord(S,':'),Min) then
  422. if TryStrToInt(NextWord(S,'.'),Sec) then
  423. begin
  424. MSec:=StrToIntDef(S,0);
  425. if Interval then
  426. Result:=EncodeTimeInterval(Hour,Min,Sec,MSec)
  427. else
  428. Result:=EncodeTime(Hour,Min,Sec,MSec);
  429. end;
  430. end;
  431. Function ParseSQLiteDateTime(S : String) : TDateTime;
  432. var
  433. P : Integer;
  434. DS,TS : ShortString;
  435. begin
  436. DS:='';
  437. TS:='';
  438. P:=Pos(' ',S);
  439. If (P<>0) then
  440. begin
  441. DS:=Copy(S,1,P-1);
  442. TS:=S;
  443. Delete(TS,1,P);
  444. end
  445. else
  446. begin
  447. If (Pos('-',S)<>0) then
  448. DS:=S
  449. else if (Pos(':',S)<>0) then
  450. TS:=S;
  451. end;
  452. Result:=ComposeDateTime(ParseSQLiteDate(DS),ParseSQLiteTime(TS,False));
  453. end;
  454. function TSQLite3Connection.LoadField(cursor : TSQLCursor;FieldDef : TfieldDef;buffer : pointer; out CreateBlob : boolean) : boolean;
  455. var
  456. st1: TStorageType;
  457. fnum: integer;
  458. str1: string;
  459. int1 : integer;
  460. bcd: tBCD;
  461. bcdstr: FmtBCDStringtype;
  462. st : psqlite3_stmt;
  463. begin
  464. st:=TSQLite3Cursor(cursor).fstatement;
  465. fnum:= FieldDef.fieldno - 1;
  466. st1:= TStorageType(sqlite3_column_type(st,fnum));
  467. CreateBlob:=false;
  468. result:= st1 <> stnull;
  469. if Not result then
  470. Exit;
  471. case FieldDef.datatype of
  472. ftInteger : pinteger(buffer)^ := sqlite3_column_int(st,fnum);
  473. ftSmallInt : psmallint(buffer)^ := sqlite3_column_int(st,fnum);
  474. ftWord : pword(buffer)^ := sqlite3_column_int(st,fnum);
  475. ftBoolean : pwordbool(buffer)^ := sqlite3_column_int(st,fnum)<>0;
  476. ftLargeInt : PInt64(buffer)^:= sqlite3_column_int64(st,fnum);
  477. ftBCD : PCurrency(buffer)^:= FloattoCurr(sqlite3_column_double(st,fnum));
  478. ftFloat,
  479. ftCurrency : pdouble(buffer)^:= sqlite3_column_double(st,fnum);
  480. ftDateTime,
  481. ftDate,
  482. ftTime: if st1 = sttext then
  483. begin
  484. setlength(str1,sqlite3_column_bytes(st,fnum));
  485. move(sqlite3_column_text(st,fnum)^,str1[1],length(str1));
  486. case FieldDef.datatype of
  487. ftDateTime: PDateTime(Buffer)^:=ParseSqliteDateTime(str1);
  488. ftDate : PDateTime(Buffer)^:=ParseSqliteDate(str1);
  489. ftTime : PDateTime(Buffer)^:=ParseSQLiteTime(str1,true);
  490. end; {case}
  491. end
  492. else
  493. begin
  494. PDateTime(buffer)^ := sqlite3_column_double(st,fnum);
  495. if PDateTime(buffer)^ > 1721059.5 {Julian 01/01/0000} then
  496. PDateTime(buffer)^ := PDateTime(buffer)^ - JulianDateShift; //backward compatibility hack
  497. end;
  498. ftFixedChar,
  499. ftString: begin
  500. int1:= sqlite3_column_bytes(st,fnum);
  501. if int1>FieldDef.Size then
  502. int1:=FieldDef.Size;
  503. if int1 > 0 then
  504. move(sqlite3_column_text(st,fnum)^,buffer^,int1);
  505. end;
  506. ftFmtBCD: begin
  507. int1:= sqlite3_column_bytes(st,fnum);
  508. if (int1 > 0) and (int1 <= MAXFMTBcdFractionSize) then
  509. begin
  510. SetLength(bcdstr,int1);
  511. move(sqlite3_column_text(st,fnum)^,bcdstr[1],int1);
  512. // sqlite always uses the point as decimal-point
  513. if not TryStrToBCD(bcdstr,bcd,FSQLFormatSettings) then
  514. // sqlite does the same, if the value can't be interpreted as a
  515. // number in sqlite3_column_int, return 0
  516. bcd := 0;
  517. end
  518. else
  519. bcd := 0;
  520. pBCD(buffer)^:= bcd;
  521. end;
  522. ftFixedWideChar,
  523. ftWideString:
  524. begin
  525. int1 := sqlite3_column_bytes16(st,fnum)+2; //The value returned does not include the zero terminator at the end of the string
  526. if int1>(FieldDef.Size+1)*2 then
  527. int1:=(FieldDef.Size+1)*2;
  528. if int1 > 0 then
  529. move(sqlite3_column_text16(st,fnum)^, buffer^, int1); //Strings returned by sqlite3_column_text() and sqlite3_column_text16(), even empty strings, are always zero terminated.
  530. end;
  531. ftWideMemo,
  532. ftMemo,
  533. ftBlob: CreateBlob:=True;
  534. else { Case }
  535. result:= false; // unknown
  536. end; { Case }
  537. end;
  538. function TSQLite3Connection.Fetch(cursor: TSQLCursor): boolean;
  539. begin
  540. Result:=TSQLite3Cursor(cursor).Fetch;
  541. end;
  542. procedure TSQLite3Connection.FreeFldBuffers(cursor: TSQLCursor);
  543. begin
  544. //dummy
  545. end;
  546. function TSQLite3Connection.GetTransactionHandle(trans: TSQLHandle): pointer;
  547. begin
  548. result:= nil;
  549. end;
  550. function TSQLite3Connection.Commit(trans: TSQLHandle): boolean;
  551. begin
  552. execsql('COMMIT');
  553. result:= true;
  554. end;
  555. function TSQLite3Connection.RollBack(trans: TSQLHandle): boolean;
  556. begin
  557. execsql('ROLLBACK');
  558. result:= true;
  559. end;
  560. function TSQLite3Connection.StartdbTransaction(trans: TSQLHandle;
  561. aParams: string): boolean;
  562. begin
  563. execsql('BEGIN');
  564. result:= true;
  565. end;
  566. procedure TSQLite3Connection.CommitRetaining(trans: TSQLHandle);
  567. begin
  568. commit(trans);
  569. execsql('BEGIN');
  570. end;
  571. procedure TSQLite3Connection.RollBackRetaining(trans: TSQLHandle);
  572. begin
  573. rollback(trans);
  574. execsql('BEGIN');
  575. end;
  576. procedure TSQLite3Connection.DoInternalConnect;
  577. var
  578. str1: string;
  579. begin
  580. if Length(databasename)=0 then
  581. DatabaseError(SErrNoDatabaseName,self);
  582. InitializeSqlite(SQLiteLibraryName);
  583. str1:= databasename;
  584. checkerror(sqlite3_open(pchar(str1),@fhandle));
  585. end;
  586. procedure TSQLite3Connection.DoInternalDisconnect;
  587. begin
  588. if fhandle <> nil then
  589. begin
  590. checkerror(sqlite3_close(fhandle));
  591. fhandle:= nil;
  592. releasesqlite;
  593. end;
  594. end;
  595. function TSQLite3Connection.GetHandle: pointer;
  596. begin
  597. result:= fhandle;
  598. end;
  599. procedure TSQLite3Connection.checkerror(const aerror: integer);
  600. Var
  601. S : String;
  602. begin
  603. if (aerror<>sqlite_ok) then
  604. begin
  605. S:=strpas(sqlite3_errmsg(fhandle));
  606. DatabaseError(S,Self);
  607. end;
  608. end;
  609. procedure TSQLite3Connection.execsql(const asql: string);
  610. var
  611. err : pchar;
  612. str1 : string;
  613. res : integer;
  614. begin
  615. err:= nil;
  616. Res := sqlite3_exec(fhandle,pchar(asql),nil,nil,@err);
  617. if err <> nil then
  618. begin
  619. str1:= strpas(err);
  620. sqlite3_free(err);
  621. end;
  622. if (res<>sqlite_ok) then
  623. databaseerror(str1);
  624. end;
  625. function execcallback(adata: pointer; ncols: longint; //adata = PStringArray
  626. avalues: PPchar; anames: PPchar):longint; cdecl;
  627. var
  628. P : PStringArray;
  629. i : integer;
  630. begin
  631. P:=PStringArray(adata);
  632. SetLength(P^,ncols);
  633. for i:= 0 to ncols - 1 do
  634. P^[i]:= strPas(avalues[i]);
  635. result:= 0;
  636. end;
  637. function execscallback(adata: pointer; ncols: longint; //adata = PArrayStringArray
  638. avalues: PPchar; anames: PPchar):longint; cdecl;
  639. var
  640. I,N : integer;
  641. PP : PArrayStringArray;
  642. p : PStringArray;
  643. begin
  644. PP:=PArrayStringArray(adata);
  645. N:=high(PP^); // Length-1;
  646. setlength(PP^,N+2); // increase with 1;
  647. p:= @(PP^[N+1]); // newly added array, fill with data.
  648. setlength(p^,ncols);
  649. for i:= 0 to ncols - 1 do
  650. p^[i]:= strPas(avalues[i]);
  651. result:= 0;
  652. end;
  653. function TSQLite3Connection.stringsquery(const asql: string): TArrayStringArray;
  654. begin
  655. SetLength(result,0);
  656. checkerror(sqlite3_exec(fhandle,pchar(asql),@execscallback,@result,nil));
  657. end;
  658. function TSQLite3Connection.RowsAffected(cursor: TSQLCursor): TRowsCount;
  659. begin
  660. if assigned(cursor) then
  661. Result := (cursor as TSQLite3Cursor).RowsAffected
  662. else
  663. Result := -1;
  664. end;
  665. function TSQLite3Connection.GetSchemaInfoSQL(SchemaType: TSchemaType;
  666. SchemaObjectName, SchemaPattern: string): string;
  667. begin
  668. case SchemaType of
  669. stTables : result := 'select name as table_name from sqlite_master where type = ''table''';
  670. stColumns : result := 'pragma table_info(''' + (SchemaObjectName) + ''')';
  671. else
  672. DatabaseError(SMetadataUnavailable)
  673. end; {case}
  674. end;
  675. function TSQLite3Connection.StrToStatementType(s: string): TStatementType;
  676. begin
  677. S:=Lowercase(s);
  678. if s = 'pragma' then exit(stSelect);
  679. result := inherited StrToStatementType(s);
  680. end;
  681. constructor TSQLite3Connection.Create(AOwner: TComponent);
  682. begin
  683. inherited Create(AOwner);
  684. FConnOptions := FConnOptions + [sqEscapeRepeat] + [sqEscapeSlash];
  685. FieldNameQuoteChars:=DoubleQuotes;
  686. end;
  687. procedure TSQLite3Connection.UpdateIndexDefs(IndexDefs: TIndexDefs; TableName: string);
  688. var
  689. artableinfo, arindexlist, arindexinfo: TArrayStringArray;
  690. il,ii: integer;
  691. IndexName: string;
  692. IndexOptions: TIndexOptions;
  693. PKFields, IXFields: TStrings;
  694. function CheckPKFields:boolean;
  695. var i: integer;
  696. begin
  697. Result:=false;
  698. if IXFields.Count<>PKFields.Count then Exit;
  699. for i:=0 to IXFields.Count-1 do
  700. if PKFields.IndexOf(IXFields[i])<0 then Exit;
  701. Result:=true;
  702. PKFields.Clear;
  703. end;
  704. begin
  705. PKFields:=TStringList.Create;
  706. PKFields.Delimiter:=';';
  707. IXFields:=TStringList.Create;
  708. IXFields.Delimiter:=';';
  709. //primary key fields
  710. artableinfo := stringsquery('PRAGMA table_info('+TableName+');');
  711. for ii:=low(artableinfo) to high(artableinfo) do
  712. if (high(artableinfo[ii]) >= 5) and (artableinfo[ii][5] = '1') then
  713. PKFields.Add(artableinfo[ii][1]);
  714. //list of all table indexes
  715. arindexlist:=stringsquery('PRAGMA index_list('+TableName+');');
  716. for il:=low(arindexlist) to high(arindexlist) do
  717. begin
  718. IndexName:=arindexlist[il][1];
  719. if arindexlist[il][2]='1' then
  720. IndexOptions:=[ixUnique]
  721. else
  722. IndexOptions:=[];
  723. //list of columns in given index
  724. arindexinfo:=stringsquery('PRAGMA index_info('+IndexName+');');
  725. IXFields.Clear;
  726. for ii:=low(arindexinfo) to high(arindexinfo) do
  727. IXFields.Add(arindexinfo[ii][2]);
  728. if CheckPKFields then IndexOptions:=IndexOptions+[ixPrimary];
  729. IndexDefs.Add(IndexName, IXFields.DelimitedText, IndexOptions);
  730. end;
  731. if PKFields.Count > 0 then //in special case for INTEGER PRIMARY KEY column, unique index is not created
  732. IndexDefs.Add('$PRIMARY_KEY$', PKFields.DelimitedText, [ixPrimary,ixUnique]);
  733. PKFields.Free;
  734. IXFields.Free;
  735. end;
  736. function TSQLite3Connection.getinsertid: int64;
  737. begin
  738. result:= sqlite3_last_insert_rowid(fhandle);
  739. end;
  740. procedure TSQLite3Connection.GetFieldNames(const TableName: string;
  741. List: TStrings);
  742. begin
  743. GetDBInfo(stColumns,TableName,'name',List);
  744. end;
  745. procedure TSQLite3Connection.setoptions(const avalue: tsqliteoptions);
  746. begin
  747. if avalue <> foptions then
  748. begin
  749. checkdisconnected;
  750. foptions:= avalue;
  751. end;
  752. end;
  753. end.