sqldb.pp 65 KB

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