sqldb.pp 64 KB

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