sqldb.pp 26 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027
  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 TSchemaType = (stNoSchema, stTables, stSysTables, stProcedures, stColumns, stProcedureParams, stIndexes, stPackages);
  17. TConnOption = (sqSupportParams);
  18. TConnOptions= set of TConnOption;
  19. type
  20. TSQLConnection = class;
  21. TSQLTransaction = class;
  22. TSQLQuery = class;
  23. TStatementType = (stNone, stSelect, stInsert, stUpdate, stDelete,
  24. stDDL, stGetSegment, stPutSegment, stExecProcedure,
  25. stStartTrans, stCommit, stRollback, stSelectForUpd);
  26. TSQLHandle = Class(TObject)
  27. end;
  28. TSQLCursor = Class(TSQLHandle)
  29. public
  30. FPrepared : Boolean;
  31. FStatementType : TStatementType;
  32. end;
  33. const
  34. StatementTokens : Array[TStatementType] of string = ('(none)', 'select',
  35. 'insert', 'update', 'delete',
  36. 'create', 'get', 'put', 'execute',
  37. 'start','commit','rollback', '?'
  38. );
  39. SQLDelimiterCharacters = [',',' ','(',')',#13,#10,#9];
  40. { TSQLConnection }
  41. type
  42. TSQLConnection = class (TDatabase)
  43. private
  44. FPassword : string;
  45. FTransaction : TSQLTransaction;
  46. FUserName : string;
  47. FHostName : string;
  48. FCharSet : string;
  49. FRole : String;
  50. procedure SetTransaction(Value : TSQLTransaction);
  51. protected
  52. FConnOptions : TConnOptions;
  53. function StrToStatementType(s : string) : TStatementType; virtual;
  54. procedure DoInternalConnect; override;
  55. procedure DoInternalDisconnect; override;
  56. function GetAsSQLText(Field : TField) : string; virtual;
  57. function GetHandle : pointer; virtual; abstract;
  58. Function AllocateCursorHandle : TSQLCursor; virtual; abstract;
  59. Function AllocateTransactionHandle : TSQLHandle; virtual; abstract;
  60. procedure PrepareStatement(cursor: TSQLCursor;ATransaction : TSQLTransaction;buf : string; AParams : TParams); virtual; abstract;
  61. procedure Execute(cursor: TSQLCursor;atransaction:tSQLtransaction; AParams : TParams); virtual; abstract;
  62. function Fetch(cursor : TSQLCursor) : boolean; virtual; abstract;
  63. procedure AddFieldDefs(cursor: TSQLCursor; FieldDefs : TfieldDefs); virtual; abstract;
  64. procedure CloseStatement(cursor : TSQLCursor); virtual; abstract;
  65. procedure UnPrepareStatement(cursor : TSQLCursor); virtual; abstract;
  66. procedure FreeFldBuffers(cursor : TSQLCursor); virtual; abstract;
  67. function LoadField(cursor : TSQLCursor;FieldDef : TfieldDef;buffer : pointer) : boolean; virtual; abstract;
  68. function GetTransactionHandle(trans : TSQLHandle): pointer; virtual; abstract;
  69. function Commit(trans : TSQLHandle) : boolean; virtual; abstract;
  70. function RollBack(trans : TSQLHandle) : boolean; virtual; abstract;
  71. function StartdbTransaction(trans : TSQLHandle) : boolean; virtual; abstract;
  72. procedure CommitRetaining(trans : TSQLHandle); virtual; abstract;
  73. procedure RollBackRetaining(trans : TSQLHandle); virtual; abstract;
  74. procedure UpdateIndexDefs(var IndexDefs : TIndexDefs;TableName : string); virtual;
  75. function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; virtual;
  76. function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; virtual;abstract;
  77. Procedure ObtainSQLStatementType(Cursor : TSQLCursor; SQLStr : string);
  78. public
  79. property Handle: Pointer read GetHandle;
  80. destructor Destroy; override;
  81. property ConnOptions: TConnOptions read FConnOptions;
  82. published
  83. property Password : string read FPassword write FPassword;
  84. property Transaction : TSQLTransaction read FTransaction write SetTransaction;
  85. property UserName : string read FUserName write FUserName;
  86. property CharSet : string read FCharSet write FCharSet;
  87. property HostName : string Read FHostName Write FHostName;
  88. property Connected;
  89. Property Role : String read FRole write FRole;
  90. property DatabaseName;
  91. property KeepConnection;
  92. property LoginPrompt;
  93. property Params;
  94. property OnLogin;
  95. end;
  96. { TSQLTransaction }
  97. TCommitRollbackAction = (caNone, caCommit, caCommitRetaining, caRollback,
  98. caRollbackRetaining);
  99. TSQLTransaction = class (TDBTransaction)
  100. private
  101. FTrans : TSQLHandle;
  102. FAction : TCommitRollbackAction;
  103. protected
  104. function GetHandle : Pointer; virtual;
  105. Procedure SetDatabase (Value : TDatabase); override;
  106. public
  107. procedure Commit; virtual;
  108. procedure CommitRetaining; virtual;
  109. procedure Rollback; virtual;
  110. procedure RollbackRetaining; virtual;
  111. procedure StartTransaction; override;
  112. constructor Create(AOwner : TComponent); override;
  113. destructor Destroy; override;
  114. property Handle: Pointer read GetHandle;
  115. procedure EndTransaction; override;
  116. published
  117. property Action : TCommitRollbackAction read FAction write FAction;
  118. property Database;
  119. end;
  120. { TSQLQuery }
  121. TSQLQuery = class (Tbufdataset)
  122. private
  123. FCursor : TSQLCursor;
  124. FUpdateable : boolean;
  125. FTableName : string;
  126. FSQL : TStringList;
  127. FIsEOF : boolean;
  128. FLoadingFieldDefs : boolean;
  129. FIndexDefs : TIndexDefs;
  130. FReadOnly : boolean;
  131. FUpdateMode : TUpdateMode;
  132. FParams : TParams;
  133. FusePrimaryKeyAsKey : Boolean;
  134. // FSchemaInfo : TSchemaInfo;
  135. procedure CloseStatement;
  136. procedure FreeFldBuffers;
  137. procedure InitUpdates(SQL : string);
  138. function GetIndexDefs : TIndexDefs;
  139. function GetStatementType : TStatementType;
  140. procedure SetIndexDefs(AValue : TIndexDefs);
  141. procedure SetReadOnly(AValue : Boolean);
  142. procedure SetUsePrimaryKeyAsKey(AValue : Boolean);
  143. procedure SetUpdateMode(AValue : TUpdateMode);
  144. procedure OnChangeSQL(Sender : TObject);
  145. procedure Execute;
  146. protected
  147. // abstract & virtual methods of TBufDataset
  148. function Fetch : boolean; override;
  149. function LoadField(FieldDef : TFieldDef;buffer : pointer) : boolean; override;
  150. // abstract & virtual methods of TDataset
  151. procedure UpdateIndexDefs; override;
  152. procedure SetDatabase(Value : TDatabase); override;
  153. Procedure SetTransaction(Value : TDBTransaction); override;
  154. procedure InternalAddRecord(Buffer: Pointer; AAppend: Boolean); override;
  155. procedure InternalClose; override;
  156. procedure InternalHandleException; override;
  157. procedure InternalInitFieldDefs; override;
  158. procedure InternalOpen; override;
  159. function GetCanModify: Boolean; override;
  160. function ApplyRecUpdate(UpdateKind : TUpdateKind) : boolean; override;
  161. Function IsPrepared : Boolean; virtual;
  162. public
  163. procedure Prepare; virtual;
  164. procedure UnPrepare; virtual;
  165. procedure ExecSQL; virtual;
  166. constructor Create(AOwner : TComponent); override;
  167. destructor Destroy; override;
  168. procedure SetSchemaInfo( SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string); virtual;
  169. function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
  170. published
  171. // redeclared data set properties
  172. property Active;
  173. // property Filter;
  174. // property Filtered;
  175. // property FilterOptions;
  176. property BeforeOpen;
  177. property AfterOpen;
  178. property BeforeClose;
  179. property AfterClose;
  180. property BeforeInsert;
  181. property AfterInsert;
  182. property BeforeEdit;
  183. property AfterEdit;
  184. property BeforePost;
  185. property AfterPost;
  186. property BeforeCancel;
  187. property AfterCancel;
  188. property BeforeDelete;
  189. property AfterDelete;
  190. property BeforeScroll;
  191. property AfterScroll;
  192. property OnCalcFields;
  193. property OnDeleteError;
  194. property OnEditError;
  195. property OnFilterRecord;
  196. property OnNewRecord;
  197. property OnPostError;
  198. property AutoCalcFields;
  199. property Database;
  200. property Transaction;
  201. property ReadOnly : Boolean read FReadOnly write SetReadOnly;
  202. property SQL : TStringlist read FSQL write FSQL;
  203. property IndexDefs : TIndexDefs read GetIndexDefs;
  204. property Params : TParams read FParams write FParams;
  205. property UpdateMode : TUpdateMode read FUpdateMode write SetUpdateMode;
  206. property UsePrimaryKeyAsKey : boolean read FUsePrimaryKeyAsKey write SetUsePrimaryKeyAsKey;
  207. property Prepared : boolean read IsPrepared;
  208. property StatementType : TStatementType read GetStatementType;
  209. // property SchemaInfo : TSchemaInfo read FSchemaInfo default stNoSchema;
  210. end;
  211. implementation
  212. uses dbconst, strutils;
  213. { TSQLConnection }
  214. function TSQLConnection.StrToStatementType(s : string) : TStatementType;
  215. var T : TStatementType;
  216. begin
  217. S:=Lowercase(s);
  218. For t:=stselect to strollback do
  219. if (S=StatementTokens[t]) then
  220. Exit(t);
  221. end;
  222. procedure TSQLConnection.SetTransaction(Value : TSQLTransaction);
  223. begin
  224. if FTransaction<>value then
  225. begin
  226. if Assigned(FTransaction) and FTransaction.Active then
  227. DatabaseError(SErrAssTransaction);
  228. if Assigned(Value) then
  229. Value.Database := Self;
  230. FTransaction := Value;
  231. end;
  232. end;
  233. procedure TSQLConnection.UpdateIndexDefs(var IndexDefs : TIndexDefs;TableName : string);
  234. begin
  235. // Empty abstract
  236. end;
  237. procedure TSQLConnection.DoInternalConnect;
  238. begin
  239. // Empty abstract
  240. end;
  241. procedure TSQLConnection.DoInternalDisconnect;
  242. begin
  243. end;
  244. destructor TSQLConnection.Destroy;
  245. begin
  246. inherited Destroy;
  247. end;
  248. function TSQLConnection.GetAsSQLText(Field : TField) : string;
  249. begin
  250. if not assigned(field) then Result := 'Null'
  251. else case field.DataType of
  252. ftString : Result := '''' + field.asstring + '''';
  253. ftDate : Result := '''' + FormatDateTime('yyyy-mm-dd',Field.AsDateTime) + '''';
  254. ftDateTime : Result := '''' + FormatDateTime('yyyy-mm-dd hh:mm:ss',Field.AsDateTime) + ''''
  255. else
  256. Result := field.asstring;
  257. end; {case}
  258. end;
  259. Procedure TSQLConnection.ObtainSQLStatementType(Cursor : TSQLCursor; SQLStr : string);
  260. Var
  261. L : Integer;
  262. cmt : boolean;
  263. P,PE,PP : PChar;
  264. S : string;
  265. begin
  266. L := Length(SQLstr);
  267. if L=0 then
  268. begin
  269. DatabaseError(SErrNoStatement);
  270. exit;
  271. end;
  272. P:=Pchar(SQLstr);
  273. PP:=P;
  274. Cmt:=False;
  275. While ((P-PP)<L) do
  276. begin
  277. if not (P^ in [' ',#13,#10,#9]) then
  278. begin
  279. if not Cmt then
  280. begin
  281. // Check for comment.
  282. Cmt:=(P^='/') and (((P-PP)<=L) and (P[1]='*'));
  283. if not (cmt) then
  284. Break;
  285. end
  286. else
  287. begin
  288. // Check for end of comment.
  289. Cmt:=Not( (P^='*') and (((P-PP)<=L) and (P[1]='/')) );
  290. If not cmt then
  291. Inc(p);
  292. end;
  293. end;
  294. inc(P);
  295. end;
  296. PE:=P+1;
  297. While ((PE-PP)<L) and (PE^ in ['0'..'9','a'..'z','A'..'Z','_']) do
  298. Inc(PE);
  299. Setlength(S,PE-P);
  300. Move(P^,S[1],(PE-P));
  301. Cursor.FStatementType := StrToStatementType(s);
  302. end;
  303. function TSQLConnection.GetSchemaInfoSQL( SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string;
  304. begin
  305. DatabaseError(SMetadataUnavailable);
  306. end;
  307. { TSQLTransaction }
  308. procedure TSQLTransaction.EndTransaction;
  309. begin
  310. rollback;
  311. end;
  312. function TSQLTransaction.GetHandle: pointer;
  313. begin
  314. Result := (Database as tsqlconnection).GetTransactionHandle(FTrans);
  315. end;
  316. procedure TSQLTransaction.Commit;
  317. begin
  318. if active then
  319. begin
  320. closedatasets;
  321. if (Database as tsqlconnection).commit(FTrans) then
  322. begin
  323. closeTrans;
  324. FreeAndNil(FTrans);
  325. end;
  326. end;
  327. end;
  328. procedure TSQLTransaction.CommitRetaining;
  329. begin
  330. if active then
  331. (Database as tsqlconnection).commitRetaining(FTrans);
  332. end;
  333. procedure TSQLTransaction.Rollback;
  334. begin
  335. if active then
  336. begin
  337. closedatasets;
  338. if (Database as tsqlconnection).RollBack(FTrans) then
  339. begin
  340. CloseTrans;
  341. FreeAndNil(FTrans);
  342. end;
  343. end;
  344. end;
  345. procedure TSQLTransaction.RollbackRetaining;
  346. begin
  347. if active then
  348. (Database as tsqlconnection).RollBackRetaining(FTrans);
  349. end;
  350. procedure TSQLTransaction.StartTransaction;
  351. var db : TSQLConnection;
  352. begin
  353. if Active then
  354. DatabaseError(SErrTransAlreadyActive);
  355. db := (Database as tsqlconnection);
  356. if Db = nil then
  357. DatabaseError(SErrDatabasenAssigned);
  358. if not Db.Connected then
  359. Db.Open;
  360. if not assigned(FTrans) then FTrans := Db.AllocateTransactionHandle;
  361. if Db.StartdbTransaction(FTrans) then OpenTrans;
  362. end;
  363. constructor TSQLTransaction.Create(AOwner : TComponent);
  364. begin
  365. inherited Create(AOwner);
  366. end;
  367. destructor TSQLTransaction.Destroy;
  368. begin
  369. Rollback;
  370. inherited Destroy;
  371. end;
  372. Procedure TSQLTransaction.SetDatabase(Value : TDatabase);
  373. begin
  374. If Value<>Database then
  375. begin
  376. CheckInactive;
  377. If Assigned(Database) then
  378. with Database as TSqlConnection do
  379. if Transaction = self then Transaction := nil;
  380. inherited SetDatabase(Value);
  381. end;
  382. end;
  383. { TSQLQuery }
  384. procedure TSQLQuery.OnChangeSQL(Sender : TObject);
  385. var s : string;
  386. i : integer;
  387. p : pchar;
  388. ParamName : String;
  389. begin
  390. UnPrepare;
  391. if (FSQL <> nil) then
  392. begin
  393. if assigned(FParams) then FParams.Clear;
  394. s := FSQL.Text;
  395. i := posex(':',s);
  396. while i > 0 do
  397. begin
  398. inc(i);
  399. p := @s[i];
  400. repeat
  401. inc(p);
  402. until (p^ in SQLDelimiterCharacters);
  403. if not assigned(FParams) then FParams := TParams.create(self);
  404. ParamName := copy(s,i,p-@s[i]);
  405. if FParams.FindParam(ParamName) = nil then
  406. FParams.CreateParam(ftUnknown, ParamName, ptInput);
  407. i := posex(':',s,i);
  408. end;
  409. end
  410. end;
  411. Procedure TSQLQuery.SetTransaction(Value : TDBTransaction);
  412. begin
  413. UnPrepare;
  414. inherited;
  415. end;
  416. procedure TSQLQuery.SetDatabase(Value : TDatabase);
  417. var db : tsqlconnection;
  418. begin
  419. if (Database <> Value) then
  420. begin
  421. UnPrepare;
  422. db := value as tsqlconnection;
  423. inherited setdatabase(value);
  424. if assigned(value) and (Transaction = nil) and (Assigned(db.Transaction)) then
  425. transaction := Db.Transaction;
  426. end;
  427. end;
  428. procedure TSQLQuery.CloseStatement;
  429. begin
  430. if assigned(FCursor) then
  431. (Database as tsqlconnection).CloseStatement(FCursor);
  432. end;
  433. Function TSQLQuery.IsPrepared : Boolean;
  434. begin
  435. Result := Assigned(FCursor) and FCursor.FPrepared;
  436. end;
  437. procedure TSQLQuery.Prepare;
  438. var
  439. Buf : string;
  440. db : tsqlconnection;
  441. sqltr : tsqltransaction;
  442. begin
  443. if not IsPrepared then
  444. begin
  445. db := (Database as tsqlconnection);
  446. sqltr := (transaction as tsqltransaction);
  447. if not assigned(Db) then
  448. DatabaseError(SErrDatabasenAssigned);
  449. if not assigned(sqltr) then
  450. DatabaseError(SErrTransactionnSet);
  451. if not Db.Connected then db.Open;
  452. if not sqltr.Active then sqltr.StartTransaction;
  453. if assigned(fcursor) then FreeAndNil(fcursor);
  454. FCursor := Db.AllocateCursorHandle;
  455. buf := TrimRight(FSQL.Text);
  456. Db.PrepareStatement(Fcursor,sqltr,buf,FParams);
  457. if (FCursor.FStatementType = stSelect) and not ReadOnly then
  458. InitUpdates(Buf);
  459. end;
  460. end;
  461. procedure TSQLQuery.UnPrepare;
  462. begin
  463. CheckInactive;
  464. if IsPrepared then (Database as tsqlconnection).UnPrepareStatement(FCursor);
  465. FreeAndNil(FCursor);
  466. end;
  467. procedure TSQLQuery.FreeFldBuffers;
  468. begin
  469. if assigned(FCursor) then (Database as tsqlconnection).FreeFldBuffers(FCursor);
  470. end;
  471. function TSQLQuery.Fetch : boolean;
  472. begin
  473. if not (Fcursor.FStatementType in [stSelect]) then
  474. Exit;
  475. if not FIsEof then FIsEOF := not (Database as tsqlconnection).Fetch(Fcursor);
  476. Result := not FIsEOF;
  477. end;
  478. procedure TSQLQuery.Execute;
  479. begin
  480. (Database as tsqlconnection).execute(Fcursor,Transaction as tsqltransaction, FParams);
  481. end;
  482. function TSQLQuery.LoadField(FieldDef : TFieldDef;buffer : pointer) : boolean;
  483. begin
  484. result := (Database as tSQLConnection).LoadField(FCursor,FieldDef,buffer)
  485. end;
  486. procedure TSQLQuery.InternalAddRecord(Buffer: Pointer; AAppend: Boolean);
  487. begin
  488. // not implemented - sql dataset
  489. end;
  490. procedure TSQLQuery.InternalClose;
  491. begin
  492. FreeFldBuffers;
  493. CloseStatement;
  494. if DefaultFields then
  495. DestroyFields;
  496. FIsEOF := False;
  497. // FRecordSize := 0;
  498. inherited internalclose;
  499. end;
  500. procedure TSQLQuery.InternalHandleException;
  501. begin
  502. end;
  503. procedure TSQLQuery.InternalInitFieldDefs;
  504. begin
  505. if FLoadingFieldDefs then
  506. Exit;
  507. FLoadingFieldDefs := True;
  508. try
  509. FieldDefs.Clear;
  510. (Database as tsqlconnection).AddFieldDefs(fcursor,FieldDefs);
  511. finally
  512. FLoadingFieldDefs := False;
  513. end;
  514. end;
  515. procedure TSQLQuery.InitUpdates(SQL : string);
  516. Var
  517. L : Integer;
  518. P,PP : PChar;
  519. PS: PChar;
  520. S : string;
  521. function GetStatement(var StartP : PChar) : PChar;
  522. var p : pchar;
  523. Cmt, Stm : boolean;
  524. begin
  525. p := StartP;
  526. Cmt := false;
  527. Stm := False;
  528. While ((P-PP)<L) do
  529. begin
  530. if Cmt then
  531. begin
  532. end
  533. else if (p^ in SQLDelimiterCharacters) then
  534. begin
  535. if stm then break;
  536. end
  537. else if not stm then
  538. begin
  539. StartP := p;
  540. stm := true;
  541. end;
  542. inc(p);
  543. end;
  544. Result := P;
  545. end;
  546. begin
  547. FUpdateable := False;
  548. L:=Length(SQL);
  549. PP:=Pchar(SQL);
  550. P := pp;
  551. PS := pp;
  552. // select-keyword
  553. P := GetStatement(PS);
  554. Setlength(S,P-PS);
  555. Move(PS^,S[1],(P-PS));
  556. S:=Lowercase(S);
  557. if (S) <> 'select' then exit;
  558. // select-part
  559. While ((P-PP)<L) and (S <> 'from') do
  560. begin
  561. repeat
  562. PS := P;
  563. P := GetStatement(PS);
  564. until P^ <> ',';
  565. Setlength(S,P-PS);
  566. Move(PS^,S[1],(P-PS));
  567. S:=Lowercase(S);
  568. end;
  569. // from-part
  570. PS := P;
  571. P := GetStatement(PS);
  572. Setlength(FTableName,P-PS);
  573. Move(PS^,FTableName[1],(P-PS));
  574. While ((P-PP)<L) do
  575. begin
  576. PS := P;
  577. P := GetStatement(PS);
  578. if P^ = ',' then exit; // select-statements from more then one table are not updateable
  579. Setlength(S,P-PS);
  580. Move(PS^,S[1],(P-PS));
  581. S:=Lowercase(S);
  582. if (s = 'where') or (s='order') then break;
  583. end;
  584. FUpdateable := True;
  585. end;
  586. procedure TSQLQuery.InternalOpen;
  587. var tel : integer;
  588. f : TField;
  589. s : string;
  590. WasPrepared : boolean;
  591. begin
  592. try
  593. WasPrepared := IsPrepared;
  594. Prepare;
  595. if FCursor.FStatementType in [stSelect] then
  596. begin
  597. Execute;
  598. if not WasPrepared then InternalInitFieldDefs; // if query was prepared before opening, fields are already created
  599. if DefaultFields then
  600. begin
  601. CreateFields;
  602. if FUpdateable and FusePrimaryKeyAsKey then
  603. begin
  604. UpdateIndexDefs;
  605. for tel := 0 to indexdefs.count-1 do {with indexdefs[tel] do}
  606. begin
  607. if ixPrimary in indexdefs[tel].options then
  608. begin
  609. // Todo: If there is more then one field in the key, that must be parsed
  610. s := indexdefs[tel].fields;
  611. F := Findfield(s);
  612. if F <> nil then
  613. F.ProviderFlags := F.ProviderFlags + [pfInKey];
  614. end;
  615. end;
  616. end;
  617. end;
  618. end
  619. else
  620. DatabaseError(SErrNoSelectStatement,Self);
  621. except
  622. on E:Exception do
  623. raise;
  624. end;
  625. inherited InternalOpen;
  626. end;
  627. // public part
  628. procedure TSQLQuery.ExecSQL;
  629. begin
  630. try
  631. Prepare;
  632. Execute;
  633. finally
  634. CloseStatement;
  635. end;
  636. end;
  637. constructor TSQLQuery.Create(AOwner : TComponent);
  638. begin
  639. inherited Create(AOwner);
  640. FSQL := TStringList.Create;
  641. FSQL.OnChange := @OnChangeSQL;
  642. FIndexDefs := TIndexDefs.Create(Self);
  643. FReadOnly := false;
  644. // Delphi has upWhereAll as default, but since strings and oldvalue's don't work yet
  645. // (variants) set it to upWhereKeyOnly
  646. FUpdateMode := upWhereKeyOnly;
  647. FUsePrimaryKeyAsKey := True;
  648. end;
  649. destructor TSQLQuery.Destroy;
  650. begin
  651. if Active then Close;
  652. UnPrepare;
  653. FreeAndNil(FSQL);
  654. FreeAndNil(FIndexDefs);
  655. inherited Destroy;
  656. end;
  657. procedure TSQLQuery.SetReadOnly(AValue : Boolean);
  658. begin
  659. if not Active then FReadOnly := AValue
  660. else
  661. begin
  662. // Just temporary, this should be possible in the future
  663. DatabaseError(SActiveDataset);
  664. end;
  665. end;
  666. procedure TSQLQuery.SetUsePrimaryKeyAsKey(AValue : Boolean);
  667. begin
  668. if not Active then FusePrimaryKeyAsKey := AValue
  669. else
  670. begin
  671. // Just temporary, this should be possible in the future
  672. DatabaseError(SActiveDataset);
  673. end;
  674. end;
  675. Procedure TSQLQuery.UpdateIndexDefs;
  676. begin
  677. if assigned(DataBase) then
  678. (DataBase as TSQLConnection).UpdateIndexDefs(FIndexDefs,FTableName);
  679. end;
  680. function TSQLQuery.ApplyRecUpdate(UpdateKind : TUpdateKind) : boolean;
  681. var
  682. sql_tables : string;
  683. s : string;
  684. procedure UpdateWherePart(var sql_where : string;x : integer);
  685. begin
  686. if (pfInKey in Fields[x].ProviderFlags) or
  687. ((FUpdateMode = upWhereAll) and (pfInWhere in Fields[x].ProviderFlags)) or
  688. ((FUpdateMode = UpWhereChanged) and (pfInWhere in Fields[x].ProviderFlags) and (fields[x].value <> fields[x].oldvalue)) then
  689. begin
  690. // This should be converted to something like GetAsSQLText, but better wait until variants (oldvalue) are working for strings
  691. s := fields[x].oldvalue; // This directly int the line below raises a variant-error
  692. sql_where := sql_where + '(' + fields[x].FieldName + '=' + s + ') and ';
  693. end;
  694. end;
  695. function ModifyRecQuery : string;
  696. var x : integer;
  697. sql_set : string;
  698. sql_where : string;
  699. begin
  700. sql_tables := FTableName;
  701. sql_set := '';
  702. sql_where := '';
  703. for x := 0 to Fields.Count -1 do
  704. begin
  705. UpdateWherePart(sql_where,x);
  706. if (pfInUpdate in Fields[x].ProviderFlags) then
  707. if fields[x].IsNull then // check for null
  708. sql_set := sql_set + fields[x].FieldName + '=' + (Database as TSQLConnection).GetAsSQLText(nil) + ','
  709. else
  710. sql_set := sql_set + fields[x].FieldName + '=' + (Database as TSQLConnection).GetAsSQLText(fields[x]) + ',';
  711. end;
  712. setlength(sql_set,length(sql_set)-1);
  713. setlength(sql_where,length(sql_where)-5);
  714. result := 'update ' + sql_tables + ' set ' + sql_set + ' where ' + sql_where;
  715. end;
  716. function InsertRecQuery : string;
  717. var x : integer;
  718. sql_fields : string;
  719. sql_values : string;
  720. begin
  721. sql_tables := FTableName;
  722. sql_fields := '';
  723. sql_values := '';
  724. for x := 0 to Fields.Count -1 do
  725. begin
  726. if not fields[x].IsNull then
  727. begin
  728. sql_fields := sql_fields + fields[x].DisplayName + ',';
  729. sql_values := sql_values + (Database as TSQLConnection).GetAsSQLText(fields[x]) + ',';
  730. end;
  731. end;
  732. setlength(sql_fields,length(sql_fields)-1);
  733. setlength(sql_values,length(sql_values)-1);
  734. result := 'insert into ' + sql_tables + ' (' + sql_fields + ') values (' + sql_values + ')';
  735. end;
  736. function DeleteRecQuery : string;
  737. var x : integer;
  738. sql_where : string;
  739. begin
  740. sql_tables := FTableName;
  741. sql_where := '';
  742. for x := 0 to Fields.Count -1 do
  743. UpdateWherePart(sql_where,x);
  744. setlength(sql_where,length(sql_where)-5);
  745. result := 'delete from ' + sql_tables + ' where ' + sql_where;
  746. end;
  747. begin
  748. Result := False;
  749. with tsqlquery.Create(nil) do
  750. begin
  751. DataBase := self.Database;
  752. transaction := self.transaction;
  753. sql.clear;
  754. case UpdateKind of
  755. ukModify : s := ModifyRecQuery;
  756. ukInsert : s := InsertRecQuery;
  757. ukDelete : s := DeleteRecQuery;
  758. end; {case}
  759. sql.add(s);
  760. ExecSQL;
  761. Result := true;
  762. Free;
  763. end;
  764. end;
  765. Function TSQLQuery.GetCanModify: Boolean;
  766. begin
  767. if FCursor.FStatementType = stSelect then
  768. Result:= Active and FUpdateable and (not FReadOnly)
  769. else
  770. Result := False;
  771. end;
  772. function TSQLQuery.GetIndexDefs : TIndexDefs;
  773. begin
  774. Result := FIndexDefs;
  775. end;
  776. procedure TSQLQuery.SetIndexDefs(AValue : TIndexDefs);
  777. begin
  778. FIndexDefs := AValue;
  779. end;
  780. procedure TSQLQuery.SetUpdateMode(AValue : TUpdateMode);
  781. begin
  782. FUpdateMode := AValue;
  783. end;
  784. procedure TSQLQuery.SetSchemaInfo( SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string);
  785. begin
  786. SQL.Clear;
  787. SQL.Add((DataBase as tsqlconnection).GetSchemaInfoSQL(SchemaType, SchemaObjectName, SchemaPattern));
  788. end;
  789. function TSQLQuery.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream;
  790. begin
  791. result := (DataBase as tsqlconnection).CreateBlobStream(Field, Mode);
  792. end;
  793. function TSQLQuery.GetStatementType : TStatementType;
  794. begin
  795. if assigned(FCursor) then Result := FCursor.FStatementType
  796. else Result := stNone;
  797. end;
  798. end.
  799. {
  800. $Log$
  801. Revision 1.18 2005-04-24 19:21:28 joost
  802. - some fixes in assignment of transactions and databases
  803. Revision 1.17 2005/04/13 22:10:26 joost
  804. - TSQLQuery now frees FIndexDefs
  805. Revision 1.16 2005/04/10 18:29:26 joost
  806. - implemented parameter support for sqldb
  807. - Added TSQLConnection.ConnOptions
  808. - renamed TSQLQuery.FreeStatement to TSQLQuery.CloseStatement
  809. - renamed TSQLQuery.PrepareStatement to TSQLQuery.Prepare
  810. - added TSQLQuery.UnPrepare
  811. Revision 1.15 2005/03/23 08:17:51 michael
  812. + Several patches from Jose A. Rimon
  813. # Prevents "field not found" error, when use a query without the primary key
  814. Set SQLlen of different data types
  815. Use AliasName instead of SQLname to avoid "duplicate field name" error, for
  816. example when using "coalesce" more than once
  817. use SQLScale in ftLargeInt to get actual values
  818. Send query to server with different lines. Provides line info in sqlErrors
  819. and allows single line comments
  820. Revision 1.14 2005/02/14 17:13:12 peter
  821. * truncate log
  822. Revision 1.13 2005/02/07 11:23:41 joost
  823. - implemented TSQLQuery.SetSchemaInfo
  824. - added support for delete and insert
  825. Revision 1.12 2005/01/24 10:52:43 michael
  826. * Patch from Joost van der Sluis
  827. - Made it possible to run 'show' queries for MySQL
  828. Revision 1.11 2005/01/12 10:30:33 michael
  829. * Patch from Joost Van der Sluis:
  830. - implemented TSQLQuery.UpdateIndexDefs
  831. - implemented TSQLQuery.ReadOnly
  832. - implemented TSQLQuery.IndexDefs
  833. - implemented TSQLQuery.UpdateMode
  834. - implemented TSQLQuery.UsePrimaryKeyAsKey (Set pfInKey in the
  835. providerflags
  836. of fields that are in the primary index of the underlying table)
  837. - Added support for updates on date-fields
  838. }