sqldb.pp 65 KB

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