sqldb.pp 23 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910
  1. { $Id$
  2. Copyright (c) 2004 by Joost van der Sluis
  3. SQL database & dataset
  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. **********************************************************************}
  10. unit sqldb;
  11. {$mode objfpc}
  12. {$H+}
  13. {$M+} // ### remove this!!!
  14. interface
  15. uses SysUtils, Classes, DB;
  16. type
  17. TSQLConnection = class;
  18. TSQLTransaction = class;
  19. TSQLQuery = class;
  20. TStatementType = (stNone, stSelect, stInsert, stUpdate, stDelete,
  21. stDDL, stGetSegment, stPutSegment, stExecProcedure,
  22. stStartTrans, stCommit, stRollback, stSelectForUpd);
  23. TSQLHandle = Class(TObject)
  24. protected
  25. StatementType : TStatementType;
  26. end;
  27. const
  28. StatementTokens : Array[TStatementType] of string = ('(none)', 'select',
  29. 'insert', 'update', 'delete',
  30. 'create', 'get', 'put', 'execute',
  31. 'start','commit','rollback', '?'
  32. );
  33. { TSQLConnection }
  34. type
  35. TSQLConnection = class (TDatabase)
  36. private
  37. FPassword : string;
  38. FTransaction : TSQLTransaction;
  39. FUserName : string;
  40. FHostName : string;
  41. FCharSet : string;
  42. FRole : String;
  43. procedure SetTransaction(Value : TSQLTransaction);
  44. protected
  45. function StrToStatementType(s : string) : TStatementType; virtual;
  46. procedure DoInternalConnect; override;
  47. procedure DoInternalDisconnect; override;
  48. function GetAsSQLText(Field : TField) : string; virtual;
  49. function GetHandle : pointer; virtual; abstract;
  50. Function AllocateCursorHandle : TSQLHandle; virtual; abstract;
  51. Function AllocateTransactionHandle : TSQLHandle; virtual; abstract;
  52. procedure FreeStatement(cursor : TSQLHandle); virtual; abstract;
  53. procedure PrepareStatement(cursor: TSQLHandle;ATransaction : TSQLTransaction;buf : string); virtual; abstract;
  54. procedure FreeFldBuffers(cursor : TSQLHandle); virtual; abstract;
  55. procedure Execute(cursor: TSQLHandle;atransaction:tSQLtransaction); virtual; abstract;
  56. procedure AddFieldDefs(cursor: TSQLHandle; FieldDefs : TfieldDefs); virtual; abstract;
  57. function Fetch(cursor : TSQLHandle) : boolean; virtual; abstract;
  58. function LoadField(cursor : TSQLHandle;FieldDef : TfieldDef;buffer : pointer) : boolean; virtual; abstract;
  59. function GetTransactionHandle(trans : TSQLHandle): pointer; virtual; abstract;
  60. function Commit(trans : TSQLHandle) : boolean; virtual; abstract;
  61. function RollBack(trans : TSQLHandle) : boolean; virtual; abstract;
  62. function StartdbTransaction(trans : TSQLHandle) : boolean; virtual; abstract;
  63. procedure CommitRetaining(trans : TSQLHandle); virtual; abstract;
  64. procedure RollBackRetaining(trans : TSQLHandle); virtual; abstract;
  65. procedure UpdateIndexDefs(var IndexDefs : TIndexDefs;TableName : string); virtual;
  66. public
  67. destructor Destroy; override;
  68. property Handle: Pointer read GetHandle;
  69. published
  70. property Password : string read FPassword write FPassword;
  71. property Transaction : TSQLTransaction read FTransaction write SetTransaction;
  72. property UserName : string read FUserName write FUserName;
  73. property CharSet : string read FCharSet write FCharSet;
  74. property HostName : string Read FHostName Write FHostName;
  75. property Connected;
  76. Property Role : String read FRole write FRole;
  77. property DatabaseName;
  78. property KeepConnection;
  79. property LoginPrompt;
  80. property Params;
  81. property OnLogin;
  82. end;
  83. { TSQLTransaction }
  84. TCommitRollbackAction = (caNone, caCommit, caCommitRetaining, caRollback,
  85. caRollbackRetaining);
  86. TSQLTransaction = class (TDBTransaction)
  87. private
  88. FTrans : TSQLHandle;
  89. FAction : TCommitRollbackAction;
  90. protected
  91. function GetHandle : Pointer; virtual;
  92. public
  93. procedure Commit; virtual;
  94. procedure CommitRetaining; virtual;
  95. procedure Rollback; virtual;
  96. procedure RollbackRetaining; virtual;
  97. procedure StartTransaction; override;
  98. constructor Create(AOwner : TComponent); override;
  99. destructor Destroy; override;
  100. property Handle: Pointer read GetHandle;
  101. procedure EndTransaction; override;
  102. published
  103. property Action : TCommitRollbackAction read FAction write FAction;
  104. property Database;
  105. end;
  106. { TSQLQuery }
  107. TSQLQuery = class (Tbufdataset)
  108. private
  109. FCursor : TSQLHandle;
  110. FUpdateable : boolean;
  111. FTableName : string;
  112. FSQL : TStrings;
  113. FIsEOF : boolean;
  114. FLoadingFieldDefs : boolean;
  115. FIndexDefs : TIndexDefs;
  116. FReadOnly : boolean;
  117. FUpdateMode : TUpdateMode;
  118. FusePrimaryKeyAsKey : Boolean;
  119. procedure FreeStatement;
  120. procedure PrepareStatement;
  121. procedure FreeFldBuffers;
  122. procedure InitUpdates(SQL : string);
  123. function GetIndexDefs : TIndexDefs;
  124. procedure SetIndexDefs(AValue : TIndexDefs);
  125. procedure SetReadOnly(AValue : Boolean);
  126. procedure SetUsePrimaryKeyAsKey(AValue : Boolean);
  127. procedure SetUpdateMode(AValue : TUpdateMode);
  128. procedure Execute;
  129. protected
  130. // abstract & virtual methods of TBufDataset
  131. function Fetch : boolean; override;
  132. function LoadField(FieldDef : TFieldDef;buffer : pointer) : boolean; override;
  133. // abstract & virtual methods of TDataset
  134. procedure UpdateIndexDefs; override;
  135. procedure SetDatabase(Value : TDatabase); override;
  136. procedure InternalAddRecord(Buffer: Pointer; AAppend: Boolean); override;
  137. procedure InternalClose; override;
  138. procedure InternalDelete; override;
  139. procedure InternalHandleException; override;
  140. procedure InternalInitFieldDefs; override;
  141. procedure InternalOpen; override;
  142. function GetCanModify: Boolean; override;
  143. Function GetSQLStatementType(SQL : String) : TStatementType; virtual;
  144. function ApplyRecUpdate : boolean; override;
  145. public
  146. procedure ExecSQL; virtual;
  147. constructor Create(AOwner : TComponent); override;
  148. destructor Destroy; override;
  149. published
  150. // redeclared data set properties
  151. property Active;
  152. // property Filter;
  153. // property Filtered;
  154. // property FilterOptions;
  155. property BeforeOpen;
  156. property AfterOpen;
  157. property BeforeClose;
  158. property AfterClose;
  159. property BeforeInsert;
  160. property AfterInsert;
  161. property BeforeEdit;
  162. property AfterEdit;
  163. property BeforePost;
  164. property AfterPost;
  165. property BeforeCancel;
  166. property AfterCancel;
  167. property BeforeDelete;
  168. property AfterDelete;
  169. property BeforeScroll;
  170. property AfterScroll;
  171. property OnCalcFields;
  172. property OnDeleteError;
  173. property OnEditError;
  174. property OnFilterRecord;
  175. property OnNewRecord;
  176. property OnPostError;
  177. property AutoCalcFields;
  178. property Database;
  179. property Transaction;
  180. property ReadOnly : Boolean read FReadOnly write SetReadOnly;
  181. property SQL : TStrings read FSQL write FSQL;
  182. property IndexDefs : TIndexDefs read GetIndexDefs;
  183. property UpdateMode : TUpdateMode read FUpdateMode write SetUpdateMode;
  184. property UsePrimaryKeyAsKey : boolean read FUsePrimaryKeyAsKey write SetUsePrimaryKeyAsKey;
  185. end;
  186. implementation
  187. uses dbconst;
  188. { TSQLConnection }
  189. function TSQLConnection.StrToStatementType(s : string) : TStatementType;
  190. var T : TStatementType;
  191. begin
  192. S:=Lowercase(s);
  193. For t:=stselect to strollback do
  194. if (S=StatementTokens[t]) then
  195. Exit(t);
  196. end;
  197. procedure TSQLConnection.SetTransaction(Value : TSQLTransaction);
  198. begin
  199. if FTransaction = nil then
  200. begin
  201. FTransaction := Value;
  202. if Assigned(FTransaction) then
  203. FTransaction.Database := Self;
  204. exit;
  205. end;
  206. if (Value <> FTransaction) and (Value <> nil) then
  207. if (not FTransaction.Active) then
  208. begin
  209. FTransaction := Value;
  210. FTransaction.Database := Self;
  211. end
  212. else
  213. DatabaseError(SErrAssTransaction);
  214. end;
  215. procedure TSQLConnection.UpdateIndexDefs(var IndexDefs : TIndexDefs;TableName : string);
  216. begin
  217. // Empty abstract
  218. end;
  219. procedure TSQLConnection.DoInternalConnect;
  220. begin
  221. // Empty abstract
  222. end;
  223. procedure TSQLConnection.DoInternalDisconnect;
  224. begin
  225. end;
  226. destructor TSQLConnection.Destroy;
  227. begin
  228. inherited Destroy;
  229. end;
  230. function TSQLConnection.GetAsSQLText(Field : TField) : string;
  231. begin
  232. if not assigned(field) then Result := 'Null'
  233. else case field.DataType of
  234. ftString : Result := '''' + field.asstring + '''';
  235. ftDate : Result := '''' + FormatDateTime('yyyy-mm-dd',Field.AsDateTime) + '''';
  236. ftDateTime : Result := '''' + FormatDateTime('yyyy-mm-dd hh:mm:ss',Field.AsDateTime) + ''''
  237. else
  238. Result := field.asstring;
  239. end; {case}
  240. end;
  241. { TSQLTransaction }
  242. procedure TSQLTransaction.EndTransaction;
  243. begin
  244. rollback;
  245. end;
  246. function TSQLTransaction.GetHandle: pointer;
  247. begin
  248. Result := (Database as tsqlconnection).GetTransactionHandle(FTrans);
  249. end;
  250. procedure TSQLTransaction.Commit;
  251. begin
  252. if active then
  253. begin
  254. closedatasets;
  255. if (Database as tsqlconnection).commit(FTrans) then
  256. begin
  257. closeTrans;
  258. FreeAndNil(FTrans);
  259. end;
  260. end;
  261. end;
  262. procedure TSQLTransaction.CommitRetaining;
  263. begin
  264. if active then
  265. (Database as tsqlconnection).commitRetaining(FTrans);
  266. end;
  267. procedure TSQLTransaction.Rollback;
  268. begin
  269. if active then
  270. begin
  271. closedatasets;
  272. if (Database as tsqlconnection).RollBack(FTrans) then
  273. begin
  274. CloseTrans;
  275. FreeAndNil(FTrans);
  276. end;
  277. end;
  278. end;
  279. procedure TSQLTransaction.RollbackRetaining;
  280. begin
  281. if active then
  282. (Database as tsqlconnection).RollBackRetaining(FTrans);
  283. end;
  284. procedure TSQLTransaction.StartTransaction;
  285. var db : TSQLConnection;
  286. begin
  287. if Active then
  288. DatabaseError(SErrTransAlreadyActive);
  289. db := (Database as tsqlconnection);
  290. if Db = nil then
  291. DatabaseError(SErrDatabasenAssigned);
  292. if not Db.Connected then
  293. Db.Open;
  294. if not assigned(FTrans) then FTrans := Db.AllocateTransactionHandle;
  295. if Db.StartdbTransaction(FTrans) then OpenTrans;
  296. end;
  297. constructor TSQLTransaction.Create(AOwner : TComponent);
  298. begin
  299. inherited Create(AOwner);
  300. end;
  301. destructor TSQLTransaction.Destroy;
  302. begin
  303. Rollback;
  304. inherited Destroy;
  305. end;
  306. { TSQLQuery }
  307. procedure TSQLQuery.SetDatabase(Value : TDatabase);
  308. var db : tsqlconnection;
  309. begin
  310. if (Database <> Value) then
  311. begin
  312. db := value as tsqlconnection;
  313. inherited setdatabase(value);
  314. if assigned(value) and (Transaction = nil) and (Assigned(db.Transaction)) then
  315. transaction := Db.Transaction;
  316. end;
  317. end;
  318. procedure TSQLQuery.FreeStatement;
  319. begin
  320. if assigned(FCursor) then
  321. begin
  322. (Database as tsqlconnection).FreeStatement(FCursor);
  323. // FreeAndNil(FCursor);
  324. end;
  325. end;
  326. procedure TSQLQuery.PrepareStatement;
  327. var
  328. Buf : string;
  329. x : integer;
  330. db : tsqlconnection;
  331. sqltr : tsqltransaction;
  332. begin
  333. db := (Database as tsqlconnection);
  334. if not assigned(Db) then
  335. DatabaseError(SErrDatabasenAssigned);
  336. if not Db.Connected then
  337. db.Open;
  338. if not assigned(Transaction) then
  339. DatabaseError(SErrTransactionnSet);
  340. sqltr := (transaction as tsqltransaction);
  341. if not sqltr.Active then sqltr.StartTransaction;
  342. if assigned(fcursor) then FreeAndNil(fcursor);
  343. FCursor := Db.AllocateCursorHandle;
  344. Buf := '';
  345. for x := 0 to FSQL.Count - 1 do
  346. Buf := Buf + FSQL[x] + ' ';
  347. if Buf='' then
  348. begin
  349. DatabaseError(SErrNoStatement);
  350. exit;
  351. end;
  352. FCursor.StatementType := GetSQLStatementType(buf);
  353. if (FCursor.StatementType = stSelect) and not ReadOnly then InitUpdates(Buf);
  354. Db.PrepareStatement(Fcursor,sqltr,buf);
  355. end;
  356. procedure TSQLQuery.FreeFldBuffers;
  357. begin
  358. if assigned(FCursor) then (Database as tsqlconnection).FreeFldBuffers(FCursor);
  359. end;
  360. function TSQLQuery.Fetch : boolean;
  361. begin
  362. if not (Fcursor.StatementType in [stSelect]) then
  363. Exit;
  364. if not FIsEof then FIsEOF := not (Database as tsqlconnection).Fetch(Fcursor);
  365. Result := not FIsEOF;
  366. end;
  367. procedure TSQLQuery.Execute;
  368. begin
  369. (Database as tsqlconnection).execute(Fcursor,Transaction as tsqltransaction);
  370. end;
  371. function TSQLQuery.LoadField(FieldDef : TFieldDef;buffer : pointer) : boolean;
  372. begin
  373. result := (Database as tSQLConnection).LoadField(FCursor,FieldDef,buffer)
  374. end;
  375. procedure TSQLQuery.InternalAddRecord(Buffer: Pointer; AAppend: Boolean);
  376. begin
  377. // not implemented - sql dataset
  378. end;
  379. procedure TSQLQuery.InternalClose;
  380. begin
  381. FreeFldBuffers;
  382. FreeStatement;
  383. if DefaultFields then
  384. DestroyFields;
  385. FIsEOF := False;
  386. // FRecordSize := 0;
  387. inherited internalclose;
  388. end;
  389. procedure TSQLQuery.InternalDelete;
  390. begin
  391. // not implemented - sql dataset
  392. end;
  393. procedure TSQLQuery.InternalHandleException;
  394. begin
  395. end;
  396. procedure TSQLQuery.InternalInitFieldDefs;
  397. begin
  398. if FLoadingFieldDefs then
  399. Exit;
  400. FLoadingFieldDefs := True;
  401. try
  402. FieldDefs.Clear;
  403. (Database as tsqlconnection).AddFieldDefs(fcursor,FieldDefs);
  404. finally
  405. FLoadingFieldDefs := False;
  406. end;
  407. end;
  408. procedure TSQLQuery.InitUpdates(SQL : string);
  409. Var
  410. L : Integer;
  411. P,PP : PChar;
  412. PS: PChar;
  413. S : string;
  414. function GetStatement(var StartP : PChar) : PChar;
  415. var p : pchar;
  416. Cmt, Stm : boolean;
  417. begin
  418. p := StartP;
  419. Cmt := false;
  420. Stm := False;
  421. While ((P-PP)<L) do
  422. begin
  423. if Cmt then
  424. begin
  425. end
  426. else if (p^ in [',',' ','(',')',#13,#10,#9]) then
  427. begin
  428. if stm then break;
  429. end
  430. else if not stm then
  431. begin
  432. StartP := p;
  433. stm := true;
  434. end;
  435. inc(p);
  436. end;
  437. Result := P;
  438. end;
  439. begin
  440. FUpdateable := False;
  441. L:=Length(SQL);
  442. PP:=Pchar(SQL);
  443. P := pp;
  444. PS := pp;
  445. // select-keyword
  446. P := GetStatement(PS);
  447. Setlength(S,P-PS);
  448. Move(PS^,S[1],(P-PS));
  449. S:=Lowercase(S);
  450. if (S) <> 'select' then exit;
  451. // select-part
  452. While ((P-PP)<L) and (S <> 'from') do
  453. begin
  454. repeat
  455. PS := P;
  456. P := GetStatement(PS);
  457. until P^ <> ',';
  458. Setlength(S,P-PS);
  459. Move(PS^,S[1],(P-PS));
  460. S:=Lowercase(S);
  461. end;
  462. // from-part
  463. PS := P;
  464. P := GetStatement(PS);
  465. Setlength(FTableName,P-PS);
  466. Move(PS^,FTableName[1],(P-PS));
  467. While ((P-PP)<L) do
  468. begin
  469. PS := P;
  470. P := GetStatement(PS);
  471. if P^ = ',' then exit; // select-statements from more then one table are not updateable
  472. Setlength(S,P-PS);
  473. Move(PS^,S[1],(P-PS));
  474. S:=Lowercase(S);
  475. if (s = 'where') or (s='order') then break;
  476. end;
  477. FUpdateable := True;
  478. end;
  479. procedure TSQLQuery.InternalOpen;
  480. var tel : integer;
  481. f : TField;
  482. s : string;
  483. begin
  484. try
  485. PrepareStatement;
  486. if Fcursor.StatementType in [stSelect] then
  487. begin
  488. Execute;
  489. InternalInitFieldDefs;
  490. if DefaultFields then
  491. begin
  492. CreateFields;
  493. if FUpdateable and FusePrimaryKeyAsKey then
  494. begin
  495. UpdateIndexDefs;
  496. for tel := 0 to indexdefs.count-1 do {with indexdefs[tel] do}
  497. begin
  498. if ixPrimary in indexdefs[tel].options then
  499. begin
  500. // Todo: If there is more then one field in the key, that must be parsed
  501. s := indexdefs[tel].fields;
  502. F := fieldbyname(s);
  503. F.ProviderFlags := F.ProviderFlags + [pfInKey];
  504. end;
  505. end;
  506. end;
  507. end;
  508. end
  509. else
  510. DatabaseError(SErrNoSelectStatement,Self);
  511. except
  512. on E:Exception do
  513. raise;
  514. end;
  515. inherited InternalOpen;
  516. end;
  517. // public part
  518. procedure TSQLQuery.ExecSQL;
  519. begin
  520. try
  521. PrepareStatement;
  522. Execute;
  523. finally
  524. FreeStatement;
  525. end;
  526. end;
  527. constructor TSQLQuery.Create(AOwner : TComponent);
  528. begin
  529. inherited Create(AOwner);
  530. FSQL := TStringList.Create;
  531. FIndexDefs := TIndexDefs.Create(Self);
  532. FReadOnly := false;
  533. // Delphi has upWhereAll as default, but since strings and oldvalue's don't work yet
  534. // (variants) set it to upWhereKeyOnly
  535. FUpdateMode := upWhereKeyOnly;
  536. FUsePrimaryKeyAsKey := True;
  537. end;
  538. destructor TSQLQuery.Destroy;
  539. begin
  540. if Active then Close;
  541. // if assigned(FCursor) then FCursor.destroy;
  542. FreeAndNil(FSQL);
  543. inherited Destroy;
  544. end;
  545. Function TSQLQuery.GetSQLStatementType(SQL : String) : TStatementType;
  546. Var
  547. L : Integer;
  548. cmt : boolean;
  549. P,PE,PP : PChar;
  550. S : string;
  551. begin
  552. Result:=stNone;
  553. L:=Length(SQL);
  554. If (L=0) then
  555. Exit;
  556. P:=Pchar(SQL);
  557. PP:=P;
  558. Cmt:=False;
  559. While ((P-PP)<L) do
  560. begin
  561. if not (P^ in [' ',#13,#10,#9]) then
  562. begin
  563. if not Cmt then
  564. begin
  565. // Check for comment.
  566. Cmt:=(P^='/') and (((P-PP)<=L) and (P[1]='*'));
  567. if not (cmt) then
  568. Break;
  569. end
  570. else
  571. begin
  572. // Check for end of comment.
  573. Cmt:=Not( (P^='*') and (((P-PP)<=L) and (P[1]='/')) );
  574. If not cmt then
  575. Inc(p);
  576. end;
  577. end;
  578. inc(P);
  579. end;
  580. PE:=P+1;
  581. While ((PE-PP)<L) and (PE^ in ['0'..'9','a'..'z','A'..'Z','_']) do
  582. Inc(PE);
  583. Setlength(S,PE-P);
  584. Move(P^,S[1],(PE-P));
  585. result := (DataBase as TSQLConnection).StrToStatementType(s);
  586. { S:=Lowercase(s);
  587. For t:=stselect to strollback do
  588. if (S=StatementTokens[t]) then
  589. Exit(t);}
  590. end;
  591. procedure TSQLQuery.SetReadOnly(AValue : Boolean);
  592. begin
  593. if not Active then FReadOnly := AValue
  594. else
  595. begin
  596. // Just temporary, this should be possible in the future
  597. DatabaseError(SActiveDataset);
  598. end;
  599. end;
  600. procedure TSQLQuery.SetUsePrimaryKeyAsKey(AValue : Boolean);
  601. begin
  602. if not Active then FusePrimaryKeyAsKey := AValue
  603. else
  604. begin
  605. // Just temporary, this should be possible in the future
  606. DatabaseError(SActiveDataset);
  607. end;
  608. end;
  609. Procedure TSQLQuery.UpdateIndexDefs;
  610. begin
  611. if assigned(DataBase) then
  612. (DataBase as TSQLConnection).UpdateIndexDefs(FIndexDefs,FTableName);
  613. end;
  614. function TSQLQuery.ApplyRecUpdate : boolean;
  615. var r,x,f : integer;
  616. fieldsstr,
  617. v : string;
  618. modify_query : tsqlquery;
  619. sql_tables : string;
  620. sql_set : string;
  621. sql_where : string;
  622. s : string;
  623. begin
  624. Result := False;
  625. sql_tables := FTableName;
  626. sql_set := '';
  627. sql_where := '';
  628. for x := 0 to Fields.Count -1 do
  629. begin
  630. if (pfInKey in Fields[x].ProviderFlags) or
  631. ((FUpdateMode = upWhereAll) and (pfInWhere in Fields[x].ProviderFlags)) or
  632. ((FUpdateMode = UpWhereChanged) and (pfInWhere in Fields[x].ProviderFlags) and (fields[x].value <> fields[x].oldvalue)) then
  633. begin
  634. // This should be converted to something like GetAsSQLText, but better wait until variants (oldvalue) are working for strings
  635. s := fields[x].oldvalue; // This directly int the line below raises a variant-error
  636. sql_where := sql_where + '(' + fields[x].DisplayName + '=' + s + ') and ';
  637. end;
  638. if (pfInUpdate in Fields[x].ProviderFlags) then
  639. if ord(ActiveBuffer[(Fields[x].Fieldno-1) div 8]) and (1 shl ((Fields[x].Fieldno-1) mod 8)) > 0 then // check for null
  640. sql_set := sql_set + fields[x].DisplayName + '=' + (Database as TSQLConnection).GetAsSQLText(nil) + ','
  641. else
  642. sql_set := sql_set + fields[x].DisplayName + '=' + (Database as TSQLConnection).GetAsSQLText(fields[x]) + ',';
  643. end;
  644. setlength(sql_set,length(sql_set)-1);
  645. setlength(sql_where,length(sql_where)-5);
  646. with tsqlquery.Create(nil) do
  647. begin
  648. DataBase := self.Database;
  649. transaction := self.transaction;
  650. sql.clear;
  651. s := 'update ' + sql_tables + ' set ' + sql_set + ' where ' + sql_where;
  652. sql.add(s);
  653. ExecSQL;
  654. Result := true;
  655. Free;
  656. end;
  657. end;
  658. Function TSQLQuery.GetCanModify: Boolean;
  659. begin
  660. if FCursor.StatementType = stSelect then
  661. Result:= Active and FUpdateable and (not FReadOnly)
  662. else
  663. Result := False;
  664. end;
  665. function TSQLQuery.GetIndexDefs : TIndexDefs;
  666. begin
  667. Result := FIndexDefs;
  668. end;
  669. procedure TSQLQuery.SetIndexDefs(AValue : TIndexDefs);
  670. begin
  671. FIndexDefs := AValue;
  672. end;
  673. procedure TSQLQuery.SetUpdateMode(AValue : TUpdateMode);
  674. begin
  675. FUpdateMode := AValue;
  676. end;
  677. end.
  678. {
  679. $Log$
  680. Revision 1.12 2005-01-24 10:52:43 michael
  681. * Patch from Joost van der Sluis
  682. - Made it possible to run 'show' queries for MySQL
  683. Revision 1.11 2005/01/12 10:30:33 michael
  684. * Patch from Joost Van der Sluis:
  685. - implemented TSQLQuery.UpdateIndexDefs
  686. - implemented TSQLQuery.ReadOnly
  687. - implemented TSQLQuery.IndexDefs
  688. - implemented TSQLQuery.UpdateMode
  689. - implemented TSQLQuery.UsePrimaryKeyAsKey (Set pfInKey in the
  690. providerflags
  691. of fields that are in the primary index of the underlying table)
  692. - Added support for updates on date-fields
  693. Revision 1.10 2004/12/29 14:31:27 michael
  694. + Patch from Joost van der Sluis:
  695. - implemented support for modifying queries, with a simple parser
  696. - implemented ApplyRecUpdate
  697. Revision 1.9 2004/12/13 19:22:16 michael
  698. * Ptahc from Joost van der Sluis
  699. - moved IsCursorOpen from TSQLQuery to tbufdataset
  700. - moved SetFieldData from TSQLQuery to TBufDataset
  701. - very first start for support of cached updates
  702. Revision 1.8 2004/12/04 22:43:38 michael
  703. * Patch from Joost van der Sluis
  704. - replaced checkactive in commit and rollback for 'if active'
  705. - fixed a warning
  706. - adapted for the changes in TBuffDataset
  707. Revision 1.7 2004/11/05 08:32:02 michael
  708. TBufDataset.inc:
  709. - replaced Freemem by Reallocmem, Free by FreeAndNil
  710. Database.inc:
  711. - Moved Active property from TSQLTransaction to TDBTransaction
  712. - Gives an error if the database of an active transaction is changed
  713. Dataset.inc
  714. - Don't distribute events if FDisableControlsCount > 0
  715. - Replaced FActive by FState<>dsInactive
  716. - Set EOF after append
  717. db.pp:
  718. - Removed duplicate definition of TAlignment
  719. - Moved Active property from TSQLTransaction to TDBTransaction
  720. - Replaced FActive by FState<>dsInactive
  721. - Gives an error if the database of an active transaction is changed
  722. sqldb:
  723. - Moved Active property from TSQLTransaction to TDBTransaction
  724. - replaced Freemem by Reallocmem, Free by FreeAndNil
  725. IBConnection:
  726. - Moved FSQLDAAllocated to the cursor
  727. PQConnection:
  728. - Don't try to free the statement if a fatal error occured
  729. Revision 1.6 2004/10/27 07:23:13 michael
  730. + Patch from Joost Van der Sluis to fix transactions
  731. Revision 1.5 2004/10/10 14:45:52 michael
  732. + Use of dbconst for resource strings
  733. Revision 1.4 2004/10/10 14:24:22 michael
  734. * Large patch from Joost Van der Sluis.
  735. * Float fix in interbase
  736. + Commit and commitretaining for pqconnection
  737. + Preparestatement and prepareselect joined.
  738. + Freestatement and FreeSelect joined
  739. + TSQLQuery.GetSQLStatementType implemented
  740. + TBufDataset.AllocBuffer now no longer does a realloc
  741. + Fetch=True means succesfully got data. False means end of data.
  742. + Default implementation of GetFieldData implemented/
  743. Revision 1.3 2004/10/02 14:52:25 michael
  744. + Added mysql connection
  745. Revision 1.2 2004/09/26 16:56:32 michael
  746. + Further fixes from Joost van der sluis for Postgresql
  747. Revision 1.1 2004/08/31 09:49:47 michael
  748. + initial implementation of TSQLQuery
  749. }