sqldb.pp 22 KB

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