sqldb.pp 66 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327
  1. {
  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, bufdataset, sqlscript;
  16. type TSchemaType = (stNoSchema, stTables, stSysTables, stProcedures, stColumns, stProcedureParams, stIndexes, stPackages, stSchemata);
  17. TConnOption = (sqSupportParams,sqEscapeSlash,sqEscapeRepeat);
  18. TConnOptions= set of TConnOption;
  19. TConnInfoType=(citAll=-1, citServerType, citServerVersion, citServerVersionString, citClientName, citClientVersion);
  20. TRowsCount = LargeInt;
  21. type
  22. TSQLConnection = class;
  23. TSQLTransaction = class;
  24. TCustomSQLQuery = class;
  25. TSQLQuery = class;
  26. TSQLScript = class;
  27. TStatementType = (stUnknown, stSelect, stInsert, stUpdate, stDelete,
  28. stDDL, stGetSegment, stPutSegment, stExecProcedure,
  29. stStartTrans, stCommit, stRollback, stSelectForUpd);
  30. TDBEventType = (detCustom, detPrepare, detExecute, detFetch, detCommit,detRollBack);
  31. TDBEventTypes = set of TDBEventType;
  32. TDBLogNotifyEvent = Procedure (Sender : TSQLConnection; EventType : TDBEventType; Const Msg : String) of object;
  33. TSQLHandle = Class(TObject)
  34. end;
  35. { TSQLCursor }
  36. TSQLCursor = Class(TSQLHandle)
  37. public
  38. FPrepared : Boolean;
  39. FSelectable : Boolean;
  40. FInitFieldDef : Boolean;
  41. FStatementType : TStatementType;
  42. FSchemaType : TSchemaType;
  43. end;
  44. type TQuoteChars = array[0..1] of char;
  45. const
  46. SingleQuotes : TQuoteChars = ('''','''');
  47. DoubleQuotes : TQuoteChars = ('"','"');
  48. LogAllEvents = [detCustom, detPrepare, detExecute, detFetch, detCommit, detRollBack];
  49. StatementTokens : Array[TStatementType] of string = ('(unknown)', 'select',
  50. 'insert', 'update', 'delete',
  51. 'create', 'get', 'put', 'execute',
  52. 'start','commit','rollback', '?'
  53. );
  54. type
  55. { TServerIndexDefs }
  56. TServerIndexDefs = class(TIndexDefs)
  57. Private
  58. public
  59. constructor Create(ADataSet: TDataSet); override;
  60. procedure Update; override;
  61. end;
  62. type
  63. { TSQLConnection }
  64. TSQLConnection = class (TDatabase)
  65. private
  66. FFieldNameQuoteChars : TQuoteChars;
  67. FLogEvents: TDBEventTypes;
  68. FOnLog: TDBLogNotifyEvent;
  69. FPassword : string;
  70. FTransaction : TSQLTransaction;
  71. FUserName : string;
  72. FHostName : string;
  73. FCharSet : string;
  74. FRole : String;
  75. function GetPort: cardinal;
  76. procedure SetPort(const AValue: cardinal);
  77. protected
  78. FConnOptions : TConnOptions;
  79. FSQLFormatSettings : TFormatSettings;
  80. procedure GetDBInfo(const ASchemaType : TSchemaType; const ASchemaObjectName, AReturnField : string; AList: TStrings);
  81. procedure SetTransaction(Value : TSQLTransaction);virtual;
  82. function StrToStatementType(s : string) : TStatementType; virtual;
  83. procedure DoInternalConnect; override;
  84. procedure DoInternalDisconnect; override;
  85. function GetAsSQLText(Field : TField) : string; overload; virtual;
  86. function GetAsSQLText(Param : TParam) : string; overload; virtual;
  87. function GetHandle : pointer; virtual; virtual;
  88. Function LogEvent(EventType : TDBEventType) : Boolean;
  89. Procedure Log(EventType : TDBEventType; Const Msg : String); virtual;
  90. Function AllocateCursorHandle : TSQLCursor; virtual; abstract;
  91. Procedure DeAllocateCursorHandle(var cursor : TSQLCursor); virtual; abstract;
  92. Function AllocateTransactionHandle : TSQLHandle; virtual; abstract;
  93. procedure PrepareStatement(cursor: TSQLCursor;ATransaction : TSQLTransaction;buf : string; AParams : TParams); virtual; abstract;
  94. procedure Execute(cursor: TSQLCursor;atransaction:tSQLtransaction; AParams : TParams); virtual; abstract;
  95. function Fetch(cursor : TSQLCursor) : boolean; virtual; abstract;
  96. procedure AddFieldDefs(cursor: TSQLCursor; FieldDefs : TfieldDefs); virtual; abstract;
  97. procedure UnPrepareStatement(cursor : TSQLCursor); virtual; abstract;
  98. procedure FreeFldBuffers(cursor : TSQLCursor); virtual;
  99. function LoadField(cursor : TSQLCursor;FieldDef : TfieldDef;buffer : pointer; out CreateBlob : boolean) : boolean; virtual; abstract;
  100. function GetTransactionHandle(trans : TSQLHandle): pointer; virtual; abstract;
  101. function Commit(trans : TSQLHandle) : boolean; virtual; abstract;
  102. function RollBack(trans : TSQLHandle) : boolean; virtual; abstract;
  103. function StartdbTransaction(trans : TSQLHandle; aParams : string) : boolean; virtual; abstract;
  104. procedure CommitRetaining(trans : TSQLHandle); virtual; abstract;
  105. procedure RollBackRetaining(trans : TSQLHandle); virtual; abstract;
  106. procedure UpdateIndexDefs(IndexDefs : TIndexDefs;TableName : string); virtual;
  107. function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; virtual;
  108. procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction : TSQLTransaction); virtual; abstract;
  109. function RowsAffected(cursor: TSQLCursor): TRowsCount; virtual;
  110. property Port: cardinal read GetPort write SetPort;
  111. public
  112. property Handle: Pointer read GetHandle;
  113. property FieldNameQuoteChars: TQuoteChars read FFieldNameQuoteChars write FFieldNameQuoteChars;
  114. constructor Create(AOwner: TComponent); override;
  115. destructor Destroy; override;
  116. procedure StartTransaction; override;
  117. procedure EndTransaction; override;
  118. property ConnOptions: TConnOptions read FConnOptions;
  119. procedure ExecuteDirect(SQL : String); overload; virtual;
  120. procedure ExecuteDirect(SQL : String; ATransaction : TSQLTransaction); overload; virtual;
  121. procedure GetTableNames(List : TStrings; SystemTables : Boolean = false); virtual;
  122. procedure GetProcedureNames(List : TStrings); virtual;
  123. procedure GetFieldNames(const TableName : string; List : TStrings); virtual;
  124. procedure GetSchemaNames(List: TStrings); virtual;
  125. function GetConnectionInfo(InfoType:TConnInfoType): string; virtual;
  126. procedure CreateDB; virtual;
  127. procedure DropDB; virtual;
  128. published
  129. property Password : string read FPassword write FPassword;
  130. property Transaction : TSQLTransaction read FTransaction write SetTransaction;
  131. property UserName : string read FUserName write FUserName;
  132. property CharSet : string read FCharSet write FCharSet;
  133. property HostName : string Read FHostName Write FHostName;
  134. Property OnLog : TDBLogNotifyEvent Read FOnLog Write FOnLog;
  135. Property LogEvents : TDBEventTypes Read FLogEvents Write FLogEvents Default LogAllEvents;
  136. property Connected;
  137. Property Role : String read FRole write FRole;
  138. property DatabaseName;
  139. property KeepConnection;
  140. property LoginPrompt;
  141. property Params;
  142. property OnLogin;
  143. end;
  144. { TSQLTransaction }
  145. TCommitRollbackAction = (caNone, caCommit, caCommitRetaining, caRollback,
  146. caRollbackRetaining);
  147. TSQLTransaction = class (TDBTransaction)
  148. private
  149. FTrans : TSQLHandle;
  150. FAction : TCommitRollbackAction;
  151. FParams : TStringList;
  152. procedure SetParams(const AValue: TStringList);
  153. protected
  154. function GetHandle : Pointer; virtual;
  155. Procedure SetDatabase (Value : TDatabase); override;
  156. Function LogEvent(EventType : TDBEventType) : Boolean;
  157. Procedure Log(EventType : TDBEventType; Const Msg : String); virtual;
  158. public
  159. procedure Commit; virtual;
  160. procedure CommitRetaining; virtual;
  161. procedure Rollback; virtual;
  162. procedure RollbackRetaining; virtual;
  163. procedure StartTransaction; override;
  164. constructor Create(AOwner : TComponent); override;
  165. destructor Destroy; override;
  166. property Handle: Pointer read GetHandle;
  167. procedure EndTransaction; override;
  168. published
  169. property Action : TCommitRollbackAction read FAction write FAction;
  170. property Database;
  171. property Params : TStringList read FParams write SetParams;
  172. end;
  173. { TCustomSQLQuery }
  174. TCustomSQLQuery = class (TCustomBufDataset)
  175. private
  176. FCursor : TSQLCursor;
  177. FUpdateable : boolean;
  178. FTableName : string;
  179. FSQL : TStringList;
  180. FUpdateSQL,
  181. FInsertSQL,
  182. FDeleteSQL : TStringList;
  183. FIsEOF : boolean;
  184. FLoadingFieldDefs : boolean;
  185. FUpdateMode : TUpdateMode;
  186. FParams : TParams;
  187. FusePrimaryKeyAsKey : Boolean;
  188. FSQLBuf : String;
  189. FWhereStartPos : integer;
  190. FWhereStopPos : integer;
  191. FParseSQL : boolean;
  192. FMasterLink : TMasterParamsDatalink;
  193. // FSchemaInfo : TSchemaInfo;
  194. FServerFilterText : string;
  195. FServerFiltered : Boolean;
  196. FServerIndexDefs : TServerIndexDefs;
  197. // Used by SetSchemaType
  198. FSchemaType : TSchemaType;
  199. FSchemaObjectName : string;
  200. FSchemaPattern : string;
  201. FUpdateQry,
  202. FDeleteQry,
  203. FInsertQry : TCustomSQLQuery;
  204. procedure FreeFldBuffers;
  205. function GetServerIndexDefs: TServerIndexDefs;
  206. function GetStatementType : TStatementType;
  207. procedure SetDeleteSQL(const AValue: TStringlist);
  208. procedure SetInsertSQL(const AValue: TStringlist);
  209. procedure SetParseSQL(AValue : Boolean);
  210. procedure SetSQL(const AValue: TStringlist);
  211. procedure SetUpdateSQL(const AValue: TStringlist);
  212. procedure SetUsePrimaryKeyAsKey(AValue : Boolean);
  213. procedure SetUpdateMode(AValue : TUpdateMode);
  214. procedure OnChangeSQL(Sender : TObject);
  215. procedure OnChangeModifySQL(Sender : TObject);
  216. procedure Execute;
  217. Function SQLParser(const ASQL : string) : TStatementType;
  218. procedure ApplyFilter;
  219. Function AddFilter(SQLstr : string) : string;
  220. protected
  221. // abstract & virtual methods of TBufDataset
  222. function Fetch : boolean; override;
  223. function LoadField(FieldDef : TFieldDef;buffer : pointer; out CreateBlob : boolean) : boolean; override;
  224. // abstract & virtual methods of TDataset
  225. procedure UpdateServerIndexDefs; virtual;
  226. procedure SetDatabase(Value : TDatabase); override;
  227. Procedure SetTransaction(Value : TDBTransaction); override;
  228. procedure InternalAddRecord(Buffer: Pointer; AAppend: Boolean); override;
  229. procedure InternalClose; override;
  230. procedure InternalInitFieldDefs; override;
  231. procedure InternalOpen; override;
  232. function GetCanModify: Boolean; override;
  233. procedure ApplyRecUpdate(UpdateKind : TUpdateKind); override;
  234. Function IsPrepared : Boolean; virtual;
  235. Procedure SetActive (Value : Boolean); override;
  236. procedure SetServerFiltered(Value: Boolean); virtual;
  237. procedure SetServerFilterText(const Value: string); virtual;
  238. Function GetDataSource : TDatasource; override;
  239. Procedure SetDataSource(AValue : TDatasource);
  240. procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField); override;
  241. procedure BeforeRefreshOpenCursor; override;
  242. procedure SetReadOnly(AValue : Boolean); override;
  243. Function LogEvent(EventType : TDBEventType) : Boolean;
  244. Procedure Log(EventType : TDBEventType; Const Msg : String); virtual;
  245. procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  246. public
  247. procedure Prepare; virtual;
  248. procedure UnPrepare; virtual;
  249. procedure ExecSQL; virtual;
  250. constructor Create(AOwner : TComponent); override;
  251. destructor Destroy; override;
  252. procedure SetSchemaInfo( ASchemaType : TSchemaType; ASchemaObjectName, ASchemaPattern : string); virtual;
  253. property Prepared : boolean read IsPrepared;
  254. function RowsAffected: TRowsCount; virtual;
  255. function ParamByName(Const AParamName : String) : TParam;
  256. protected
  257. // redeclared data set properties
  258. property Active;
  259. property Filter;
  260. property Filtered;
  261. // property FilterOptions;
  262. property BeforeOpen;
  263. property AfterOpen;
  264. property BeforeClose;
  265. property AfterClose;
  266. property BeforeInsert;
  267. property AfterInsert;
  268. property BeforeEdit;
  269. property AfterEdit;
  270. property BeforePost;
  271. property AfterPost;
  272. property BeforeCancel;
  273. property AfterCancel;
  274. property BeforeDelete;
  275. property AfterDelete;
  276. property BeforeScroll;
  277. property AfterScroll;
  278. property OnCalcFields;
  279. property OnDeleteError;
  280. property OnEditError;
  281. property OnFilterRecord;
  282. property OnNewRecord;
  283. property OnPostError;
  284. property AutoCalcFields;
  285. property Database;
  286. // protected
  287. property SchemaType : TSchemaType read FSchemaType default stNoSchema;
  288. property Transaction;
  289. property SQL : TStringlist read FSQL write SetSQL;
  290. property UpdateSQL : TStringlist read FUpdateSQL write SetUpdateSQL;
  291. property InsertSQL : TStringlist read FInsertSQL write SetInsertSQL;
  292. property DeleteSQL : TStringlist read FDeleteSQL write SetDeleteSQL;
  293. property Params : TParams read FParams write FParams;
  294. property UpdateMode : TUpdateMode read FUpdateMode write SetUpdateMode default upWhereKeyOnly;
  295. property UsePrimaryKeyAsKey : boolean read FUsePrimaryKeyAsKey write SetUsePrimaryKeyAsKey default true;
  296. property StatementType : TStatementType read GetStatementType;
  297. property ParseSQL : Boolean read FParseSQL write SetParseSQL default true;
  298. Property DataSource : TDatasource Read GetDataSource Write SetDatasource;
  299. property ServerFilter: string read FServerFilterText write SetServerFilterText;
  300. property ServerFiltered: Boolean read FServerFiltered write SetServerFiltered default False;
  301. property ServerIndexDefs : TServerIndexDefs read GetServerIndexDefs;
  302. end;
  303. { TSQLQuery }
  304. TSQLQuery = Class(TCustomSQLQuery)
  305. public
  306. property SchemaType;
  307. Property StatementType;
  308. Published
  309. property MaxIndexesCount;
  310. // TDataset stuff
  311. property FieldDefs;
  312. Property Active;
  313. Property AutoCalcFields;
  314. Property Filter;
  315. Property Filtered;
  316. Property AfterCancel;
  317. Property AfterClose;
  318. Property AfterDelete;
  319. Property AfterEdit;
  320. Property AfterInsert;
  321. Property AfterOpen;
  322. Property AfterPost;
  323. Property AfterScroll;
  324. Property BeforeCancel;
  325. Property BeforeClose;
  326. Property BeforeDelete;
  327. Property BeforeEdit;
  328. Property BeforeInsert;
  329. Property BeforeOpen;
  330. Property BeforePost;
  331. Property BeforeScroll;
  332. Property OnCalcFields;
  333. Property OnDeleteError;
  334. Property OnEditError;
  335. Property OnFilterRecord;
  336. Property OnNewRecord;
  337. Property OnPostError;
  338. // property SchemaInfo default stNoSchema;
  339. property Database;
  340. property Transaction;
  341. property ReadOnly;
  342. property SQL;
  343. property UpdateSQL;
  344. property InsertSQL;
  345. property DeleteSQL;
  346. property IndexDefs;
  347. property Params;
  348. property UpdateMode;
  349. property UsePrimaryKeyAsKey;
  350. property ParseSQL;
  351. Property DataSource;
  352. property ServerFilter;
  353. property ServerFiltered;
  354. property ServerIndexDefs;
  355. end;
  356. { TSQLScript }
  357. TSQLScript = class (TCustomSQLscript)
  358. private
  359. FOnDirective: TSQLScriptDirectiveEvent;
  360. FQuery : TCustomSQLQuery;
  361. FDatabase : TDatabase;
  362. FTransaction : TDBTransaction;
  363. protected
  364. procedure ExecuteStatement (SQLStatement: TStrings; var StopExecution: Boolean); override;
  365. procedure ExecuteDirective (Directive, Argument: String; var StopExecution: Boolean); override;
  366. procedure ExecuteCommit; override;
  367. Procedure SetDatabase (Value : TDatabase); virtual;
  368. Procedure SetTransaction(Value : TDBTransaction); virtual;
  369. Procedure CheckDatabase;
  370. public
  371. constructor Create(AOwner : TComponent); override;
  372. destructor Destroy; override;
  373. procedure Execute; override;
  374. procedure ExecuteScript;
  375. published
  376. Property DataBase : TDatabase Read FDatabase Write SetDatabase;
  377. Property Transaction : TDBTransaction Read FTransaction Write SetTransaction;
  378. property OnDirective: TSQLScriptDirectiveEvent read FOnDirective write FOnDirective;
  379. property Directives;
  380. property Defines;
  381. property Script;
  382. property Terminator;
  383. property CommentsinSQL;
  384. property UseSetTerm;
  385. property UseCommit;
  386. property UseDefines;
  387. property OnException;
  388. end;
  389. { TSQLConnector }
  390. TSQLConnector = Class(TSQLConnection)
  391. private
  392. FProxy : TSQLConnection;
  393. FConnectorType: String;
  394. procedure SetConnectorType(const AValue: String);
  395. protected
  396. procedure SetTransaction(Value : TSQLTransaction);override;
  397. procedure DoInternalConnect; override;
  398. procedure DoInternalDisconnect; override;
  399. Procedure CheckProxy;
  400. Procedure CreateProxy; virtual;
  401. Procedure FreeProxy; virtual;
  402. function StrToStatementType(s : string) : TStatementType; override;
  403. function GetAsSQLText(Field : TField) : string; overload; override;
  404. function GetAsSQLText(Param : TParam) : string; overload; override;
  405. function GetHandle : pointer; override;
  406. Function AllocateCursorHandle : TSQLCursor; override;
  407. Procedure DeAllocateCursorHandle(var cursor : TSQLCursor); override;
  408. Function AllocateTransactionHandle : TSQLHandle; override;
  409. procedure PrepareStatement(cursor: TSQLCursor;ATransaction : TSQLTransaction;buf : string; AParams : TParams); override;
  410. procedure Execute(cursor: TSQLCursor;atransaction:tSQLtransaction; AParams : TParams); override;
  411. function Fetch(cursor : TSQLCursor) : boolean; override;
  412. procedure AddFieldDefs(cursor: TSQLCursor; FieldDefs : TfieldDefs); override;
  413. procedure UnPrepareStatement(cursor : TSQLCursor); override;
  414. procedure FreeFldBuffers(cursor : TSQLCursor); override;
  415. function LoadField(cursor : TSQLCursor;FieldDef : TfieldDef;buffer : pointer; out CreateBlob : boolean) : boolean; override;
  416. function RowsAffected(cursor: TSQLCursor): TRowsCount; override;
  417. function GetTransactionHandle(trans : TSQLHandle): pointer; override;
  418. function Commit(trans : TSQLHandle) : boolean; override;
  419. function RollBack(trans : TSQLHandle) : boolean; override;
  420. function StartdbTransaction(trans : TSQLHandle; aParams : string) : boolean; override;
  421. procedure CommitRetaining(trans : TSQLHandle); override;
  422. procedure RollBackRetaining(trans : TSQLHandle); override;
  423. procedure UpdateIndexDefs(IndexDefs : TIndexDefs;TableName : string); override;
  424. function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; override;
  425. procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction : TSQLTransaction); override;
  426. Property Proxy : TSQLConnection Read FProxy;
  427. Published
  428. Property ConnectorType : String Read FConnectorType Write SetConnectorType;
  429. end;
  430. TSQLConnectionClass = Class of TSQLConnection;
  431. { TConnectionDef }
  432. TLibraryLoadFunction = Function (Const S : AnsiString) : Integer;
  433. TLibraryUnLoadFunction = Procedure;
  434. TConnectionDef = Class(TPersistent)
  435. Class Function TypeName : String; virtual;
  436. Class Function ConnectionClass : TSQLConnectionClass; virtual;
  437. Class Function Description : String; virtual;
  438. Class Function DefaultLibraryName : String; virtual;
  439. Class Function LoadFunction : TLibraryLoadFunction; virtual;
  440. Class Function UnLoadFunction : TLibraryUnLoadFunction; virtual;
  441. Class Function LoadedLibraryName : string; virtual;
  442. Procedure ApplyParams(Params : TStrings; AConnection : TSQLConnection); virtual;
  443. end;
  444. TConnectionDefClass = class of TConnectionDef;
  445. Var
  446. GlobalDBLogHook : TDBLogNotifyEvent;
  447. Procedure RegisterConnection(Def : TConnectionDefClass);
  448. Procedure UnRegisterConnection(Def : TConnectionDefClass);
  449. Procedure UnRegisterConnection(ConnectionName : String);
  450. Function GetConnectionDef(ConnectorName : String) : TConnectionDef;
  451. Procedure GetConnectionList(List : TSTrings);
  452. const DefaultSQLFormatSettings : TFormatSettings = (
  453. CurrencyFormat: 1;
  454. NegCurrFormat: 5;
  455. ThousandSeparator: #0;
  456. DecimalSeparator: '.';
  457. CurrencyDecimals: 2;
  458. DateSeparator: '-';
  459. TimeSeparator: ':';
  460. ListSeparator: ' ';
  461. CurrencyString: '$';
  462. ShortDateFormat: 'yyyy-mm-dd';
  463. LongDateFormat: '';
  464. TimeAMString: '';
  465. TimePMString: '';
  466. ShortTimeFormat: 'hh:nn:ss';
  467. LongTimeFormat: 'hh:nn:ss.zzz';
  468. ShortMonthNames: ('','','','','','','','','','','','');
  469. LongMonthNames: ('','','','','','','','','','','','');
  470. ShortDayNames: ('','','','','','','');
  471. LongDayNames: ('','','','','','','');
  472. TwoDigitYearCenturyWindow: 50;
  473. );
  474. implementation
  475. uses dbconst, strutils;
  476. function TimeIntervalToString(Time: TDateTime): string;
  477. var
  478. millisecond: word;
  479. second : word;
  480. minute : word;
  481. hour : word;
  482. begin
  483. DecodeTime(Time,hour,minute,second,millisecond);
  484. hour := hour + (trunc(Time) * 24);
  485. result := Format('%.2d:%.2d:%.2d.%.3d',[hour,minute,second,millisecond]);
  486. end;
  487. { TSQLConnection }
  488. function TSQLConnection.StrToStatementType(s : string) : TStatementType;
  489. var T : TStatementType;
  490. begin
  491. S:=Lowercase(s);
  492. for T:=stSelect to stRollback do
  493. if (S=StatementTokens[T]) then
  494. Exit(T);
  495. Result:=stUnknown;
  496. end;
  497. procedure TSQLConnection.SetTransaction(Value : TSQLTransaction);
  498. begin
  499. if FTransaction<>value then
  500. begin
  501. if Assigned(FTransaction) and FTransaction.Active then
  502. DatabaseError(SErrAssTransaction);
  503. if Assigned(Value) then
  504. Value.Database := Self;
  505. FTransaction := Value;
  506. If Assigned(FTransaction) and (FTransaction.Database=Nil) then
  507. FTransaction.Database:=Self;
  508. end;
  509. end;
  510. procedure TSQLConnection.UpdateIndexDefs(IndexDefs : TIndexDefs;TableName : string);
  511. begin
  512. // Empty abstract
  513. end;
  514. procedure TSQLConnection.DoInternalConnect;
  515. begin
  516. if (DatabaseName = '') then
  517. DatabaseError(SErrNoDatabaseName,self);
  518. end;
  519. procedure TSQLConnection.DoInternalDisconnect;
  520. begin
  521. end;
  522. destructor TSQLConnection.Destroy;
  523. begin
  524. inherited Destroy;
  525. end;
  526. procedure TSQLConnection.StartTransaction;
  527. begin
  528. if not assigned(Transaction) then
  529. DatabaseError(SErrConnTransactionnSet)
  530. else
  531. Transaction.StartTransaction;
  532. end;
  533. procedure TSQLConnection.EndTransaction;
  534. begin
  535. if not assigned(Transaction) then
  536. DatabaseError(SErrConnTransactionnSet)
  537. else
  538. Transaction.EndTransaction;
  539. end;
  540. Procedure TSQLConnection.ExecuteDirect(SQL: String);
  541. begin
  542. ExecuteDirect(SQL,FTransaction);
  543. end;
  544. Procedure TSQLConnection.ExecuteDirect(SQL: String; ATransaction : TSQLTransaction);
  545. var Cursor : TSQLCursor;
  546. begin
  547. if not assigned(ATransaction) then
  548. DatabaseError(SErrTransactionnSet);
  549. if not Connected then Open;
  550. if not ATransaction.Active then ATransaction.StartTransaction;
  551. try
  552. SQL := TrimRight(SQL);
  553. if SQL = '' then
  554. DatabaseError(SErrNoStatement);
  555. Cursor := AllocateCursorHandle;
  556. Cursor.FStatementType := stUnknown;
  557. PrepareStatement(Cursor,ATransaction,SQL,Nil);
  558. Execute(Cursor,ATransaction, Nil);
  559. UnPrepareStatement(Cursor);
  560. finally;
  561. DeAllocateCursorHandle(Cursor);
  562. end;
  563. end;
  564. function TSQLConnection.GetPort: cardinal;
  565. begin
  566. result := StrToIntDef(Params.Values['Port'],0);
  567. end;
  568. procedure TSQLConnection.SetPort(const AValue: cardinal);
  569. begin
  570. if AValue<>0 then
  571. Params.Values['Port']:=IntToStr(AValue)
  572. else with params do if IndexOfName('Port') > -1 then
  573. Delete(IndexOfName('Port'));
  574. end;
  575. procedure TSQLConnection.GetDBInfo(const ASchemaType : TSchemaType; const ASchemaObjectName, AReturnField : string; AList: TStrings);
  576. var qry : TCustomSQLQuery;
  577. begin
  578. if not assigned(Transaction) then
  579. DatabaseError(SErrConnTransactionnSet);
  580. qry := TCustomSQLQuery.Create(nil);
  581. qry.transaction := Transaction;
  582. qry.database := Self;
  583. with qry do
  584. begin
  585. ParseSQL := False;
  586. SetSchemaInfo(ASchemaType,ASchemaObjectName,'');
  587. open;
  588. AList.Clear;
  589. while not eof do
  590. begin
  591. AList.Append(trim(fieldbyname(AReturnField).asstring));
  592. Next;
  593. end;
  594. end;
  595. qry.free;
  596. end;
  597. function TSQLConnection.RowsAffected(cursor: TSQLCursor): TRowsCount;
  598. begin
  599. Result := -1;
  600. end;
  601. constructor TSQLConnection.Create(AOwner: TComponent);
  602. begin
  603. inherited Create(AOwner);
  604. FSQLFormatSettings:=DefaultSQLFormatSettings;
  605. FFieldNameQuoteChars:=DoubleQuotes;
  606. end;
  607. procedure TSQLConnection.GetTableNames(List: TStrings; SystemTables: Boolean);
  608. begin
  609. if not SystemTables then
  610. GetDBInfo(stTables,'','table_name',List)
  611. else
  612. GetDBInfo(stSysTables,'','table_name',List);
  613. end;
  614. procedure TSQLConnection.GetProcedureNames(List: TStrings);
  615. begin
  616. GetDBInfo(stProcedures,'','proc_name',List);
  617. end;
  618. procedure TSQLConnection.GetFieldNames(const TableName: string; List: TStrings);
  619. begin
  620. GetDBInfo(stColumns,TableName,'column_name',List);
  621. end;
  622. procedure TSQLConnection.GetSchemaNames(List: TStrings);
  623. begin
  624. GetDBInfo(stSchemata,'','SCHEMA_NAME',List);
  625. end;
  626. function TSQLConnection.GetConnectionInfo(InfoType: TConnInfoType): string;
  627. var i: TConnInfoType;
  628. begin
  629. Result:='';
  630. if InfoType = citAll then
  631. for i:=citServerType to citClientVersion do
  632. begin
  633. if Result<>'' then Result:=Result+',';
  634. Result:=Result+'"'+GetConnectionInfo(i)+'"';
  635. end;
  636. end;
  637. function TSQLConnection.GetAsSQLText(Field : TField) : string;
  638. begin
  639. if (not assigned(field)) or field.IsNull then Result := 'Null'
  640. else case field.DataType of
  641. ftString : Result := QuotedStr(Field.AsString);
  642. ftDate : Result := '''' + FormatDateTime('yyyy-mm-dd',Field.AsDateTime,FSqlFormatSettings) + '''';
  643. ftDateTime : Result := '''' + FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz',Field.AsDateTime,FSqlFormatSettings) + '''';
  644. ftTime : Result := QuotedStr(TimeIntervalToString(Field.AsDateTime));
  645. else
  646. Result := field.asstring;
  647. end; {case}
  648. end;
  649. function TSQLConnection.GetAsSQLText(Param: TParam) : string;
  650. begin
  651. if (not assigned(param)) or param.IsNull then Result := 'Null'
  652. else case param.DataType of
  653. ftGuid,
  654. ftMemo,
  655. ftFixedChar,
  656. ftString : Result := QuotedStr(Param.AsString);
  657. ftDate : Result := '''' + FormatDateTime('yyyy-mm-dd',Param.AsDateTime,FSQLFormatSettings) + '''';
  658. ftTime : Result := QuotedStr(TimeIntervalToString(Param.AsDateTime));
  659. ftDateTime : Result := '''' + FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz', Param.AsDateTime, FSQLFormatSettings) + '''';
  660. ftCurrency,
  661. ftBcd : Result := CurrToStr(Param.AsCurrency, FSQLFormatSettings);
  662. ftFloat : Result := FloatToStr(Param.AsFloat, FSQLFormatSettings);
  663. ftFMTBcd : Result := stringreplace(Param.AsString, DefaultFormatSettings.DecimalSeparator, FSQLFormatSettings.DecimalSeparator, []);
  664. else
  665. Result := Param.asstring;
  666. end; {case}
  667. end;
  668. function TSQLConnection.GetHandle: pointer;
  669. begin
  670. Result := nil;
  671. end;
  672. function TSQLConnection.LogEvent(EventType: TDBEventType): Boolean;
  673. begin
  674. Result:=(Assigned(FOnLog) or Assigned(GlobalDBLogHook)) and (EventType in LogEvents);
  675. end;
  676. procedure TSQLConnection.Log(EventType: TDBEventType; const Msg: String);
  677. Var
  678. M : String;
  679. begin
  680. If LogEvent(EventType) then
  681. begin
  682. If Assigned(FonLog) then
  683. FOnLog(Self,EventType,Msg);
  684. If Assigned(GlobalDBLogHook) then
  685. begin
  686. If (Name<>'') then
  687. M:=Name+' : '+Msg
  688. else
  689. M:=ClassName+' : '+Msg;
  690. GlobalDBLogHook(Self,EventType,M);
  691. end;
  692. end;
  693. end;
  694. procedure TSQLConnection.FreeFldBuffers(cursor: TSQLCursor);
  695. begin
  696. // empty
  697. end;
  698. function TSQLConnection.GetSchemaInfoSQL( SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string;
  699. begin
  700. case SchemaType of
  701. stSchemata: Result := 'SELECT * FROM INFORMATION_SCHEMA.SCHEMATA';
  702. else DatabaseError(SMetadataUnavailable);
  703. end;
  704. end;
  705. procedure TSQLConnection.CreateDB;
  706. begin
  707. DatabaseError(SNotSupported);
  708. end;
  709. procedure TSQLConnection.DropDB;
  710. begin
  711. DatabaseError(SNotSupported);
  712. end;
  713. { TSQLTransaction }
  714. procedure TSQLTransaction.EndTransaction;
  715. begin
  716. rollback;
  717. end;
  718. procedure TSQLTransaction.SetParams(const AValue: TStringList);
  719. begin
  720. FParams.Assign(AValue);
  721. end;
  722. function TSQLTransaction.GetHandle: pointer;
  723. begin
  724. Result := TSQLConnection(Database).GetTransactionHandle(FTrans);
  725. end;
  726. procedure TSQLTransaction.Commit;
  727. begin
  728. if active then
  729. begin
  730. closedatasets;
  731. If LogEvent(detCommit) then
  732. Log(detCommit,SCommitting);
  733. if TSQLConnection(Database).commit(FTrans) then
  734. begin
  735. closeTrans;
  736. FreeAndNil(FTrans);
  737. end;
  738. end;
  739. end;
  740. procedure TSQLTransaction.CommitRetaining;
  741. begin
  742. if active then
  743. begin
  744. If LogEvent(detCommit) then
  745. Log(detCommit,SCommitRetaining);
  746. TSQLConnection(Database).commitRetaining(FTrans);
  747. end;
  748. end;
  749. procedure TSQLTransaction.Rollback;
  750. begin
  751. if active then
  752. begin
  753. closedatasets;
  754. If LogEvent(detRollback) then
  755. Log(detRollback,SRollingBack);
  756. if TSQLConnection(Database).RollBack(FTrans) then
  757. begin
  758. CloseTrans;
  759. FreeAndNil(FTrans);
  760. end;
  761. end;
  762. end;
  763. procedure TSQLTransaction.RollbackRetaining;
  764. begin
  765. if active then
  766. begin
  767. If LogEvent(detRollback) then
  768. Log(detRollback,SRollBackRetaining);
  769. TSQLConnection(Database).RollBackRetaining(FTrans);
  770. end;
  771. end;
  772. procedure TSQLTransaction.StartTransaction;
  773. var db : TSQLConnection;
  774. begin
  775. if Active then
  776. DatabaseError(SErrTransAlreadyActive);
  777. db := TSQLConnection(Database);
  778. if Db = nil then
  779. DatabaseError(SErrDatabasenAssigned);
  780. if not Db.Connected then
  781. Db.Open;
  782. if not assigned(FTrans) then FTrans := Db.AllocateTransactionHandle;
  783. if Db.StartdbTransaction(FTrans,FParams.CommaText) then OpenTrans;
  784. end;
  785. constructor TSQLTransaction.Create(AOwner : TComponent);
  786. begin
  787. inherited Create(AOwner);
  788. FParams := TStringList.Create;
  789. end;
  790. destructor TSQLTransaction.Destroy;
  791. begin
  792. Rollback;
  793. FreeAndNil(FParams);
  794. inherited Destroy;
  795. end;
  796. Procedure TSQLTransaction.SetDatabase(Value : TDatabase);
  797. begin
  798. If Value<>Database then
  799. begin
  800. if assigned(value) and not (Value is TSQLConnection) then
  801. DatabaseErrorFmt(SErrNotASQLConnection,[value.Name],self);
  802. CheckInactive;
  803. If Assigned(Database) then
  804. with TSQLConnection(DataBase) do
  805. if Transaction = self then Transaction := nil;
  806. inherited SetDatabase(Value);
  807. If Assigned(Database) and not (csLoading in ComponentState) then
  808. If (TSQLConnection(DataBase).Transaction=Nil) then
  809. TSQLConnection(DataBase).Transaction:=Self;
  810. end;
  811. end;
  812. function TSQLTransaction.LogEvent(EventType: TDBEventType): Boolean;
  813. begin
  814. Result:=Assigned(Database) and TSQLConnection(Database).LogEvent(EventType);
  815. end;
  816. procedure TSQLTransaction.Log(EventType: TDBEventType; const Msg: String);
  817. Var
  818. M : String;
  819. begin
  820. If LogEVent(EventType) then
  821. begin
  822. If (Name<>'') then
  823. M:=Name+' : '+Msg
  824. else
  825. M:=Msg;
  826. TSQLConnection(Database).Log(EventType,M);
  827. end;
  828. end;
  829. { TCustomSQLQuery }
  830. procedure TCustomSQLQuery.OnChangeSQL(Sender : TObject);
  831. var ConnOptions : TConnOptions;
  832. NewParams: TParams;
  833. begin
  834. UnPrepare;
  835. FSchemaType:=stNoSchema;
  836. if (FSQL <> nil) then
  837. begin
  838. if assigned(DataBase) then
  839. ConnOptions := TSQLConnection(DataBase).ConnOptions
  840. else
  841. ConnOptions := [sqEscapeRepeat,sqEscapeSlash];
  842. //preserve existing param. values
  843. NewParams := TParams.Create(Self);
  844. try
  845. NewParams.ParseSQL(FSQL.Text, True, sqEscapeSlash in ConnOptions, sqEscapeRepeat in ConnOptions, psInterbase);
  846. NewParams.AssignValues(FParams);
  847. FParams.Assign(NewParams);
  848. finally
  849. NewParams.Free;
  850. end;
  851. If Assigned(FMasterLink) then
  852. FMasterLink.RefreshParamNames;
  853. end;
  854. end;
  855. function TCustomSQLQuery.ParamByName(Const AParamName : String) : TParam;
  856. begin
  857. Result:=Params.ParamByName(AParamName);
  858. end;
  859. procedure TCustomSQLQuery.OnChangeModifySQL(Sender : TObject);
  860. begin
  861. CheckInactive;
  862. end;
  863. Procedure TCustomSQLQuery.SetTransaction(Value : TDBTransaction);
  864. begin
  865. UnPrepare;
  866. inherited;
  867. If (Transaction<>Nil) and (Database=Nil) then
  868. Database:=TSQLTransaction(Transaction).Database;
  869. end;
  870. procedure TCustomSQLQuery.SetDatabase(Value : TDatabase);
  871. var db : tsqlconnection;
  872. begin
  873. if (Database <> Value) then
  874. begin
  875. if assigned(value) and not (Value is TSQLConnection) then
  876. DatabaseErrorFmt(SErrNotASQLConnection,[value.Name],self);
  877. UnPrepare;
  878. if assigned(FCursor) then TSQLConnection(DataBase).DeAllocateCursorHandle(FCursor);
  879. db := TSQLConnection(Value);
  880. inherited setdatabase(value);
  881. if assigned(value) and (Transaction = nil) and (Assigned(db.Transaction)) then
  882. transaction := Db.Transaction;
  883. OnChangeSQL(Self);
  884. end;
  885. end;
  886. Function TCustomSQLQuery.IsPrepared : Boolean;
  887. begin
  888. Result := Assigned(FCursor) and FCursor.FPrepared;
  889. end;
  890. Function TCustomSQLQuery.AddFilter(SQLstr : string) : string;
  891. begin
  892. if (FWhereStartPos > 0) and (FWhereStopPos > 0) then
  893. begin
  894. system.insert('(',SQLstr,FWhereStartPos+1);
  895. system.insert(')',SQLstr,FWhereStopPos+1);
  896. end;
  897. if FWhereStartPos = 0 then
  898. SQLstr := SQLstr + ' where (' + ServerFilter + ')'
  899. else if FWhereStopPos > 0 then
  900. system.insert(' and ('+ServerFilter+') ',SQLstr,FWhereStopPos+2)
  901. else
  902. system.insert(' where ('+ServerFilter+') ',SQLstr,FWhereStartPos);
  903. Result := SQLstr;
  904. end;
  905. procedure TCustomSQLQuery.ApplyFilter;
  906. var S : String;
  907. begin
  908. FreeFldBuffers;
  909. TSQLConnection(Database).UnPrepareStatement(FCursor);
  910. FIsEOF := False;
  911. inherited internalclose;
  912. s := FSQLBuf;
  913. if ServerFiltered then s := AddFilter(s);
  914. TSQLConnection(Database).PrepareStatement(FCursor,(Transaction as TSQLTransaction),S,FParams);
  915. Execute;
  916. inherited InternalOpen;
  917. First;
  918. end;
  919. Procedure TCustomSQLQuery.SetActive (Value : Boolean);
  920. begin
  921. inherited SetActive(Value);
  922. // The query is UnPrepared, so that if a transaction closes all datasets
  923. // they also get unprepared
  924. if not Value and IsPrepared then UnPrepare;
  925. end;
  926. procedure TCustomSQLQuery.SetServerFiltered(Value: Boolean);
  927. begin
  928. if Value and not FParseSQL then DatabaseErrorFmt(SNoParseSQL,['Filtering ']);
  929. if (ServerFiltered <> Value) then
  930. begin
  931. FServerFiltered := Value;
  932. if active then ApplyFilter;
  933. end;
  934. end;
  935. procedure TCustomSQLQuery.SetServerFilterText(const Value: string);
  936. begin
  937. if Value <> ServerFilter then
  938. begin
  939. FServerFilterText := Value;
  940. if active then ApplyFilter;
  941. end;
  942. end;
  943. procedure TCustomSQLQuery.Prepare;
  944. var
  945. db : tsqlconnection;
  946. sqltr : tsqltransaction;
  947. StmType: TStatementType;
  948. begin
  949. if not IsPrepared then
  950. begin
  951. db := TSQLConnection(Database);
  952. sqltr := (transaction as tsqltransaction);
  953. if not assigned(Db) then
  954. DatabaseError(SErrDatabasenAssigned);
  955. if not assigned(sqltr) then
  956. DatabaseError(SErrTransactionnSet);
  957. if not Db.Connected then db.Open;
  958. if not sqltr.Active then sqltr.StartTransaction;
  959. if FSchemaType=stNoSchema then
  960. FSQLBuf := TrimRight(FSQL.Text)
  961. else
  962. FSQLBuf := db.GetSchemaInfoSQL(FSchemaType, FSchemaObjectName, FSchemaPattern);
  963. if FSQLBuf = '' then
  964. DatabaseError(SErrNoStatement);
  965. StmType:=SQLParser(FSQLBuf);
  966. // There may no error occur between the allocation of the cursor and
  967. // the preparation of the cursor. Because internalclose (which is called in
  968. // case of an exception) assumes that allocated cursors are also prepared,
  969. // and thus calls unprepare.
  970. // A call to unprepare while the cursor is not prepared at all can lead to
  971. // unpredictable results.
  972. if not assigned(FCursor) then
  973. FCursor := Db.AllocateCursorHandle;
  974. FCursor.FSelectable:=True; // let PrepareStatement and/or Execute alter it
  975. FCursor.FStatementType:=StmType;
  976. FCursor.FSchemaType := FSchemaType;
  977. if ServerFiltered then
  978. begin
  979. If LogEvent(detPrepare) then
  980. Log(detPrepare,AddFilter(FSQLBuf));
  981. Db.PrepareStatement(FCursor,sqltr,AddFilter(FSQLBuf),FParams)
  982. end
  983. else
  984. begin
  985. If LogEvent(detPrepare) then
  986. Log(detPrepare,FSQLBuf);
  987. Db.PrepareStatement(FCursor,sqltr,FSQLBuf,FParams);
  988. end;
  989. FCursor.FInitFieldDef := FCursor.FSelectable;
  990. end;
  991. end;
  992. procedure TCustomSQLQuery.UnPrepare;
  993. begin
  994. CheckInactive;
  995. if IsPrepared then with TSQLConnection(DataBase) do
  996. UnPrepareStatement(FCursor);
  997. end;
  998. procedure TCustomSQLQuery.FreeFldBuffers;
  999. begin
  1000. if assigned(FCursor) then TSQLConnection(Database).FreeFldBuffers(FCursor);
  1001. end;
  1002. function TCustomSQLQuery.GetServerIndexDefs: TServerIndexDefs;
  1003. begin
  1004. Result := FServerIndexDefs;
  1005. end;
  1006. function TCustomSQLQuery.Fetch : boolean;
  1007. begin
  1008. if not FCursor.FSelectable then
  1009. Exit;
  1010. if not FIsEof then FIsEOF := not TSQLConnection(Database).Fetch(FCursor);
  1011. Result := not FIsEOF;
  1012. end;
  1013. procedure TCustomSQLQuery.Execute;
  1014. begin
  1015. If (FParams.Count>0) and Assigned(FMasterLink) then
  1016. FMasterLink.CopyParamsFromMaster(False);
  1017. If LogEvent(detExecute) then
  1018. Log(detExecute,FSQLBuf);
  1019. TSQLConnection(Database).Execute(FCursor,Transaction as TSQLTransaction, FParams);
  1020. end;
  1021. function TCustomSQLQuery.LoadField(FieldDef : TFieldDef;buffer : pointer; out CreateBlob : boolean) : boolean;
  1022. begin
  1023. result := TSQLConnection(Database).LoadField(FCursor,FieldDef,buffer, Createblob)
  1024. end;
  1025. function TCustomSQLQuery.RowsAffected: TRowsCount;
  1026. begin
  1027. Result := -1;
  1028. if not Assigned(Database) then Exit;
  1029. //assert(Database is TSQLConnection);
  1030. Result := TSQLConnection(Database).RowsAffected(FCursor);
  1031. end;
  1032. procedure TCustomSQLQuery.InternalAddRecord(Buffer: Pointer; AAppend: Boolean);
  1033. begin
  1034. // not implemented - sql dataset
  1035. end;
  1036. procedure TCustomSQLQuery.InternalClose;
  1037. begin
  1038. if not IsReadFromPacket then
  1039. begin
  1040. if assigned(FCursor) and FCursor.FSelectable then FreeFldBuffers;
  1041. // Database and FCursor could be nil, for example if the database is not assigned, and .open is called
  1042. if (not IsPrepared) and (assigned(database)) and (assigned(FCursor)) then TSQLConnection(database).UnPrepareStatement(FCursor);
  1043. end;
  1044. if DefaultFields then
  1045. DestroyFields;
  1046. FIsEOF := False;
  1047. if assigned(FUpdateQry) then FreeAndNil(FUpdateQry);
  1048. if assigned(FInsertQry) then FreeAndNil(FInsertQry);
  1049. if assigned(FDeleteQry) then FreeAndNil(FDeleteQry);
  1050. // FRecordSize := 0;
  1051. inherited internalclose;
  1052. end;
  1053. procedure TCustomSQLQuery.InternalInitFieldDefs;
  1054. begin
  1055. if FLoadingFieldDefs then
  1056. Exit;
  1057. FLoadingFieldDefs := True;
  1058. try
  1059. FieldDefs.Clear;
  1060. if not Assigned(Database) then DatabaseError(SErrDatabasenAssigned);
  1061. TSQLConnection(Database).AddFieldDefs(FCursor,FieldDefs);
  1062. finally
  1063. FLoadingFieldDefs := False;
  1064. if Assigned(FCursor) then FCursor.FInitFieldDef := false;
  1065. end;
  1066. end;
  1067. function TCustomSQLQuery.SQLParser(const ASQL : string) : TStatementType;
  1068. type TParsePart = (ppStart,ppWith,ppSelect,ppTableName,ppFrom,ppWhere,ppGroup,ppOrder,ppBogus);
  1069. TPhraseSeparator = (sepNone, sepWhiteSpace, sepComma, sepComment, sepParentheses, sepDoubleQuote, sepEnd);
  1070. TKeyword = (kwWITH, kwSELECT, kwINSERT, kwUPDATE, kwDELETE, kwFROM, kwJOIN, kwWHERE, kwGROUP, kwORDER, kwUNION, kwROWS, kwLIMIT, kwUnknown);
  1071. const
  1072. KeywordNames: array[TKeyword] of string =
  1073. ('WITH', 'SELECT', 'INSERT', 'UPDATE', 'DELETE', 'FROM', 'JOIN', 'WHERE', 'GROUP', 'ORDER', 'UNION', 'ROWS', 'LIMIT', '');
  1074. var
  1075. PSQL, CurrentP, SavedP,
  1076. PhraseP, PStatementPart : pchar;
  1077. S : string;
  1078. ParsePart : TParsePart;
  1079. BracketCount : Integer;
  1080. ConnOptions : TConnOptions;
  1081. Separator : TPhraseSeparator;
  1082. Keyword, K : TKeyword;
  1083. begin
  1084. PSQL:=Pchar(ASQL);
  1085. ParsePart := ppStart;
  1086. CurrentP := PSQL-1;
  1087. PhraseP := PSQL;
  1088. FTableName := '';
  1089. FUpdateable := False;
  1090. FWhereStartPos := 0;
  1091. FWhereStopPos := 0;
  1092. ConnOptions := TSQLConnection(DataBase).ConnOptions;
  1093. repeat
  1094. begin
  1095. inc(CurrentP);
  1096. SavedP := CurrentP;
  1097. case CurrentP^ of
  1098. ' ', #9..#13:
  1099. Separator := sepWhiteSpace;
  1100. ',':
  1101. Separator := sepComma;
  1102. #0, ';':
  1103. Separator := sepEnd;
  1104. '(':
  1105. begin
  1106. Separator := sepParentheses;
  1107. // skip everything between brackets, since it could be a sub-select, and
  1108. // further nothing between brackets could be interesting for the parser.
  1109. BracketCount := 1;
  1110. repeat
  1111. inc(CurrentP);
  1112. if CurrentP^ = '(' then inc(BracketCount)
  1113. else if CurrentP^ = ')' then dec(BracketCount);
  1114. until (CurrentP^ = #0) or (BracketCount = 0);
  1115. if CurrentP^ <> #0 then inc(CurrentP);
  1116. end;
  1117. '"':
  1118. if SkipComments(CurrentP, sqEscapeSlash in ConnOptions, sqEscapeRepeat in ConnOptions) then
  1119. Separator := sepDoubleQuote;
  1120. else
  1121. if SkipComments(CurrentP, sqEscapeSlash in ConnOptions, sqEscapeRepeat in ConnOptions) then
  1122. Separator := sepComment
  1123. else
  1124. Separator := sepNone;
  1125. end;
  1126. if (CurrentP > SavedP) and (SavedP > PhraseP) then
  1127. CurrentP := SavedP; // there is something before comment or left parenthesis
  1128. if Separator <> sepNone then
  1129. begin
  1130. if ((Separator in [sepWhitespace,sepComment]) and (PhraseP = SavedP)) then
  1131. PhraseP := CurrentP; // skip comments(but not parentheses) and white spaces
  1132. if (CurrentP-PhraseP > 0) or (Separator = sepEnd) then
  1133. begin
  1134. SetString(s, PhraseP, CurrentP-PhraseP);
  1135. Keyword := kwUnknown;
  1136. for K in TKeyword do
  1137. if SameText(s, KeywordNames[K]) then
  1138. begin
  1139. Keyword := K;
  1140. break;
  1141. end;
  1142. case ParsePart of
  1143. ppStart : begin
  1144. Result := TSQLConnection(Database).StrToStatementType(s);
  1145. case Keyword of
  1146. kwWITH : ParsePart := ppWith;
  1147. kwSELECT: ParsePart := ppSelect;
  1148. else break;
  1149. end;
  1150. if not FParseSQL then break;
  1151. end;
  1152. ppWith : begin
  1153. // WITH [RECURSIVE] CTE_name [ ( column_names ) ] AS ( CTE_query_definition ) [, ...]
  1154. // { SELECT | INSERT | UPDATE | DELETE } ...
  1155. case Keyword of
  1156. kwSELECT: Result := stSelect;
  1157. kwINSERT: Result := stInsert;
  1158. kwUPDATE: Result := stUpdate;
  1159. kwDELETE: Result := stDelete;
  1160. end;
  1161. if Result <> stUnknown then break;
  1162. end;
  1163. ppSelect : begin
  1164. if Keyword = kwFROM then
  1165. ParsePart := ppTableName;
  1166. end;
  1167. ppTableName:
  1168. begin
  1169. // Meta-data requests are never updateable
  1170. // and select-statements from more then one table
  1171. // and/or derived tables are also not updateable
  1172. if (FSchemaType = stNoSchema) and
  1173. (Separator in [sepWhitespace, sepComment, sepDoubleQuote, sepEnd]) then
  1174. begin
  1175. FTableName := s;
  1176. FUpdateable := True;
  1177. end;
  1178. ParsePart := ppFrom;
  1179. end;
  1180. ppFrom : begin
  1181. if (Keyword in [kwWHERE, kwGROUP, kwORDER, kwLIMIT, kwROWS]) or
  1182. (Separator = sepEnd) then
  1183. begin
  1184. case Keyword of
  1185. kwWHERE: ParsePart := ppWhere;
  1186. kwGROUP: ParsePart := ppGroup;
  1187. kwORDER: ParsePart := ppOrder;
  1188. else ParsePart := ppBogus;
  1189. end;
  1190. FWhereStartPos := PhraseP-PSQL+1;
  1191. PStatementPart := CurrentP;
  1192. end
  1193. else
  1194. // joined table or user_defined_function (...)
  1195. if (Keyword = kwJOIN) or (Separator in [sepComma, sepParentheses]) then
  1196. begin
  1197. FTableName := '';
  1198. FUpdateable := False;
  1199. end;
  1200. end;
  1201. ppWhere : begin
  1202. if (Keyword in [kwGROUP, kwORDER, kwLIMIT, kwROWS]) or
  1203. (Separator = sepEnd) then
  1204. begin
  1205. ParsePart := ppBogus;
  1206. FWhereStartPos := PStatementPart-PSQL;
  1207. if (Separator = sepEnd) then
  1208. FWhereStopPos := CurrentP-PSQL+1
  1209. else
  1210. FWhereStopPos := PhraseP-PSQL+1;
  1211. end
  1212. else if (Keyword = kwUNION) then
  1213. begin
  1214. ParsePart := ppBogus;
  1215. FUpdateable := False;
  1216. end;
  1217. end;
  1218. end; {case}
  1219. end;
  1220. if Separator in [sepComment, sepParentheses, sepDoubleQuote] then
  1221. dec(CurrentP);
  1222. PhraseP := CurrentP+1;
  1223. end
  1224. end;
  1225. until CurrentP^=#0;
  1226. end;
  1227. procedure TCustomSQLQuery.InternalOpen;
  1228. var tel, fieldc : integer;
  1229. f : TField;
  1230. IndexFields : TStrings;
  1231. ReadFromFile: Boolean;
  1232. begin
  1233. ReadFromFile:=IsReadFromPacket;
  1234. if ReadFromFile then
  1235. begin
  1236. if not assigned(FCursor) then
  1237. FCursor := TSQLConnection(Database).AllocateCursorHandle;
  1238. FCursor.FSelectable:=True;
  1239. FCursor.FStatementType:=stSelect;
  1240. FUpdateable:=True;
  1241. end
  1242. else
  1243. Prepare;
  1244. if not FCursor.FSelectable then
  1245. DatabaseError(SErrNoSelectStatement,Self);
  1246. if not ReadFromFile then
  1247. begin
  1248. // Call UpdateServerIndexDefs before Execute, to avoid problems with connections
  1249. // which do not allow processing multiple recordsets at a time. (Microsoft
  1250. // calls this MARS, see bug 13241)
  1251. if DefaultFields and FUpdateable and FusePrimaryKeyAsKey and (not IsUniDirectional) then
  1252. UpdateServerIndexDefs;
  1253. Execute;
  1254. if not FCursor.FSelectable then
  1255. DatabaseError(SErrNoSelectStatement,Self);
  1256. // InternalInitFieldDef is only called after a prepare. i.e. not twice if
  1257. // a dataset is opened - closed - opened.
  1258. if FCursor.FInitFieldDef then InternalInitFieldDefs;
  1259. if DefaultFields then
  1260. begin
  1261. CreateFields;
  1262. if FUpdateable and (not IsUniDirectional) then
  1263. begin
  1264. if FusePrimaryKeyAsKey then
  1265. begin
  1266. for tel := 0 to ServerIndexDefs.count-1 do
  1267. begin
  1268. if ixPrimary in ServerIndexDefs[tel].options then
  1269. begin
  1270. IndexFields := TStringList.Create;
  1271. ExtractStrings([';'],[' '],pchar(ServerIndexDefs[tel].fields),IndexFields);
  1272. for fieldc := 0 to IndexFields.Count-1 do
  1273. begin
  1274. F := Findfield(IndexFields[fieldc]);
  1275. if F <> nil then
  1276. F.ProviderFlags := F.ProviderFlags + [pfInKey];
  1277. end;
  1278. IndexFields.Free;
  1279. end;
  1280. end;
  1281. end;
  1282. end;
  1283. end
  1284. else
  1285. BindFields(True);
  1286. end
  1287. else
  1288. BindFields(True);
  1289. if not ReadOnly and not FUpdateable and (FSchemaType=stNoSchema) then
  1290. begin
  1291. if (trim(FDeleteSQL.Text) <> '') or (trim(FUpdateSQL.Text) <> '') or
  1292. (trim(FInsertSQL.Text) <> '') then FUpdateable := True;
  1293. end;
  1294. inherited InternalOpen;
  1295. end;
  1296. // public part
  1297. procedure TCustomSQLQuery.ExecSQL;
  1298. begin
  1299. try
  1300. Prepare;
  1301. Execute;
  1302. finally
  1303. // FCursor has to be assigned, or else the prepare went wrong before PrepareStatment was
  1304. // called, so UnPrepareStatement shoudn't be called either
  1305. if (not IsPrepared) and (assigned(database)) and (assigned(FCursor)) then TSQLConnection(database).UnPrepareStatement(FCursor);
  1306. end;
  1307. end;
  1308. constructor TCustomSQLQuery.Create(AOwner : TComponent);
  1309. begin
  1310. inherited Create(AOwner);
  1311. FParams := TParams.create(self);
  1312. FSQL := TStringList.Create;
  1313. FSQL.OnChange := @OnChangeSQL;
  1314. FUpdateSQL := TStringList.Create;
  1315. FUpdateSQL.OnChange := @OnChangeModifySQL;
  1316. FInsertSQL := TStringList.Create;
  1317. FInsertSQL.OnChange := @OnChangeModifySQL;
  1318. FDeleteSQL := TStringList.Create;
  1319. FDeleteSQL.OnChange := @OnChangeModifySQL;
  1320. FServerIndexDefs := TServerIndexDefs.Create(Self);
  1321. FParseSQL := True;
  1322. FServerFiltered := False;
  1323. FServerFilterText := '';
  1324. FSchemaType:=stNoSchema;
  1325. FSchemaObjectName:='';
  1326. FSchemaPattern:='';
  1327. // Delphi has upWhereAll as default, but since strings and oldvalue's don't work yet
  1328. // (variants) set it to upWhereKeyOnly
  1329. FUpdateMode := upWhereKeyOnly;
  1330. FUsePrimaryKeyAsKey := True;
  1331. end;
  1332. destructor TCustomSQLQuery.Destroy;
  1333. begin
  1334. if Active then Close;
  1335. UnPrepare;
  1336. if assigned(FCursor) then TSQLConnection(Database).DeAllocateCursorHandle(FCursor);
  1337. FreeAndNil(FMasterLink);
  1338. FreeAndNil(FParams);
  1339. FreeAndNil(FSQL);
  1340. FreeAndNil(FInsertSQL);
  1341. FreeAndNil(FDeleteSQL);
  1342. FreeAndNil(FUpdateSQL);
  1343. FServerIndexDefs.Free;
  1344. inherited Destroy;
  1345. end;
  1346. procedure TCustomSQLQuery.SetReadOnly(AValue : Boolean);
  1347. begin
  1348. CheckInactive;
  1349. inherited SetReadOnly(AValue);
  1350. end;
  1351. procedure TCustomSQLQuery.SetParseSQL(AValue : Boolean);
  1352. begin
  1353. CheckInactive;
  1354. if not AValue then
  1355. begin
  1356. FServerFiltered := False;
  1357. FParseSQL := False;
  1358. end
  1359. else
  1360. FParseSQL := True;
  1361. end;
  1362. procedure TCustomSQLQuery.SetSQL(const AValue: TStringlist);
  1363. begin
  1364. FSQL.Assign(AValue);
  1365. end;
  1366. procedure TCustomSQLQuery.SetUpdateSQL(const AValue: TStringlist);
  1367. begin
  1368. FUpdateSQL.Assign(AValue);
  1369. end;
  1370. procedure TCustomSQLQuery.SetUsePrimaryKeyAsKey(AValue : Boolean);
  1371. begin
  1372. if not Active then FusePrimaryKeyAsKey := AValue
  1373. else
  1374. begin
  1375. // Just temporary, this should be possible in the future
  1376. DatabaseError(SActiveDataset);
  1377. end;
  1378. end;
  1379. Procedure TCustomSQLQuery.UpdateServerIndexDefs;
  1380. begin
  1381. FServerIndexDefs.Clear;
  1382. if assigned(DataBase) and (FTableName<>'') then
  1383. TSQLConnection(DataBase).UpdateIndexDefs(ServerIndexDefs,FTableName);
  1384. end;
  1385. Procedure TCustomSQLQuery.ApplyRecUpdate(UpdateKind : TUpdateKind);
  1386. var FieldNamesQuoteChars : TQuoteChars;
  1387. function InitialiseModifyQuery(var qry : TCustomSQLQuery): TCustomSQLQuery;
  1388. begin
  1389. if not assigned(qry) then
  1390. begin
  1391. qry := TCustomSQLQuery.Create(nil);
  1392. qry.ParseSQL := False;
  1393. qry.DataBase := Self.DataBase;
  1394. qry.Transaction := Self.Transaction;
  1395. end;
  1396. Result:=qry;
  1397. end;
  1398. procedure UpdateWherePart(var sql_where : string;x : integer);
  1399. begin
  1400. if (pfInKey in Fields[x].ProviderFlags) or
  1401. ((FUpdateMode = upWhereAll) and (pfInWhere in Fields[x].ProviderFlags)) or
  1402. ((FUpdateMode = UpWhereChanged) and (pfInWhere in Fields[x].ProviderFlags) and (Fields[x].Value <> Fields[x].OldValue)) then
  1403. if Fields[x].OldValue = NULL then
  1404. sql_where := sql_where + FieldNamesQuoteChars[0] + Fields[x].FieldName + FieldNamesQuoteChars[1] + ' is null and '
  1405. else
  1406. sql_where := sql_where + '(' + FieldNamesQuoteChars[0] + Fields[x].FieldName + FieldNamesQuoteChars[1] + '= :"' + 'OLD_' + Fields[x].FieldName + '") and ';
  1407. end;
  1408. function ModifyRecQuery : string;
  1409. var x : integer;
  1410. sql_set : string;
  1411. sql_where : string;
  1412. begin
  1413. sql_set := '';
  1414. sql_where := '';
  1415. for x := 0 to Fields.Count -1 do
  1416. begin
  1417. UpdateWherePart(sql_where,x);
  1418. if (pfInUpdate in Fields[x].ProviderFlags) and (not Fields[x].ReadOnly) then
  1419. sql_set := sql_set +FieldNamesQuoteChars[0] + fields[x].FieldName + FieldNamesQuoteChars[1] +'=:"' + fields[x].FieldName + '",';
  1420. end;
  1421. if length(sql_set) = 0 then DatabaseErrorFmt(sNoUpdateFields,['update'],self);
  1422. setlength(sql_set,length(sql_set)-1);
  1423. if length(sql_where) = 0 then DatabaseErrorFmt(sNoWhereFields,['update'],self);
  1424. setlength(sql_where,length(sql_where)-5);
  1425. result := 'update ' + FTableName + ' set ' + sql_set + ' where ' + sql_where;
  1426. end;
  1427. function InsertRecQuery : string;
  1428. var x : integer;
  1429. sql_fields : string;
  1430. sql_values : string;
  1431. begin
  1432. sql_fields := '';
  1433. sql_values := '';
  1434. for x := 0 to Fields.Count -1 do
  1435. begin
  1436. if (not Fields[x].IsNull) and (pfInUpdate in Fields[x].ProviderFlags) and (not Fields[x].ReadOnly) then
  1437. begin
  1438. sql_fields := sql_fields + FieldNamesQuoteChars[0] + fields[x].FieldName + FieldNamesQuoteChars[1] + ',';
  1439. sql_values := sql_values + ':"' + fields[x].FieldName + '",';
  1440. end;
  1441. end;
  1442. if length(sql_fields) = 0 then DatabaseErrorFmt(sNoUpdateFields,['insert'],self);
  1443. setlength(sql_fields,length(sql_fields)-1);
  1444. setlength(sql_values,length(sql_values)-1);
  1445. result := 'insert into ' + FTableName + ' (' + sql_fields + ') values (' + sql_values + ')';
  1446. end;
  1447. function DeleteRecQuery : string;
  1448. var x : integer;
  1449. sql_where : string;
  1450. begin
  1451. sql_where := '';
  1452. for x := 0 to Fields.Count -1 do
  1453. UpdateWherePart(sql_where,x);
  1454. if length(sql_where) = 0 then DatabaseErrorFmt(sNoWhereFields,['delete'],self);
  1455. setlength(sql_where,length(sql_where)-5);
  1456. result := 'delete from ' + FTableName + ' where ' + sql_where;
  1457. end;
  1458. var qry : TCustomSQLQuery;
  1459. s : string;
  1460. x : integer;
  1461. Fld : TField;
  1462. begin
  1463. FieldNamesQuoteChars := TSQLConnection(DataBase).FieldNameQuoteChars;
  1464. case UpdateKind of
  1465. ukInsert : begin
  1466. s := trim(FInsertSQL.Text);
  1467. if s = '' then s := InsertRecQuery;
  1468. qry := InitialiseModifyQuery(FInsertQry);
  1469. end;
  1470. ukModify : begin
  1471. s := trim(FUpdateSQL.Text);
  1472. if (s='') and (not assigned(FUpdateQry) or (UpdateMode<>upWhereKeyOnly)) then //first time or dynamic where part
  1473. s := ModifyRecQuery;
  1474. qry := InitialiseModifyQuery(FUpdateQry);
  1475. end;
  1476. ukDelete : begin
  1477. s := trim(FDeleteSQL.Text);
  1478. if (s='') and (not assigned(FDeleteQry) or (UpdateMode<>upWhereKeyOnly)) then
  1479. s := DeleteRecQuery;
  1480. qry := InitialiseModifyQuery(FDeleteQry);
  1481. end;
  1482. end;
  1483. if (qry.SQL.Text<>s) and (s<>'') then qry.SQL.Text:=s; //assign only when changed, to avoid UnPrepare/Prepare
  1484. assert(qry.sql.Text<>'');
  1485. with qry do
  1486. begin
  1487. for x := 0 to Params.Count-1 do with params[x] do if sametext(leftstr(name,4),'OLD_') then
  1488. begin
  1489. Fld := self.FieldByName(copy(name,5,length(name)-4));
  1490. AssignFieldValue(Fld,Fld.OldValue);
  1491. end
  1492. else
  1493. begin
  1494. Fld := self.FieldByName(name);
  1495. AssignFieldValue(Fld,Fld.Value);
  1496. end;
  1497. execsql;
  1498. end;
  1499. end;
  1500. Function TCustomSQLQuery.GetCanModify: Boolean;
  1501. begin
  1502. // the test for assigned(FCursor) is needed for the case that the dataset isn't opened
  1503. if assigned(FCursor) and (FCursor.FStatementType = stSelect) then
  1504. Result:= FUpdateable and (not ReadOnly) and (not IsUniDirectional)
  1505. else
  1506. Result := False;
  1507. end;
  1508. procedure TCustomSQLQuery.SetUpdateMode(AValue : TUpdateMode);
  1509. begin
  1510. FUpdateMode := AValue;
  1511. end;
  1512. procedure TCustomSQLQuery.SetSchemaInfo( ASchemaType : TSchemaType; ASchemaObjectName, ASchemaPattern : string);
  1513. begin
  1514. FSchemaType:=ASchemaType;
  1515. FSchemaObjectName:=ASchemaObjectName;
  1516. FSchemaPattern:=ASchemaPattern;
  1517. end;
  1518. procedure TCustomSQLQuery.LoadBlobIntoBuffer(FieldDef: TFieldDef;
  1519. ABlobBuf: PBufBlobField);
  1520. begin
  1521. TSQLConnection(DataBase).LoadBlobIntoBuffer(FieldDef, ABlobBuf, FCursor,(Transaction as TSQLTransaction));
  1522. end;
  1523. procedure TCustomSQLQuery.BeforeRefreshOpenCursor;
  1524. begin
  1525. // This is only necessary because TIBConnection can not re-open a
  1526. // prepared cursor. In fact this is wrong, but has never led to
  1527. // problems because in SetActive(false) queries are always
  1528. // unprepared. (which is also wrong, but has to be fixed later)
  1529. if IsPrepared then with TSQLConnection(DataBase) do
  1530. UnPrepareStatement(FCursor);
  1531. end;
  1532. function TCustomSQLQuery.LogEvent(EventType: TDBEventType): Boolean;
  1533. begin
  1534. Result:=Assigned(Database) and TSQLConnection(Database).LogEvent(EventType);
  1535. end;
  1536. procedure TCustomSQLQuery.Log(EventType: TDBEventType; const Msg: String);
  1537. Var
  1538. M : String;
  1539. begin
  1540. If LogEvent(EventType) then
  1541. begin
  1542. M:=Msg;
  1543. If (Name<>'') then
  1544. M:=Name+' : '+M;
  1545. TSQLConnection(Database).Log(EventType,M);
  1546. end;
  1547. end;
  1548. function TCustomSQLQuery.GetStatementType : TStatementType;
  1549. begin
  1550. if assigned(FCursor) then
  1551. Result := FCursor.FStatementType
  1552. else
  1553. Result := stUnknown;
  1554. end;
  1555. procedure TCustomSQLQuery.SetDeleteSQL(const AValue: TStringlist);
  1556. begin
  1557. FDeleteSQL.Assign(AValue);
  1558. end;
  1559. procedure TCustomSQLQuery.SetInsertSQL(const AValue: TStringlist);
  1560. begin
  1561. FInsertSQL.Assign(AValue);
  1562. end;
  1563. Procedure TCustomSQLQuery.SetDataSource(AValue : TDatasource);
  1564. Var
  1565. DS : TDatasource;
  1566. begin
  1567. DS:=DataSource;
  1568. If (AValue<>DS) then
  1569. begin
  1570. If Assigned(AValue) and (AValue.Dataset=Self) then
  1571. DatabaseError(SErrCircularDataSourceReferenceNotAllowed,Self);
  1572. If Assigned(DS) then
  1573. DS.RemoveFreeNotification(Self);
  1574. If Assigned(AValue) then
  1575. begin
  1576. AValue.FreeNotification(Self);
  1577. If (FMasterLink=Nil) then
  1578. FMasterLink:=TMasterParamsDataLink.Create(Self);
  1579. FMasterLink.Datasource:=AValue;
  1580. end
  1581. else
  1582. FreeAndNil(FMasterLink);
  1583. end;
  1584. end;
  1585. Function TCustomSQLQuery.GetDataSource : TDatasource;
  1586. begin
  1587. If Assigned(FMasterLink) then
  1588. Result:=FMasterLink.DataSource
  1589. else
  1590. Result:=Nil;
  1591. end;
  1592. procedure TCustomSQLQuery.Notification(AComponent: TComponent; Operation: TOperation);
  1593. begin
  1594. Inherited;
  1595. If (Operation=opRemove) and (AComponent=DataSource) then
  1596. DataSource:=Nil;
  1597. end;
  1598. { TSQLScript }
  1599. procedure TSQLScript.ExecuteStatement(SQLStatement: TStrings;
  1600. var StopExecution: Boolean);
  1601. begin
  1602. fquery.SQL.assign(SQLStatement);
  1603. fquery.ExecSQL;
  1604. end;
  1605. procedure TSQLScript.ExecuteDirective(Directive, Argument: String;
  1606. var StopExecution: Boolean);
  1607. begin
  1608. if assigned (FOnDirective) then
  1609. FOnDirective (Self, Directive, Argument, StopExecution);
  1610. end;
  1611. procedure TSQLScript.ExecuteCommit;
  1612. begin
  1613. if FTransaction is TSQLTransaction then
  1614. TSQLTransaction(FTransaction).CommitRetaining
  1615. else
  1616. begin
  1617. FTransaction.Active := false;
  1618. FTransaction.Active := true;
  1619. end;
  1620. end;
  1621. procedure TSQLScript.SetDatabase(Value: TDatabase);
  1622. begin
  1623. FDatabase := Value;
  1624. end;
  1625. procedure TSQLScript.SetTransaction(Value: TDBTransaction);
  1626. begin
  1627. FTransaction := Value;
  1628. end;
  1629. procedure TSQLScript.CheckDatabase;
  1630. begin
  1631. If (FDatabase=Nil) then
  1632. DatabaseError(SErrNoDatabaseAvailable,Self)
  1633. end;
  1634. constructor TSQLScript.Create(AOwner: TComponent);
  1635. begin
  1636. inherited Create(AOwner);
  1637. FQuery := TCustomSQLQuery.Create(nil);
  1638. end;
  1639. destructor TSQLScript.Destroy;
  1640. begin
  1641. FQuery.Free;
  1642. inherited Destroy;
  1643. end;
  1644. procedure TSQLScript.Execute;
  1645. begin
  1646. FQuery.DataBase := FDatabase;
  1647. FQuery.Transaction := FTransaction;
  1648. inherited Execute;
  1649. end;
  1650. procedure TSQLScript.ExecuteScript;
  1651. begin
  1652. Execute;
  1653. end;
  1654. { Connection definitions }
  1655. Var
  1656. ConnDefs : TStringList;
  1657. Procedure CheckDefs;
  1658. begin
  1659. If (ConnDefs=Nil) then
  1660. begin
  1661. ConnDefs:=TStringList.Create;
  1662. ConnDefs.Sorted:=True;
  1663. ConnDefs.Duplicates:=dupError;
  1664. end;
  1665. end;
  1666. Procedure DoneDefs;
  1667. Var
  1668. I : Integer;
  1669. begin
  1670. If Assigned(ConnDefs) then
  1671. begin
  1672. For I:=ConnDefs.Count-1 downto 0 do
  1673. begin
  1674. ConnDefs.Objects[i].Free;
  1675. ConnDefs.Delete(I);
  1676. end;
  1677. FreeAndNil(ConnDefs);
  1678. end;
  1679. end;
  1680. Function GetConnectionDef(ConnectorName : String) : TConnectionDef;
  1681. Var
  1682. I : Integer;
  1683. begin
  1684. CheckDefs;
  1685. I:=ConnDefs.IndexOf(ConnectorName);
  1686. If (I<>-1) then
  1687. Result:=TConnectionDef(ConnDefs.Objects[i])
  1688. else
  1689. Result:=Nil;
  1690. end;
  1691. procedure RegisterConnection(Def: TConnectionDefClass);
  1692. Var
  1693. I : Integer;
  1694. begin
  1695. CheckDefs;
  1696. I:=ConnDefs.IndexOf(Def.TypeName);
  1697. If (I=-1) then
  1698. ConnDefs.AddObject(Def.TypeName,Def.Create)
  1699. else
  1700. begin
  1701. ConnDefs.Objects[I].Free;
  1702. ConnDefs.Objects[I]:=Def.Create;
  1703. end;
  1704. end;
  1705. procedure UnRegisterConnection(Def: TConnectionDefClass);
  1706. begin
  1707. UnRegisterConnection(Def.TypeName);
  1708. end;
  1709. procedure UnRegisterConnection(ConnectionName: String);
  1710. Var
  1711. I : Integer;
  1712. begin
  1713. if (ConnDefs<>Nil) then
  1714. begin
  1715. I:=ConnDefs.IndexOf(ConnectionName);
  1716. If (I<>-1) then
  1717. begin
  1718. ConnDefs.Objects[I].Free;
  1719. ConnDefs.Delete(I);
  1720. end;
  1721. end;
  1722. end;
  1723. procedure GetConnectionList(List: TSTrings);
  1724. begin
  1725. CheckDefs;
  1726. List.Text:=ConnDefs.Text;
  1727. end;
  1728. { TSQLConnector }
  1729. procedure TSQLConnector.SetConnectorType(const AValue: String);
  1730. begin
  1731. if FConnectorType<>AValue then
  1732. begin
  1733. CheckDisconnected;
  1734. If Assigned(FProxy) then
  1735. FreeProxy;
  1736. FConnectorType:=AValue;
  1737. end;
  1738. end;
  1739. procedure TSQLConnector.SetTransaction(Value: TSQLTransaction);
  1740. begin
  1741. inherited SetTransaction(Value);
  1742. If Assigned(FProxy) and (FProxy.Transaction<>Value) then
  1743. FProxy.FTransaction:=Value;
  1744. end;
  1745. procedure TSQLConnector.DoInternalConnect;
  1746. Var
  1747. D : TConnectionDef;
  1748. begin
  1749. inherited DoInternalConnect;
  1750. CreateProxy;
  1751. FProxy.CharSet:=Self.CharSet;
  1752. FProxy.Role:=Self.Role;
  1753. FProxy.DatabaseName:=Self.DatabaseName;
  1754. FProxy.HostName:=Self.HostName;
  1755. FProxy.UserName:=Self.UserName;
  1756. FProxy.Password:=Self.Password;
  1757. FProxy.FTransaction:=Self.Transaction;
  1758. D:=GetConnectionDef(ConnectorType);
  1759. D.ApplyParams(Params,FProxy);
  1760. FProxy.Connected:=True;
  1761. end;
  1762. procedure TSQLConnector.DoInternalDisconnect;
  1763. begin
  1764. FProxy.Connected:=False;
  1765. inherited DoInternalDisconnect;
  1766. end;
  1767. procedure TSQLConnector.CheckProxy;
  1768. begin
  1769. If (FProxy=Nil) then
  1770. CreateProxy;
  1771. end;
  1772. procedure TSQLConnector.CreateProxy;
  1773. Var
  1774. D : TConnectionDef;
  1775. begin
  1776. D:=GetConnectionDef(ConnectorType);
  1777. If (D=Nil) then
  1778. DatabaseErrorFmt(SErrUnknownConnectorType,[ConnectorType],Self);
  1779. FProxy:=D.ConnectionClass.Create(Self);
  1780. FFieldNameQuoteChars := FProxy.FieldNameQuoteChars;
  1781. end;
  1782. procedure TSQLConnector.FreeProxy;
  1783. begin
  1784. FProxy.Connected:=False;
  1785. FreeAndNil(FProxy);
  1786. end;
  1787. function TSQLConnector.StrToStatementType(s: string): TStatementType;
  1788. begin
  1789. CheckProxy;
  1790. Result:=FProxy.StrToStatementType(s);
  1791. end;
  1792. function TSQLConnector.GetAsSQLText(Field: TField): string;
  1793. begin
  1794. CheckProxy;
  1795. Result:=FProxy.GetAsSQLText(Field);
  1796. end;
  1797. function TSQLConnector.GetAsSQLText(Param: TParam): string;
  1798. begin
  1799. CheckProxy;
  1800. Result:=FProxy.GetAsSQLText(Param);
  1801. end;
  1802. function TSQLConnector.GetHandle: pointer;
  1803. begin
  1804. CheckProxy;
  1805. Result:=FProxy.GetHandle;
  1806. end;
  1807. function TSQLConnector.AllocateCursorHandle: TSQLCursor;
  1808. begin
  1809. CheckProxy;
  1810. Result:=FProxy.AllocateCursorHandle;
  1811. end;
  1812. procedure TSQLConnector.DeAllocateCursorHandle(var cursor: TSQLCursor);
  1813. begin
  1814. CheckProxy;
  1815. FProxy.DeAllocateCursorHandle(cursor);
  1816. end;
  1817. function TSQLConnector.AllocateTransactionHandle: TSQLHandle;
  1818. begin
  1819. CheckProxy;
  1820. Result:=FProxy.AllocateTransactionHandle;
  1821. end;
  1822. procedure TSQLConnector.PrepareStatement(cursor: TSQLCursor;
  1823. ATransaction: TSQLTransaction; buf: string; AParams: TParams);
  1824. begin
  1825. CheckProxy;
  1826. FProxy.PrepareStatement(cursor, ATransaction, buf, AParams);
  1827. end;
  1828. procedure TSQLConnector.Execute(cursor: TSQLCursor;
  1829. atransaction: tSQLtransaction; AParams: TParams);
  1830. begin
  1831. CheckProxy;
  1832. FProxy.Execute(cursor, atransaction, AParams);
  1833. end;
  1834. function TSQLConnector.Fetch(cursor: TSQLCursor): boolean;
  1835. begin
  1836. CheckProxy;
  1837. Result:=FProxy.Fetch(cursor);
  1838. end;
  1839. procedure TSQLConnector.AddFieldDefs(cursor: TSQLCursor; FieldDefs: TfieldDefs
  1840. );
  1841. begin
  1842. CheckProxy;
  1843. FProxy.AddFieldDefs(cursor, FieldDefs);
  1844. end;
  1845. procedure TSQLConnector.UnPrepareStatement(cursor: TSQLCursor);
  1846. begin
  1847. CheckProxy;
  1848. FProxy.UnPrepareStatement(cursor);
  1849. end;
  1850. procedure TSQLConnector.FreeFldBuffers(cursor: TSQLCursor);
  1851. begin
  1852. CheckProxy;
  1853. FProxy.FreeFldBuffers(cursor);
  1854. end;
  1855. function TSQLConnector.LoadField(cursor: TSQLCursor; FieldDef: TfieldDef;
  1856. buffer: pointer; out CreateBlob: boolean): boolean;
  1857. begin
  1858. CheckProxy;
  1859. Result:=FProxy.LoadField(cursor, FieldDef, buffer, CreateBlob);
  1860. end;
  1861. function TSQLConnector.RowsAffected(cursor: TSQLCursor): TRowsCount;
  1862. begin
  1863. CheckProxy;
  1864. Result := FProxy.RowsAffected(cursor);
  1865. end;
  1866. function TSQLConnector.GetTransactionHandle(trans: TSQLHandle): pointer;
  1867. begin
  1868. CheckProxy;
  1869. Result:=FProxy.GetTransactionHandle(trans);
  1870. end;
  1871. function TSQLConnector.Commit(trans: TSQLHandle): boolean;
  1872. begin
  1873. CheckProxy;
  1874. Result:=FProxy.Commit(trans);
  1875. end;
  1876. function TSQLConnector.RollBack(trans: TSQLHandle): boolean;
  1877. begin
  1878. CheckProxy;
  1879. Result:=FProxy.RollBack(trans);
  1880. end;
  1881. function TSQLConnector.StartdbTransaction(trans: TSQLHandle; aParams: string
  1882. ): boolean;
  1883. begin
  1884. CheckProxy;
  1885. Result:=FProxy.StartdbTransaction(trans, aParams);
  1886. end;
  1887. procedure TSQLConnector.CommitRetaining(trans: TSQLHandle);
  1888. begin
  1889. CheckProxy;
  1890. FProxy.CommitRetaining(trans);
  1891. end;
  1892. procedure TSQLConnector.RollBackRetaining(trans: TSQLHandle);
  1893. begin
  1894. CheckProxy;
  1895. FProxy.RollBackRetaining(trans);
  1896. end;
  1897. procedure TSQLConnector.UpdateIndexDefs(IndexDefs: TIndexDefs;
  1898. TableName: string);
  1899. begin
  1900. CheckProxy;
  1901. FProxy.UpdateIndexDefs(IndexDefs, TableName);
  1902. end;
  1903. function TSQLConnector.GetSchemaInfoSQL(SchemaType: TSchemaType;
  1904. SchemaObjectName, SchemaPattern: string): string;
  1905. begin
  1906. CheckProxy;
  1907. Result:=FProxy.GetSchemaInfoSQL(SchemaType, SchemaObjectName, SchemaPattern
  1908. );
  1909. end;
  1910. procedure TSQLConnector.LoadBlobIntoBuffer(FieldDef: TFieldDef;
  1911. ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction: TSQLTransaction);
  1912. begin
  1913. CheckProxy;
  1914. FProxy.LoadBlobIntoBuffer(FieldDef, ABlobBuf, cursor, ATransaction);
  1915. end;
  1916. { TConnectionDef }
  1917. class function TConnectionDef.TypeName: String;
  1918. begin
  1919. Result:='';
  1920. end;
  1921. class function TConnectionDef.ConnectionClass: TSQLConnectionClass;
  1922. begin
  1923. Result:=Nil;
  1924. end;
  1925. class function TConnectionDef.Description: String;
  1926. begin
  1927. Result:='';
  1928. end;
  1929. class function TConnectionDef.DefaultLibraryName: String;
  1930. begin
  1931. Result:='';
  1932. end;
  1933. class function TConnectionDef.LoadFunction: TLibraryLoadFunction;
  1934. begin
  1935. Result:=Nil;
  1936. end;
  1937. class function TConnectionDef.UnLoadFunction: TLibraryUnLoadFunction;
  1938. begin
  1939. Result:=Nil;
  1940. end;
  1941. class function TConnectionDef.LoadedLibraryName: string;
  1942. begin
  1943. Result:='';
  1944. end;
  1945. procedure TConnectionDef.ApplyParams(Params: TStrings;
  1946. AConnection: TSQLConnection);
  1947. begin
  1948. AConnection.Params.Assign(Params);
  1949. end;
  1950. { TServerIndexDefs }
  1951. constructor TServerIndexDefs.create(ADataset: TDataset);
  1952. begin
  1953. if not (ADataset is TCustomSQLQuery) then
  1954. DatabaseErrorFmt(SErrNotASQLQuery,[ADataset.Name]);
  1955. inherited create(ADataset);
  1956. end;
  1957. procedure TServerIndexDefs.Update;
  1958. begin
  1959. if (not updated) and assigned(Dataset) then
  1960. begin
  1961. TCustomSQLQuery(Dataset).UpdateServerIndexDefs;
  1962. updated := True;
  1963. end;
  1964. end;
  1965. Initialization
  1966. Finalization
  1967. DoneDefs;
  1968. end.