odbcconn.pas 54 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338
  1. (******************************************************************************
  2. * *
  3. * (c) 2005 Hexis BV *
  4. * *
  5. * File: odbcconn.pas *
  6. * Author: Bram Kuijvenhoven ([email protected]) *
  7. * Description: ODBC SQLDB unit *
  8. * License: (modified) LGPL *
  9. * *
  10. ******************************************************************************)
  11. unit odbcconn;
  12. {$mode objfpc}{$H+}
  13. interface
  14. uses
  15. Classes, SysUtils, sqldb, db, odbcsqldyn
  16. {$IF (FPC_VERSION>=2) AND (FPC_RELEASE>=1)}, BufDataset{$ENDIF}
  17. ;
  18. type
  19. // forward declarations
  20. TODBCConnection = class;
  21. { TODBCCursor }
  22. TODBCCursor = class(TSQLCursor)
  23. protected
  24. FSTMTHandle:SQLHSTMT; // ODBC Statement Handle
  25. FQuery:string; // last prepared query, with :ParamName converted to ?
  26. FParamIndex:TParamBinding; // maps the i-th parameter in the query to the TParams passed to PrepareStatement
  27. FParamBuf:array of pointer; // buffers that can be used to bind the i-th parameter in the query
  28. {$IF NOT((FPC_VERSION>=2) AND (FPC_RELEASE>=1))}
  29. FBlobStreams:TList; // list of Blob TMemoryStreams stored in field buffers (we need this currently as we can't hook into the freeing of TBufDataset buffers)
  30. {$ENDIF}
  31. public
  32. constructor Create(Connection:TODBCConnection);
  33. destructor Destroy; override;
  34. end;
  35. { TODBCHandle } // this name is a bit confusing, but follows the standards for naming classes in sqldb
  36. TODBCHandle = class(TSQLHandle)
  37. protected
  38. end;
  39. { TODBCEnvironment }
  40. TODBCEnvironment = class
  41. protected
  42. FENVHandle:SQLHENV; // ODBC Environment Handle
  43. public
  44. constructor Create;
  45. destructor Destroy; override;
  46. end;
  47. { TODBCConnection }
  48. TODBCConnection = class(TSQLConnection)
  49. private
  50. FDriver: string;
  51. FEnvironment:TODBCEnvironment;
  52. FDBCHandle:SQLHDBC; // ODBC Connection Handle
  53. FFileDSN: string;
  54. procedure SetParameters(ODBCCursor:TODBCCursor; AParams:TParams);
  55. procedure FreeParamBuffers(ODBCCursor:TODBCCursor);
  56. protected
  57. // Overrides from TSQLConnection
  58. function GetHandle:pointer; override;
  59. // - Connect/disconnect
  60. procedure DoInternalConnect; override;
  61. procedure DoInternalDisconnect; override;
  62. // - Handle (de)allocation
  63. function AllocateCursorHandle:TSQLCursor; override;
  64. procedure DeAllocateCursorHandle(var cursor:TSQLCursor); override;
  65. function AllocateTransactionHandle:TSQLHandle; override;
  66. // - Statement handling
  67. procedure PrepareStatement(cursor:TSQLCursor; ATransaction:TSQLTransaction; buf:string; AParams:TParams); override;
  68. procedure UnPrepareStatement(cursor:TSQLCursor); override;
  69. // - Transaction handling
  70. function GetTransactionHandle(trans:TSQLHandle):pointer; override;
  71. function StartDBTransaction(trans:TSQLHandle; AParams:string):boolean; override;
  72. function Commit(trans:TSQLHandle):boolean; override;
  73. function Rollback(trans:TSQLHandle):boolean; override;
  74. procedure CommitRetaining(trans:TSQLHandle); override;
  75. procedure RollbackRetaining(trans:TSQLHandle); override;
  76. // - Statement execution
  77. procedure Execute(cursor:TSQLCursor; ATransaction:TSQLTransaction; AParams:TParams); override;
  78. // - Result retrieving
  79. procedure AddFieldDefs(cursor:TSQLCursor; FieldDefs:TFieldDefs); override;
  80. function Fetch(cursor:TSQLCursor):boolean; override;
  81. {$IF (FPC_VERSION>=2) AND (FPC_RELEASE>=1)}
  82. function LoadField(cursor:TSQLCursor; FieldDef:TFieldDef; buffer:pointer; out CreateBlob : boolean):boolean; override;
  83. procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction : TSQLTransaction); override;
  84. {$ELSE}
  85. function LoadField(cursor:TSQLCursor; FieldDef:TFieldDef; buffer:pointer):boolean; override;
  86. function CreateBlobStream(Field:TField; Mode:TBlobStreamMode):TStream; override;
  87. {$ENDIF}
  88. procedure FreeFldBuffers(cursor:TSQLCursor); override;
  89. // - UpdateIndexDefs
  90. procedure UpdateIndexDefs(IndexDefs:TIndexDefs; TableName:string); override;
  91. // - Schema info
  92. function GetSchemaInfoSQL(SchemaType:TSchemaType; SchemaObjectName, SchemaObjectPattern:string):string; override;
  93. // Internal utility functions
  94. function CreateConnectionString:string;
  95. public
  96. constructor Create(AOwner : TComponent); override;
  97. property Environment:TODBCEnvironment read FEnvironment;
  98. published
  99. property Driver:string read FDriver write FDriver; // will be passed as DRIVER connection parameter
  100. property FileDSN:string read FFileDSN write FFileDSN; // will be passed as FILEDSN parameter
  101. // Redeclare properties from TSQLConnection
  102. property Password; // will be passed as PWD connection parameter
  103. property Transaction;
  104. property UserName; // will be passed as UID connection parameter
  105. property CharSet;
  106. property HostName; // ignored
  107. // Redeclare properties from TDatabase
  108. property Connected;
  109. property Role;
  110. property DatabaseName; // will be passed as DSN connection parameter
  111. property KeepConnection;
  112. property LoginPrompt; // if true, ODBC drivers might prompt for more details that are not in the connection string
  113. property Params; // will be added to connection string
  114. property OnLogin;
  115. end;
  116. EODBCException = class(EDatabaseError)
  117. // currently empty; perhaps we can add fields here later that describe the error instead of one simple message string
  118. end;
  119. {$IF (FPC_VERSION>=2) AND (FPC_RELEASE>=1)}
  120. { TODBCConnectionDef }
  121. TODBCConnectionDef = Class(TConnectionDef)
  122. Class Function TypeName : String; override;
  123. Class Function ConnectionClass : TSQLConnectionClass; override;
  124. Class Function Description : String; override;
  125. end;
  126. {$ENDIF}
  127. implementation
  128. uses
  129. Math, DBConst, ctypes;
  130. const
  131. DefaultEnvironment:TODBCEnvironment = nil;
  132. ODBCLoadCount:integer = 0; // ODBC is loaded when > 0; modified by TODBCEnvironment.Create/Destroy
  133. { Generic ODBC helper functions }
  134. function ODBCSucces(const Res:SQLRETURN):boolean;
  135. begin
  136. Result:=(Res=SQL_SUCCESS) or (Res=SQL_SUCCESS_WITH_INFO);
  137. end;
  138. function ODBCResultToStr(Res:SQLRETURN):string;
  139. begin
  140. case Res of
  141. SQL_SUCCESS: Result:='SQL_SUCCESS';
  142. SQL_SUCCESS_WITH_INFO:Result:='SQL_SUCCESS_WITH_INFO';
  143. SQL_ERROR: Result:='SQL_ERROR';
  144. SQL_INVALID_HANDLE: Result:='SQL_INVALID_HANDLE';
  145. SQL_NO_DATA: Result:='SQL_NO_DATA';
  146. SQL_NEED_DATA: Result:='SQL_NEED_DATA';
  147. SQL_STILL_EXECUTING: Result:='SQL_STILL_EXECUTING';
  148. else
  149. Result:='';
  150. end;
  151. end;
  152. procedure ODBCCheckResult(LastReturnCode:SQLRETURN; HandleType:SQLSMALLINT; AHandle: SQLHANDLE; ErrorMsg: string; const FmtArgs:array of const);
  153. // check return value from SQLGetDiagField/Rec function itself
  154. procedure CheckSQLGetDiagResult(const Res:SQLRETURN);
  155. begin
  156. case Res of
  157. SQL_INVALID_HANDLE:
  158. raise EODBCException.Create('Invalid handle passed to SQLGetDiagRec/Field');
  159. SQL_ERROR:
  160. raise EODBCException.Create('An invalid parameter was passed to SQLGetDiagRec/Field');
  161. SQL_NO_DATA:
  162. raise EODBCException.Create('A too large RecNumber was passed to SQLGetDiagRec/Field');
  163. end;
  164. end;
  165. var
  166. NativeError:SQLINTEGER;
  167. TextLength:SQLSMALLINT;
  168. Res:SQLRETURN;
  169. SqlState,MessageText,TotalMessage:string;
  170. RecNumber:SQLSMALLINT;
  171. begin
  172. // check result
  173. if ODBCSucces(LastReturnCode) then
  174. Exit; // no error; all is ok
  175. //WriteLn('LastResultCode: ',ODBCResultToStr(LastReturnCode));
  176. try
  177. // build TotalMessage for exception to throw
  178. TotalMessage:=Format(ErrorMsg,FmtArgs)+Format(' ODBC error details: LastReturnCode: %s;',[ODBCResultToStr(LastReturnCode)]);
  179. // retrieve status records
  180. SetLength(SqlState,5); // SqlState buffer
  181. SetLength(MessageText,1);
  182. RecNumber:=1;
  183. repeat
  184. // dummy call to get correct TextLength
  185. //WriteLn('Getting error record ',RecNumber);
  186. Res:=SQLGetDiagRec(HandleType,AHandle,RecNumber,@(SqlState[1]),NativeError,@(MessageText[1]),0,TextLength);
  187. if Res=SQL_NO_DATA then
  188. Break; // no more status records
  189. CheckSQLGetDiagResult(Res);
  190. if TextLength>0 then // if TextLength=0 we don't need another call; also our string buffer would not point to a #0, but be a nil pointer
  191. begin
  192. // allocate large enough buffer
  193. SetLength(MessageText,TextLength); // note: ansistrings of Length>0 are always terminated by a #0 character, so this is safe
  194. // actual call
  195. Res:=SQLGetDiagRec(HandleType,AHandle,RecNumber,@(SqlState[1]),NativeError,@(MessageText[1]),Length(MessageText)+1,TextLength);
  196. CheckSQLGetDiagResult(Res);
  197. end;
  198. // add to TotalMessage
  199. TotalMessage:=TotalMessage+Format(' Record %d: SqlState: %s; NativeError: %d; Message: %s;',[RecNumber,SqlState,NativeError,MessageText]);
  200. // incement counter
  201. Inc(RecNumber);
  202. until false;
  203. except
  204. on E:EODBCException do begin
  205. TotalMessage:=TotalMessage+Format('Could not get error message: %s',[E.Message]);
  206. end
  207. end;
  208. // raise error
  209. raise EODBCException.Create(TotalMessage);
  210. end;
  211. procedure ODBCCheckResult(LastReturnCode:SQLRETURN; HandleType:SQLSMALLINT; AHandle: SQLHANDLE; ErrorMsg: string);
  212. begin
  213. ODBCCheckResult(LastReturnCode, HandleType, AHandle, ErrorMsg, []);
  214. end;
  215. { TODBCConnection }
  216. // Creates a connection string using the current value of the fields
  217. function TODBCConnection.CreateConnectionString: string;
  218. // encloses a param value with braces if necessary, i.e. when any of the characters []{}(),;?*=!@ is in the value
  219. function EscapeParamValue(const s:string):string;
  220. var
  221. NeedEscape:boolean;
  222. i:integer;
  223. begin
  224. NeedEscape:=false;
  225. for i:=1 to Length(s) do
  226. if s[i] in ['[',']','{','}','(',')',',','*','=','!','@'] then
  227. begin
  228. NeedEscape:=true;
  229. Break;
  230. end;
  231. if NeedEscape then
  232. Result:='{'+s+'}'
  233. else
  234. Result:=s;
  235. end;
  236. var
  237. i: Integer;
  238. Param: string;
  239. EqualSignPos:integer;
  240. begin
  241. Result:='';
  242. if DatabaseName<>'' then Result:=Result + 'DSN='+EscapeParamValue(DatabaseName)+';';
  243. if Driver <>'' then Result:=Result + 'DRIVER='+EscapeParamValue(Driver)+';';
  244. if UserName <>'' then Result:=Result + 'UID='+EscapeParamValue(UserName)+';PWD='+EscapeParamValue(Password)+';';
  245. if FileDSN <>'' then Result:=Result + 'FILEDSN='+EscapeParamValue(FileDSN)+'';
  246. for i:=0 to Params.Count-1 do
  247. begin
  248. Param:=Params[i];
  249. EqualSignPos:=Pos('=',Param);
  250. if EqualSignPos=0 then
  251. raise EODBCException.CreateFmt('Invalid parameter in Params[%d]; can''t find a ''='' in ''%s''',[i, Param])
  252. else if EqualSignPos=1 then
  253. raise EODBCException.CreateFmt('Invalid parameter in Params[%d]; no identifier before the ''='' in ''%s''',[i, Param])
  254. else
  255. Result:=Result + EscapeParamValue(Copy(Param,1,EqualSignPos-1))+'='+EscapeParamValue(Copy(Param,EqualSignPos+1,MaxInt))+';';
  256. end;
  257. end;
  258. constructor TODBCConnection.Create(AOwner: TComponent);
  259. begin
  260. inherited Create(AOwner);
  261. {$IF (FPC_VERSION>=2) AND (FPC_RELEASE>=1)}
  262. FConnOptions := FConnOptions + [sqEscapeRepeat] + [sqEscapeSlash];
  263. {$ENDIF}
  264. end;
  265. procedure TODBCConnection.SetParameters(ODBCCursor: TODBCCursor; AParams: TParams);
  266. var
  267. ParamIndex: integer;
  268. PVal, Buf, PStrLenOrInd: pointer;
  269. I, Size: integer;
  270. IntVal: clong;
  271. LargeVal: clonglong;
  272. StrVal: string;
  273. FloatVal: cdouble;
  274. DateVal: SQL_DATE_STRUCT;
  275. TimeStampVal: SQL_TIMESTAMP_STRUCT;
  276. ColumnSize, BufferLength, StrLenOrInd: SQLINTEGER;
  277. CType, SqlType, DecimalDigits:SQLSMALLINT;
  278. begin
  279. // Note: it is assumed that AParams is the same as the one passed to PrepareStatement, in the sense that
  280. // the parameters have the same order and names
  281. if Length(ODBCCursor.FParamIndex)>0 then
  282. if not Assigned(AParams) then
  283. raise EODBCException.CreateFmt('The query has parameter markers in it, but no actual parameters were passed',[]);
  284. SetLength(ODBCCursor.FParamBuf, Length(ODBCCursor.FParamIndex));
  285. for i:=0 to High(ODBCCursor.FParamIndex) do
  286. begin
  287. ParamIndex:=ODBCCursor.FParamIndex[i];
  288. if (ParamIndex<0) or (ParamIndex>=AParams.Count) then
  289. raise EODBCException.CreateFmt('Parameter %d in query does not have a matching parameter set',[i]);
  290. DecimalDigits:=0;
  291. BufferLength:=0;
  292. StrLenOrInd:=0;
  293. case AParams[ParamIndex].DataType of
  294. ftInteger, ftSmallInt:
  295. begin
  296. IntVal:=AParams[ParamIndex].AsInteger;
  297. PVal:=@IntVal;
  298. Size:=SizeOf(IntVal);
  299. CType:=SQL_C_LONG;
  300. SqlType:=SQL_INTEGER;
  301. ColumnSize:=10;
  302. end;
  303. ftLargeInt:
  304. begin
  305. LargeVal:=AParams[ParamIndex].AsLargeInt;
  306. PVal:=@LargeVal;
  307. Size:=SizeOf(LargeVal);
  308. CType:=SQL_C_SBIGINT;
  309. SqlType:=SQL_BIGINT;
  310. ColumnSize:=19;
  311. end;
  312. ftString, ftBlob, ftMemo:
  313. begin
  314. StrVal:=AParams[ParamIndex].AsString;
  315. StrLenOrInd:=Length(StrVal);
  316. if StrVal='' then //HY104
  317. begin
  318. StrVal:=#0;
  319. StrLenOrInd:=SQL_NTS;
  320. end;
  321. PVal:=@StrVal[1];
  322. Size:=Length(StrVal);
  323. ColumnSize:=Size;
  324. BufferLength:=Size;
  325. if AParams[ParamIndex].DataType = ftString then
  326. begin
  327. CType:=SQL_C_CHAR;
  328. SqlType:=SQL_LONGVARCHAR;
  329. end
  330. else // ftBlob, ftMemo
  331. begin
  332. CType:=SQL_C_BINARY;
  333. SqlType:=SQL_BINARY;
  334. end;
  335. end;
  336. ftFloat:
  337. begin
  338. FloatVal:=AParams[ParamIndex].AsFloat;
  339. PVal:=@FloatVal;
  340. Size:=SizeOf(FloatVal);
  341. CType:=SQL_C_DOUBLE;
  342. SqlType:=SQL_DOUBLE;
  343. ColumnSize:=15;
  344. end;
  345. ftDate:
  346. begin
  347. DateVal:=DateTimeToDateStruct(AParams[ParamIndex].AsDate);
  348. PVal:=@DateVal;
  349. Size:=SizeOf(DateVal);
  350. CType:=SQL_C_TYPE_DATE;
  351. SqlType:=SQL_TYPE_DATE;
  352. ColumnSize:=Size;
  353. end;
  354. ftDateTime:
  355. begin
  356. DateTime2TimeStampStruct(TimeStampVal, AParams[ParamIndex].AsDateTime);
  357. PVal:=@TimeStampVal;
  358. Size:=SizeOf(TimeStampVal);
  359. CType:=SQL_C_TYPE_TIMESTAMP;
  360. SqlType:=SQL_TYPE_TIMESTAMP;
  361. ColumnSize:=Size;
  362. end;
  363. else
  364. raise EDataBaseError.CreateFmt('Parameter %d is of type %s, which not supported yet',[ParamIndex, Fieldtypenames[AParams[ParamIndex].DataType]]);
  365. end;
  366. if AParams[ParamIndex].IsNull then
  367. StrLenOrInd:=SQL_NULL_DATA;
  368. Buf:=GetMem(Size+SizeOf(SQLINTEGER));
  369. Move(PVal^, Buf^, Size);
  370. if StrLenOrInd<>0 then
  371. begin
  372. PStrLenOrInd:=Buf + Size;
  373. Move(StrLenOrInd, PStrLenOrInd^, SizeOf(SQLINTEGER));
  374. end
  375. else
  376. PStrLenOrInd:=nil;
  377. ODBCCursor.FParamBuf[i]:=Buf;
  378. ODBCCheckResult(
  379. SQLBindParameter(ODBCCursor.FSTMTHandle, // StatementHandle
  380. i+1, // ParameterNumber
  381. SQL_PARAM_INPUT, // InputOutputType
  382. CType, // ValueType
  383. SqlType, // ParameterType
  384. ColumnSize, // ColumnSize
  385. DecimalDigits, // DecimalDigits
  386. Buf, // ParameterValuePtr
  387. BufferLength, // BufferLength
  388. PStrLenOrInd), // StrLen_or_IndPtr
  389. SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not bind parameter %d.', [i]
  390. );
  391. end;
  392. end;
  393. procedure TODBCConnection.FreeParamBuffers(ODBCCursor: TODBCCursor);
  394. var
  395. i:integer;
  396. begin
  397. for i:=0 to High(ODBCCursor.FParamBuf) do
  398. FreeMem(ODBCCursor.FParamBuf[i]);
  399. SetLength(ODBCCursor.FParamBuf,0);
  400. end;
  401. function TODBCConnection.GetHandle: pointer;
  402. begin
  403. // I'm not sure whether this is correct; perhaps we should return nil
  404. // note that FDBHandle is a LongInt, because ODBC handles are integers, not pointers
  405. // I wonder how this will work on 64 bit platforms then (FK)
  406. Result:=pointer(PtrInt(FDBCHandle));
  407. end;
  408. procedure TODBCConnection.DoInternalConnect;
  409. const
  410. BufferLength = 1024; // should be at least 1024 according to the ODBC specification
  411. var
  412. ConnectionString:string;
  413. OutConnectionString:string;
  414. ActualLength:SQLSMALLINT;
  415. begin
  416. // Do not call the inherited method as it checks for a non-empty DatabaseName, and we don't even use DatabaseName!
  417. // inherited DoInternalConnect;
  418. // make sure we have an environment
  419. if not Assigned(FEnvironment) then
  420. begin
  421. if not Assigned(DefaultEnvironment) then
  422. DefaultEnvironment:=TODBCEnvironment.Create;
  423. FEnvironment:=DefaultEnvironment;
  424. end;
  425. // allocate connection handle
  426. ODBCCheckResult(
  427. SQLAllocHandle(SQL_HANDLE_DBC,Environment.FENVHandle,FDBCHandle),
  428. SQL_HANDLE_ENV,Environment.FENVHandle,'Could not allocate ODBC Connection handle.'
  429. );
  430. try
  431. // connect
  432. ConnectionString:=CreateConnectionString;
  433. SetLength(OutConnectionString,BufferLength-1); // allocate completed connection string buffer (using the ansistring #0 trick)
  434. ODBCCheckResult(
  435. SQLDriverConnect(FDBCHandle, // the ODBC connection handle
  436. nil, // no parent window (would be required for prompts)
  437. PChar(ConnectionString), // the connection string
  438. Length(ConnectionString), // connection string length
  439. @(OutConnectionString[1]),// buffer for storing the completed connection string
  440. BufferLength, // length of the buffer
  441. ActualLength, // the actual length of the completed connection string
  442. SQL_DRIVER_NOPROMPT), // don't prompt for password etc.
  443. SQL_HANDLE_DBC,FDBCHandle,'Could not connect with connection string "%s".',[ConnectionString]
  444. );
  445. except
  446. on E:Exception do begin
  447. // free connection handle
  448. ODBCCheckResult(
  449. SQLFreeHandle(SQL_HANDLE_DBC,FDBCHandle),
  450. SQL_HANDLE_DBC,FDBCHandle,'Could not free ODBC Connection handle.'
  451. );
  452. raise; // re-raise exception
  453. end;
  454. end;
  455. // commented out as the OutConnectionString is not used further at the moment
  456. // if ActualLength<BufferLength-1 then
  457. // SetLength(OutConnectionString,ActualLength); // fix completed connection string length
  458. // set connection attributes (none yet)
  459. end;
  460. procedure TODBCConnection.DoInternalDisconnect;
  461. var
  462. Res:SQLRETURN;
  463. begin
  464. inherited DoInternalDisconnect;
  465. // disconnect
  466. ODBCCheckResult(
  467. SQLDisconnect(FDBCHandle),
  468. SQL_HANDLE_DBC,FDBCHandle,'Could not disconnect.'
  469. );
  470. // deallocate connection handle
  471. Res:=SQLFreeHandle(SQL_HANDLE_DBC, FDBCHandle);
  472. if Res=SQL_ERROR then
  473. ODBCCheckResult(Res,SQL_HANDLE_DBC,FDBCHandle,'Could not free ODBC Connection handle.');
  474. end;
  475. function TODBCConnection.AllocateCursorHandle: TSQLCursor;
  476. begin
  477. Result:=TODBCCursor.Create(self);
  478. end;
  479. procedure TODBCConnection.DeAllocateCursorHandle(var cursor: TSQLCursor);
  480. begin
  481. FreeAndNil(cursor); // the destructor of TODBCCursor frees the ODBC Statement handle
  482. end;
  483. function TODBCConnection.AllocateTransactionHandle: TSQLHandle;
  484. begin
  485. Result:=nil; // not yet supported; will move connection handles to transaction handles later
  486. end;
  487. procedure TODBCConnection.PrepareStatement(cursor: TSQLCursor; ATransaction: TSQLTransaction; buf: string; AParams: TParams);
  488. var
  489. ODBCCursor:TODBCCursor;
  490. begin
  491. ODBCCursor:=cursor as TODBCCursor;
  492. // allocate statement handle
  493. ODBCCheckResult(
  494. SQLAllocHandle(SQL_HANDLE_STMT, FDBCHandle, ODBCCursor.FSTMTHandle),
  495. SQL_HANDLE_DBC, FDBCHandle, 'Could not allocate ODBC Statement handle.'
  496. );
  497. ODBCCursor.FPrepared:=True;
  498. // Parameter handling
  499. // Note: We can only pass ? parameters to ODBC, so we should convert named parameters like :MyID
  500. // ODBCCursor.FParamIndex will map th i-th ? token in the (modified) query to an index for AParams
  501. // Parse the SQL and build FParamIndex
  502. if assigned(AParams) and (AParams.count > 0) then
  503. {$IF (FPC_VERSION>=2) AND (FPC_RELEASE>=1)}
  504. buf := AParams.ParseSQL(buf,false,sqEscapeSlash in ConnOptions, sqEscapeRepeat in ConnOptions,psInterbase,ODBCCursor.FParamIndex);
  505. {$ELSE}
  506. buf := AParams.ParseSQL(buf,false,psInterbase,ODBCCursor.FParamIndex);
  507. {$ENDIF}
  508. // prepare statement
  509. ODBCCursor.FQuery:=Buf;
  510. if ODBCCursor.FSchemaType=stNoSchema then
  511. begin
  512. ODBCCheckResult(
  513. SQLPrepare(ODBCCursor.FSTMTHandle, PChar(buf), Length(buf)),
  514. SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not prepare statement.'
  515. );
  516. end
  517. else
  518. ODBCCursor.FStatementType:=stSelect;
  519. end;
  520. procedure TODBCConnection.UnPrepareStatement(cursor: TSQLCursor);
  521. var Res:SQLRETURN;
  522. begin
  523. with TODBCCursor(cursor) do
  524. begin
  525. if FSTMTHandle<>SQL_NULL_HSTMT then
  526. begin
  527. // deallocate statement handle
  528. Res:=SQLFreeHandle(SQL_HANDLE_STMT, FSTMTHandle);
  529. if Res=SQL_ERROR then
  530. ODBCCheckResult(Res,SQL_HANDLE_STMT, FSTMTHandle, 'Could not free ODBC Statement handle.');
  531. FSTMTHandle:=SQL_NULL_HSTMT;
  532. FPrepared := False;
  533. end;
  534. end;
  535. end;
  536. function TODBCConnection.GetTransactionHandle(trans: TSQLHandle): pointer;
  537. begin
  538. // Tranactions not implemented yet
  539. end;
  540. function TODBCConnection.StartDBTransaction(trans: TSQLHandle; AParams:string): boolean;
  541. begin
  542. // Tranactions not implemented yet
  543. end;
  544. function TODBCConnection.Commit(trans: TSQLHandle): boolean;
  545. begin
  546. // Tranactions not implemented yet
  547. end;
  548. function TODBCConnection.Rollback(trans: TSQLHandle): boolean;
  549. begin
  550. // Tranactions not implemented yet
  551. end;
  552. procedure TODBCConnection.CommitRetaining(trans: TSQLHandle);
  553. begin
  554. // Tranactions not implemented yet
  555. end;
  556. procedure TODBCConnection.RollbackRetaining(trans: TSQLHandle);
  557. begin
  558. // Tranactions not implemented yet
  559. end;
  560. procedure TODBCConnection.Execute(cursor: TSQLCursor; ATransaction: TSQLTransaction; AParams: TParams);
  561. var
  562. ODBCCursor:TODBCCursor;
  563. Res:SQLRETURN;
  564. begin
  565. ODBCCursor:=cursor as TODBCCursor;
  566. // set parameters
  567. if Assigned(APArams) and (AParams.count > 0) then SetParameters(ODBCCursor, AParams);
  568. // execute the statement
  569. case ODBCCursor.FSchemaType of
  570. stNoSchema : Res:=SQLExecute(ODBCCursor.FSTMTHandle); //SQL_NO_DATA returns searched update or delete statement that does not affect any rows
  571. stTables : Res:=SQLTables (ODBCCursor.FSTMTHandle, nil, 0, nil, 0, nil, 0, nil, 0 );
  572. stColumns : Res:=SQLColumns(ODBCCursor.FSTMTHandle, nil, 0, nil, 0, @ODBCCursor.FQuery[1], length(ODBCCursor.FQuery), nil, 0 );
  573. stProcedures: Res:=SQLProcedures(ODBCCursor.FSTMTHandle, nil, 0, nil, 0, nil, 0 );
  574. else Res:=SQL_NO_DATA;
  575. end; {case}
  576. if (Res<>SQL_NO_DATA) then ODBCCheckResult( Res, SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not execute statement.' );
  577. // free parameter buffers
  578. FreeParamBuffers(ODBCCursor);
  579. end;
  580. function TODBCConnection.Fetch(cursor: TSQLCursor): boolean;
  581. var
  582. ODBCCursor:TODBCCursor;
  583. Res:SQLRETURN;
  584. begin
  585. ODBCCursor:=cursor as TODBCCursor;
  586. // fetch new row
  587. Res:=SQLFetch(ODBCCursor.FSTMTHandle);
  588. if Res<>SQL_NO_DATA then
  589. ODBCCheckResult(Res,SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not fetch new row from result set.');
  590. // result is true iff a new row was available
  591. Result:=Res<>SQL_NO_DATA;
  592. end;
  593. const
  594. DEFAULT_BLOB_BUFFER_SIZE = 1024;
  595. {$IF (FPC_VERSION>=2) AND (FPC_RELEASE>=1)}
  596. function TODBCConnection.LoadField(cursor: TSQLCursor; FieldDef: TFieldDef; buffer: pointer; out CreateBlob : boolean): boolean;
  597. {$ELSE}
  598. function TODBCConnection.LoadField(cursor: TSQLCursor; FieldDef: TFieldDef; buffer: pointer):boolean;
  599. {$ENDIF}
  600. var
  601. ODBCCursor:TODBCCursor;
  602. StrLenOrInd:SQLINTEGER;
  603. ODBCDateStruct:SQL_DATE_STRUCT;
  604. ODBCTimeStruct:SQL_TIME_STRUCT;
  605. ODBCTimeStampStruct:SQL_TIMESTAMP_STRUCT;
  606. DateTime:TDateTime;
  607. {$IF NOT((FPC_VERSION>=2) AND (FPC_RELEASE>=1))}
  608. BlobBuffer:pointer;
  609. BlobBufferSize,BytesRead:SQLINTEGER;
  610. BlobMemoryStream:TMemoryStream;
  611. {$ENDIF}
  612. Res:SQLRETURN;
  613. begin
  614. {$IF (FPC_VERSION>=2) AND (FPC_RELEASE>=1)}
  615. CreateBlob := False;
  616. {$ENDIF}
  617. ODBCCursor:=cursor as TODBCCursor;
  618. // load the field using SQLGetData
  619. // Note: optionally we can implement the use of SQLBindCol later for even more speed
  620. // TODO: finish this
  621. case FieldDef.DataType of
  622. ftWideString,ftFixedWideChar: // mapped to TWideStringField
  623. Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_WCHAR, buffer, FieldDef.Size, @StrLenOrInd);
  624. ftGuid, ftFixedChar,ftString: // are mapped to a TStringField (including TGuidField)
  625. Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_CHAR, buffer, FieldDef.Size, @StrLenOrInd);
  626. ftSmallint: // mapped to TSmallintField
  627. Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_SSHORT, buffer, SizeOf(Smallint), @StrLenOrInd);
  628. ftInteger,ftWord: // mapped to TLongintField
  629. Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_SLONG, buffer, SizeOf(Longint), @StrLenOrInd);
  630. ftLargeint: // mapped to TLargeintField
  631. Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_SBIGINT, buffer, SizeOf(Largeint), @StrLenOrInd);
  632. ftFloat: // mapped to TFloatField
  633. Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_DOUBLE, buffer, SizeOf(Double), @StrLenOrInd);
  634. ftTime: // mapped to TTimeField
  635. begin
  636. Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_TYPE_TIME, @ODBCTimeStruct, SizeOf(SQL_TIME_STRUCT), @StrLenOrInd);
  637. if StrLenOrInd<>SQL_NULL_DATA then
  638. begin
  639. DateTime:=TimeStructToDateTime(@ODBCTimeStruct);
  640. Move(DateTime, buffer^, SizeOf(TDateTime));
  641. end;
  642. end;
  643. ftDate: // mapped to TDateField
  644. begin
  645. Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_TYPE_DATE, @ODBCDateStruct, SizeOf(SQL_DATE_STRUCT), @StrLenOrInd);
  646. if StrLenOrInd<>SQL_NULL_DATA then
  647. begin
  648. DateTime:=DateStructToDateTime(@ODBCDateStruct);
  649. Move(DateTime, buffer^, SizeOf(TDateTime));
  650. end;
  651. end;
  652. ftDateTime: // mapped to TDateTimeField
  653. begin
  654. Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_TYPE_TIMESTAMP, @ODBCTimeStampStruct, SizeOf(SQL_TIMESTAMP_STRUCT), @StrLenOrInd);
  655. if StrLenOrInd<>SQL_NULL_DATA then
  656. begin
  657. DateTime:=TimeStampStructToDateTime(@ODBCTimeStampStruct);
  658. Move(DateTime, buffer^, SizeOf(TDateTime));
  659. end;
  660. end;
  661. ftBoolean: // mapped to TBooleanField
  662. Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BIT, buffer, SizeOf(Wordbool), @StrLenOrInd);
  663. ftBytes: // mapped to TBytesField
  664. Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, buffer, FieldDef.Size, @StrLenOrInd);
  665. ftVarBytes: // mapped to TVarBytesField
  666. Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, buffer, FieldDef.Size, @StrLenOrInd);
  667. {$IF (FPC_VERSION>=2) AND (FPC_RELEASE>=1)}
  668. ftWideMemo,
  669. {$ENDIF}
  670. ftBlob, ftMemo: // BLOBs
  671. begin
  672. //Writeln('BLOB');
  673. // Try to discover BLOB data length
  674. Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, buffer, 0, @StrLenOrInd);
  675. ODBCCheckResult(Res, SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not get field data for field "%s" (index %d).',[FieldDef.Name, FieldDef.Index+1]);
  676. // Read the data if not NULL
  677. if StrLenOrInd<>SQL_NULL_DATA then
  678. begin
  679. {$IF (FPC_VERSION>=2) AND (FPC_RELEASE>=1)}
  680. CreateBlob:=true; // defer actual loading of blob data to LoadBlobIntoBuffer method
  681. //WriteLn('Deferring loading of blob of length ',StrLenOrInd);
  682. {$ELSE}
  683. // Determine size of buffer to use
  684. if StrLenOrInd<>SQL_NO_TOTAL then
  685. BlobBufferSize:=StrLenOrInd
  686. else
  687. BlobBufferSize:=DEFAULT_BLOB_BUFFER_SIZE;
  688. try
  689. // init BlobBuffer and BlobMemoryStream to nil pointers
  690. BlobBuffer:=nil;
  691. BlobMemoryStream:=nil;
  692. if BlobBufferSize>0 then // Note: zero-length BLOB is represented as nil pointer in the field buffer to save memory usage
  693. begin
  694. // Allocate the buffer and memorystream
  695. BlobBuffer:=GetMem(BlobBufferSize);
  696. BlobMemoryStream:=TMemoryStream.Create;
  697. // Retrieve data in parts (or effectively in one part if StrLenOrInd<>SQL_NO_TOTAL above)
  698. repeat
  699. Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, BlobBuffer, BlobBufferSize, @StrLenOrInd);
  700. ODBCCheckResult(Res, SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not get field data for field "%s" (index %d).',[FieldDef.Name, FieldDef.Index+1]);
  701. // Append data in buffer to memorystream
  702. if (StrLenOrInd=SQL_NO_TOTAL) or (StrLenOrInd>BlobBufferSize) then
  703. BytesRead:=BlobBufferSize
  704. else
  705. BytesRead:=StrLenOrInd;
  706. BlobMemoryStream.Write(BlobBuffer^, BytesRead);
  707. until Res=SQL_SUCCESS;
  708. end;
  709. // Store memorystream pointer in Field buffer and in the cursor's FBlobStreams list
  710. TObject(buffer^):=BlobMemoryStream;
  711. if BlobMemoryStream<>nil then
  712. ODBCCursor.FBlobStreams.Add(BlobMemoryStream);
  713. // Set BlobMemoryStream to nil, so it won't get freed in the finally block below
  714. BlobMemoryStream:=nil;
  715. finally
  716. BlobMemoryStream.Free;
  717. if BlobBuffer<>nil then
  718. Freemem(BlobBuffer,BlobBufferSize);
  719. end;
  720. {$ENDIF}
  721. end;
  722. end;
  723. // TODO: Loading of other field types
  724. else
  725. raise EODBCException.CreateFmt('Tried to load field of unsupported field type %s',[Fieldtypenames[FieldDef.DataType]]);
  726. end;
  727. ODBCCheckResult(Res, SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not get field data for field "%s" (index %d).',[FieldDef.Name, FieldDef.Index+1]);
  728. Result:=StrLenOrInd<>SQL_NULL_DATA; // Result indicates whether the value is non-null
  729. //writeln(Format('Field.Size: %d; StrLenOrInd: %d',[FieldDef.Size, StrLenOrInd]));
  730. end;
  731. {$IF (FPC_VERSION>=2) AND (FPC_RELEASE>=1)}
  732. procedure TODBCConnection.LoadBlobIntoBuffer(FieldDef: TFieldDef; ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction: TSQLTransaction);
  733. var
  734. ODBCCursor: TODBCCursor;
  735. Res: SQLRETURN;
  736. StrLenOrInd:SQLINTEGER;
  737. BlobBuffer:pointer;
  738. BlobBufferSize,BytesRead:SQLINTEGER;
  739. BlobMemoryStream:TMemoryStream;
  740. begin
  741. ODBCCursor:=cursor as TODBCCursor;
  742. // Try to discover BLOB data length
  743. // NB MS ODBC requires that TargetValuePtr is not nil, so we supply it with a valid pointer, even though BufferLength is 0
  744. Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, @BlobBuffer, 0, @StrLenOrInd);
  745. ODBCCheckResult(Res, SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not get field data for field "%s" (index %d).',[FieldDef.Name, FieldDef.Index+1]);
  746. // Read the data if not NULL
  747. if StrLenOrInd<>SQL_NULL_DATA then
  748. begin
  749. // Determine size of buffer to use
  750. if StrLenOrInd<>SQL_NO_TOTAL then begin
  751. // Size is known on beforehand
  752. // set size & alloc buffer
  753. //WriteLn('Loading blob of length ',StrLenOrInd);
  754. BlobBufferSize:=StrLenOrInd;
  755. ABlobBuf^.BlobBuffer^.Size:=BlobBufferSize;
  756. ReAllocMem(ABlobBuf^.BlobBuffer^.Buffer, BlobBufferSize);
  757. // get blob data
  758. if BlobBufferSize>0 then begin
  759. Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, ABlobBuf^.BlobBuffer^.Buffer, BlobBufferSize, @StrLenOrInd);
  760. ODBCCheckResult(Res, SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not load blob data for field "%s" (index %d).',[FieldDef.Name, FieldDef.Index+1]);
  761. end;
  762. end else begin
  763. // Size is not known on beforehand; read data in chuncks; write to a TMemoryStream (which implements O(n) writing)
  764. BlobBufferSize:=DEFAULT_BLOB_BUFFER_SIZE;
  765. // init BlobBuffer and BlobMemoryStream to nil pointers
  766. BlobBuffer:=nil; // the buffer that will hold the chuncks of data; not to be confused with ABlobBuf^.BlobBuffer
  767. BlobMemoryStream:=nil;
  768. try
  769. // Allocate the buffer and memorystream
  770. BlobBuffer:=GetMem(BlobBufferSize);
  771. BlobMemoryStream:=TMemoryStream.Create;
  772. // Retrieve data in parts
  773. repeat
  774. Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, BlobBuffer, BlobBufferSize, @StrLenOrInd);
  775. ODBCCheckResult(Res, SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not load (partial) blob data for field "%s" (index %d).',[FieldDef.Name, FieldDef.Index+1]);
  776. // Append data in buffer to memorystream
  777. if (StrLenOrInd=SQL_NO_TOTAL) or (StrLenOrInd>BlobBufferSize) then
  778. BytesRead:=BlobBufferSize
  779. else
  780. BytesRead:=StrLenOrInd;
  781. BlobMemoryStream.Write(BlobBuffer^, BytesRead);
  782. until Res=SQL_SUCCESS;
  783. // Copy memory stream data to ABlobBuf^.BlobBuffer
  784. BlobBufferSize:=BlobMemoryStream.Size; // actual blob size
  785. // alloc ABlobBuf^.BlobBuffer
  786. ABlobBuf^.BlobBuffer^.Size:=BlobBufferSize;
  787. ReAllocMem(ABlobBuf^.BlobBuffer^.Buffer, BlobBufferSize);
  788. // read memory stream data into ABlobBuf^.BlobBuffer
  789. BlobMemoryStream.Position:=0;
  790. BlobMemoryStream.Read(ABlobBuf^.BlobBuffer^.Buffer^, BlobBufferSize);
  791. finally
  792. // free buffer and memory stream
  793. BlobMemoryStream.Free;
  794. if BlobBuffer<>nil then
  795. Freemem(BlobBuffer,BlobBufferSize);
  796. end;
  797. end;
  798. end;
  799. end;
  800. {$ELSE}
  801. function TODBCConnection.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream;
  802. var
  803. ODBCCursor: TODBCCursor;
  804. BlobMemoryStream, BlobMemoryStreamCopy: TMemoryStream;
  805. begin
  806. if (Mode=bmRead) and not Field.IsNull then
  807. begin
  808. Field.GetData(@BlobMemoryStream);
  809. BlobMemoryStreamCopy:=TMemoryStream.Create;
  810. if BlobMemoryStream<>nil then
  811. BlobMemoryStreamCopy.LoadFromStream(BlobMemoryStream);
  812. Result:=BlobMemoryStreamCopy;
  813. end
  814. else
  815. Result:=nil;
  816. end;
  817. {$ENDIF}
  818. procedure TODBCConnection.FreeFldBuffers(cursor: TSQLCursor);
  819. var
  820. ODBCCursor:TODBCCursor;
  821. {$IF NOT((FPC_VERSION>=2) AND (FPC_RELEASE>=1))}
  822. i: integer;
  823. {$ENDIF}
  824. begin
  825. ODBCCursor:=cursor as TODBCCursor;
  826. {$IF NOT((FPC_VERSION>=2) AND (FPC_RELEASE>=1))}
  827. // Free TMemoryStreams in cursor.FBlobStreams and clear it
  828. for i:=0 to ODBCCursor.FBlobStreams.Count-1 do
  829. TObject(ODBCCursor.FBlobStreams[i]).Free;
  830. ODBCCursor.FBlobStreams.Clear;
  831. {$ENDIF}
  832. ODBCCheckResult(
  833. SQLFreeStmt(ODBCCursor.FSTMTHandle, SQL_CLOSE),
  834. SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not close ODBC statement cursor.'
  835. );
  836. end;
  837. procedure TODBCConnection.AddFieldDefs(cursor: TSQLCursor; FieldDefs: TFieldDefs);
  838. const
  839. ColNameDefaultLength = 40; // should be > 0, because an ansistring of length 0 is a nil pointer instead of a pointer to a #0
  840. TypeNameDefaultLength = 80; // idem
  841. {$IF (FPC_VERSION>=2) AND (FPC_RELEASE>=1)}
  842. BLOB_BUF_SIZE = 0;
  843. {$ELSE}
  844. BLOB_BUF_SIZE = sizeof(pointer);
  845. {$ENDIF}
  846. var
  847. ODBCCursor:TODBCCursor;
  848. ColumnCount:SQLSMALLINT;
  849. i:integer;
  850. ColNameLength,TypeNameLength,DataType,DecimalDigits,Nullable:SQLSMALLINT;
  851. ColumnSize:SQLUINTEGER;
  852. ColName,TypeName:string;
  853. FieldType:TFieldType;
  854. FieldSize:word;
  855. begin
  856. ODBCCursor:=cursor as TODBCCursor;
  857. // get number of columns in result set
  858. ODBCCheckResult(
  859. SQLNumResultCols(ODBCCursor.FSTMTHandle, ColumnCount),
  860. SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not determine number of columns in result set.'
  861. );
  862. for i:=1 to ColumnCount do
  863. begin
  864. SetLength(ColName,ColNameDefaultLength); // also garantuees uniqueness
  865. // call with default column name buffer
  866. ODBCCheckResult(
  867. SQLDescribeCol(ODBCCursor.FSTMTHandle, // statement handle
  868. i, // column number, is 1-based (Note: column 0 is the bookmark column in ODBC)
  869. @(ColName[1]), // default buffer
  870. ColNameDefaultLength+1, // and its length; we include the #0 terminating any ansistring of Length > 0 in the buffer
  871. ColNameLength, // actual column name length
  872. DataType, // the SQL datatype for the column
  873. ColumnSize, // column size
  874. DecimalDigits, // number of decimal digits
  875. Nullable), // SQL_NO_NULLS, SQL_NULLABLE or SQL_NULLABLE_UNKNOWN
  876. SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not get column properties for column %d.',[i]
  877. );
  878. // truncate buffer or make buffer long enough for entire column name (note: the call is the same for both cases!)
  879. SetLength(ColName,ColNameLength);
  880. // check whether entire column name was returned
  881. if ColNameLength>ColNameDefaultLength then
  882. begin
  883. // request column name with buffer that is long enough
  884. ODBCCheckResult(
  885. SQLColAttribute(ODBCCursor.FSTMTHandle, // statement handle
  886. i, // column number
  887. SQL_DESC_NAME, // the column name or alias
  888. @(ColName[1]), // buffer
  889. ColNameLength+1, // buffer size
  890. @ColNameLength, // actual length
  891. nil), // no numerical output
  892. SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not get column name for column %d.',[i]
  893. );
  894. end;
  895. // convert type
  896. // NOTE: I made some guesses here after I found only limited information about TFieldType; please report any problems
  897. case DataType of
  898. SQL_CHAR: begin FieldType:=ftFixedChar; FieldSize:=ColumnSize+1; end;
  899. SQL_VARCHAR: begin FieldType:=ftString; FieldSize:=ColumnSize+1; end;
  900. SQL_LONGVARCHAR: begin FieldType:=ftMemo; FieldSize:=BLOB_BUF_SIZE; end; // is a blob
  901. {$IF (FPC_VERSION>=2) AND (FPC_RELEASE>=1)}
  902. SQL_WCHAR: begin FieldType:=ftFixedWideChar; FieldSize:=(ColumnSize+1)*sizeof(Widechar); end;
  903. SQL_WVARCHAR: begin FieldType:=ftWideString; FieldSize:=(ColumnSize+1)*sizeof(Widechar); end;
  904. SQL_WLONGVARCHAR: begin FieldType:=ftWideMemo; FieldSize:=BLOB_BUF_SIZE; end; // is a blob
  905. {$ENDIF}
  906. SQL_DECIMAL: begin FieldType:=ftFloat; FieldSize:=0; end;
  907. SQL_NUMERIC: begin FieldType:=ftFloat; FieldSize:=0; end;
  908. SQL_SMALLINT: begin FieldType:=ftSmallint; FieldSize:=0; end;
  909. SQL_INTEGER: begin FieldType:=ftInteger; FieldSize:=0; end;
  910. SQL_REAL: begin FieldType:=ftFloat; FieldSize:=0; end;
  911. SQL_FLOAT: begin FieldType:=ftFloat; FieldSize:=0; end;
  912. SQL_DOUBLE: begin FieldType:=ftFloat; FieldSize:=0; end;
  913. SQL_BIT: begin FieldType:=ftBoolean; FieldSize:=0; end;
  914. SQL_TINYINT: begin FieldType:=ftSmallint; FieldSize:=0; end;
  915. SQL_BIGINT: begin FieldType:=ftLargeint; FieldSize:=0; end;
  916. SQL_BINARY: begin FieldType:=ftBytes; FieldSize:=ColumnSize; end;
  917. SQL_VARBINARY: begin FieldType:=ftVarBytes; FieldSize:=ColumnSize; end;
  918. SQL_LONGVARBINARY: begin FieldType:=ftBlob; FieldSize:=BLOB_BUF_SIZE; end; // is a blob
  919. SQL_TYPE_DATE: begin FieldType:=ftDate; FieldSize:=0; end;
  920. SQL_TYPE_TIME: begin FieldType:=ftTime; FieldSize:=0; end;
  921. SQL_TYPE_TIMESTAMP:begin FieldType:=ftDateTime; FieldSize:=0; end;
  922. { SQL_TYPE_UTCDATETIME:FieldType:=ftUnknown;}
  923. { SQL_TYPE_UTCTIME: FieldType:=ftUnknown;}
  924. { SQL_INTERVAL_MONTH: FieldType:=ftUnknown;}
  925. { SQL_INTERVAL_YEAR: FieldType:=ftUnknown;}
  926. { SQL_INTERVAL_YEAR_TO_MONTH: FieldType:=ftUnknown;}
  927. { SQL_INTERVAL_DAY: FieldType:=ftUnknown;}
  928. { SQL_INTERVAL_HOUR: FieldType:=ftUnknown;}
  929. { SQL_INTERVAL_MINUTE: FieldType:=ftUnknown;}
  930. { SQL_INTERVAL_SECOND: FieldType:=ftUnknown;}
  931. { SQL_INTERVAL_DAY_TO_HOUR: FieldType:=ftUnknown;}
  932. { SQL_INTERVAL_DAY_TO_MINUTE: FieldType:=ftUnknown;}
  933. { SQL_INTERVAL_DAY_TO_SECOND: FieldType:=ftUnknown;}
  934. { SQL_INTERVAL_HOUR_TO_MINUTE: FieldType:=ftUnknown;}
  935. { SQL_INTERVAL_HOUR_TO_SECOND: FieldType:=ftUnknown;}
  936. { SQL_INTERVAL_MINUTE_TO_SECOND:FieldType:=ftUnknown;}
  937. {$IF (FPC_VERSION>=2) AND (FPC_RELEASE>=1)}
  938. SQL_GUID: begin FieldType:=ftGuid; FieldSize:=ColumnSize+1; end;
  939. {$ENDIF}
  940. else
  941. begin FieldType:=ftUnknown; FieldSize:=ColumnSize; end
  942. end;
  943. if (FieldType in [ftString,ftFixedChar]) and // field types mapped to TStringField
  944. (FieldSize >= dsMaxStringSize) then
  945. begin
  946. FieldSize:=dsMaxStringSize-1;
  947. end;
  948. if FieldType=ftUnknown then // if unknown field type encountered, try finding more specific information about the ODBC SQL DataType
  949. begin
  950. SetLength(TypeName,TypeNameDefaultLength); // also garantuees uniqueness
  951. ODBCCheckResult(
  952. SQLColAttribute(ODBCCursor.FSTMTHandle, // statement handle
  953. i, // column number
  954. SQL_DESC_TYPE_NAME, // FieldIdentifier indicating the datasource dependent data type name (useful for diagnostics)
  955. @(TypeName[1]), // default buffer
  956. TypeNameDefaultLength+1, // and its length; we include the #0 terminating any ansistring of Length > 0 in the buffer
  957. @TypeNameLength, // actual type name length
  958. nil // no need for a pointer to return a numeric attribute at
  959. ),
  960. SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not get datasource dependent type name for column %s.',[ColName]
  961. );
  962. // truncate buffer or make buffer long enough for entire column name (note: the call is the same for both cases!)
  963. SetLength(TypeName,TypeNameLength);
  964. // check whether entire column name was returned
  965. if TypeNameLength>TypeNameDefaultLength then
  966. begin
  967. // request column name with buffer that is long enough
  968. ODBCCheckResult(
  969. SQLColAttribute(ODBCCursor.FSTMTHandle, // statement handle
  970. i, // column number
  971. SQL_DESC_TYPE_NAME, // FieldIdentifier indicating the datasource dependent data type name (useful for diagnostics)
  972. @(TypeName[1]), // buffer
  973. TypeNameLength+1, // buffer size
  974. @TypeNameLength, // actual length
  975. nil), // no need for a pointer to return a numeric attribute at
  976. SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not get datasource dependent type name for column %s.',[ColName]
  977. );
  978. end;
  979. DatabaseErrorFmt('Column %s has an unknown or unsupported column type. Datasource dependent type name: %s. ODBC SQL data type code: %d.', [ColName, TypeName, DataType]);
  980. end;
  981. // add FieldDef
  982. TFieldDef.Create(FieldDefs, ColName, FieldType, FieldSize, False, i);
  983. end;
  984. end;
  985. procedure TODBCConnection.UpdateIndexDefs(IndexDefs: TIndexDefs; TableName: string);
  986. var
  987. StmtHandle:SQLHSTMT;
  988. Res:SQLRETURN;
  989. IndexDef: TIndexDef;
  990. KeyName: String;
  991. // variables for binding
  992. NonUnique :SQLSMALLINT; NonUniqueIndOrLen :SQLINTEGER;
  993. IndexName :string; IndexNameIndOrLen :SQLINTEGER;
  994. _Type :SQLSMALLINT; _TypeIndOrLen :SQLINTEGER;
  995. OrdinalPos:SQLSMALLINT; OrdinalPosIndOrLen:SQLINTEGER;
  996. ColName :string; ColNameIndOrLen :SQLINTEGER;
  997. AscOrDesc :SQLCHAR; AscOrDescIndOrLen :SQLINTEGER;
  998. PKName :string; PKNameIndOrLen :SQLINTEGER;
  999. const
  1000. DEFAULT_NAME_LEN = 255;
  1001. begin
  1002. // allocate statement handle
  1003. StmtHandle := SQL_NULL_HANDLE;
  1004. ODBCCheckResult(
  1005. SQLAllocHandle(SQL_HANDLE_STMT, FDBCHandle, StmtHandle),
  1006. SQL_HANDLE_DBC, FDBCHandle, 'Could not allocate ODBC Statement handle.'
  1007. );
  1008. try
  1009. // Disabled: only works if we can specify a SchemaName and, if supported by the data source, a CatalogName
  1010. // otherwise SQLPrimaryKeys returns error HY0009 (Invalid use of null pointer)
  1011. // set the SQL_ATTR_METADATA_ID so parameters to Catalog functions are considered as identifiers (e.g. case-insensitive)
  1012. //ODBCCheckResult(
  1013. // SQLSetStmtAttr(StmtHandle, SQL_ATTR_METADATA_ID, SQLPOINTER(SQL_TRUE), SQL_IS_UINTEGER),
  1014. // SQL_HANDLE_STMT, StmtHandle, 'Could not set SQL_ATTR_METADATA_ID statement attribute to SQL_TRUE.'
  1015. //);
  1016. // alloc result column buffers
  1017. SetLength(ColName, DEFAULT_NAME_LEN);
  1018. SetLength(PKName, DEFAULT_NAME_LEN);
  1019. SetLength(IndexName,DEFAULT_NAME_LEN);
  1020. // Fetch primary key info using SQLPrimaryKeys
  1021. ODBCCheckResult(
  1022. SQLPrimaryKeys(
  1023. StmtHandle,
  1024. nil, 0, // any catalog
  1025. nil, 0, // any schema
  1026. PChar(TableName), Length(TableName)
  1027. ),
  1028. SQL_HANDLE_STMT, StmtHandle, 'Could not retrieve primary key metadata for table %s using SQLPrimaryKeys.', [TableName]
  1029. );
  1030. // init key name & fields; we will set the IndexDefs.Option ixPrimary below when there is a match by IndexName=KeyName
  1031. KeyName:='';
  1032. try
  1033. // bind result columns; the column numbers are documented in the reference for SQLStatistics
  1034. ODBCCheckResult(SQLBindCol(StmtHandle, 4, SQL_C_CHAR , @ColName[1], Length(ColName)+1, @ColNameIndOrLen), SQL_HANDLE_STMT, StmtHandle, 'Could not bind primary key metadata column COLUMN_NAME.');
  1035. ODBCCheckResult(SQLBindCol(StmtHandle, 5, SQL_C_SSHORT, @OrdinalPos, 0, @OrdinalPosIndOrLen), SQL_HANDLE_STMT, StmtHandle, 'Could not bind primary key metadata column KEY_SEQ.');
  1036. ODBCCheckResult(SQLBindCol(StmtHandle, 6, SQL_C_CHAR , @PKName [1], Length(PKName )+1, @PKNameIndOrLen ), SQL_HANDLE_STMT, StmtHandle, 'Could not bind primary key metadata column PK_NAME.');
  1037. // fetch result
  1038. repeat
  1039. // go to next row; loads data in bound columns
  1040. Res:=SQLFetch(StmtHandle);
  1041. // if no more row, break
  1042. if Res=SQL_NO_DATA then
  1043. Break;
  1044. // handle data
  1045. if ODBCSucces(Res) then begin
  1046. if OrdinalPos=1 then begin
  1047. // create new IndexDef if OrdinalPos=1
  1048. IndexDef:=IndexDefs.AddIndexDef;
  1049. IndexDef.Name:=PChar(@PKName[1]);
  1050. IndexDef.Fields:=PChar(@ColName[1]);
  1051. IndexDef.Options:=IndexDef.Options+[ixUnique]+[ixPrimary]; // Primary key is always unique
  1052. KeyName:=IndexDef.Name;
  1053. end else begin
  1054. assert(Assigned(IndexDef));
  1055. IndexDef.Fields:=IndexDef.Fields+';'+PChar(@ColName[1]); // NB ; is the separator to be used for IndexDef.Fields
  1056. end;
  1057. end else begin
  1058. ODBCCheckResult(Res, SQL_HANDLE_STMT, StmtHandle, 'Could not fetch primary key metadata row.');
  1059. end;
  1060. until false;
  1061. finally
  1062. // unbind columns & close cursor
  1063. ODBCCheckResult(SQLFreeStmt(StmtHandle, SQL_UNBIND), SQL_HANDLE_STMT, StmtHandle, 'Could not unbind columns.');
  1064. ODBCCheckResult(SQLFreeStmt(StmtHandle, SQL_CLOSE), SQL_HANDLE_STMT, StmtHandle, 'Could not close cursor.');
  1065. end;
  1066. //WriteLn('KeyName: ',KeyName,'; KeyFields: ',KeyFields);
  1067. // use SQLStatistics to get index information
  1068. ODBCCheckResult(
  1069. SQLStatistics(
  1070. StmtHandle,
  1071. nil, 0, // catalog unkown; request for all catalogs
  1072. nil, 0, // schema unkown; request for all schemas
  1073. PChar(TableName), Length(TableName), // request information for TableName
  1074. SQL_INDEX_ALL,
  1075. SQL_QUICK
  1076. ),
  1077. SQL_HANDLE_STMT, StmtHandle, 'Could not retrieve index metadata for table %s using SQLStatistics.', [TableName]
  1078. );
  1079. try
  1080. // bind result columns; the column numbers are documented in the reference for SQLStatistics
  1081. ODBCCheckResult(SQLBindCol(StmtHandle, 4, SQL_C_SSHORT, @NonUnique , 0, @NonUniqueIndOrLen ), SQL_HANDLE_STMT, StmtHandle, 'Could not bind index metadata column NON_UNIQUE.');
  1082. ODBCCheckResult(SQLBindCol(StmtHandle, 6, SQL_C_CHAR , @IndexName[1], Length(IndexName)+1, @IndexNameIndOrLen), SQL_HANDLE_STMT, StmtHandle, 'Could not bind index metadata column INDEX_NAME.');
  1083. ODBCCheckResult(SQLBindCol(StmtHandle, 7, SQL_C_SSHORT, @_Type , 0, @_TypeIndOrLen ), SQL_HANDLE_STMT, StmtHandle, 'Could not bind index metadata column TYPE.');
  1084. ODBCCheckResult(SQLBindCol(StmtHandle, 8, SQL_C_SSHORT, @OrdinalPos, 0, @OrdinalPosIndOrLen), SQL_HANDLE_STMT, StmtHandle, 'Could not bind index metadata column ORDINAL_POSITION.');
  1085. ODBCCheckResult(SQLBindCol(StmtHandle, 9, SQL_C_CHAR , @ColName [1], Length(ColName )+1, @ColNameIndOrLen ), SQL_HANDLE_STMT, StmtHandle, 'Could not bind index metadata column COLUMN_NAME.');
  1086. ODBCCheckResult(SQLBindCol(StmtHandle, 10, SQL_C_CHAR , @AscOrDesc , 1, @AscOrDescIndOrLen ), SQL_HANDLE_STMT, StmtHandle, 'Could not bind index metadata column ASC_OR_DESC.');
  1087. // clear index defs
  1088. IndexDef:=nil;
  1089. // fetch result
  1090. repeat
  1091. // go to next row; loads data in bound columns
  1092. Res:=SQLFetch(StmtHandle);
  1093. // if no more row, break
  1094. if Res=SQL_NO_DATA then
  1095. Break;
  1096. // handle data
  1097. if ODBCSucces(Res) then begin
  1098. // note: SQLStatistics not only returns index info, but also statistics; we skip the latter
  1099. if _Type<>SQL_TABLE_STAT then begin
  1100. if PChar(@IndexName[1])=KeyName then begin
  1101. // The indexdef is already made as the primary key
  1102. // Only if the index is descending is not known yet.
  1103. if (AscOrDescIndOrLen<>SQL_NULL_DATA) and (AscOrDesc='D') then begin
  1104. IndexDef:=IndexDefs.Find(KeyName);
  1105. IndexDef.Options:=IndexDef.Options+[ixDescending];
  1106. end;
  1107. end else if (OrdinalPos=1) or not Assigned(IndexDef) then begin
  1108. // create new IndexDef iff OrdinalPos=1 or not Assigned(IndexDef) (the latter should not occur though)
  1109. IndexDef:=IndexDefs.AddIndexDef;
  1110. IndexDef.Name:=PChar(@IndexName[1]); // treat ansistring as zero terminated string
  1111. IndexDef.Fields:=PChar(@ColName[1]);
  1112. if NonUnique=SQL_FALSE then
  1113. IndexDef.Options:=IndexDef.Options+[ixUnique];
  1114. if (AscOrDescIndOrLen<>SQL_NULL_DATA) and (AscOrDesc='D') then
  1115. IndexDef.Options:=IndexDef.Options+[ixDescending];
  1116. // TODO: figure out how we can tell whether COLUMN_NAME is an expression or not
  1117. // if it is an expression, we should include ixExpression in Options and set Expression to ColName
  1118. end else // NB we re-use the last IndexDef
  1119. IndexDef.Fields:=IndexDef.Fields+';'+PChar(@ColName[1]); // NB ; is the separator to be used for IndexDef.Fields
  1120. end;
  1121. end else begin
  1122. ODBCCheckResult(Res, SQL_HANDLE_STMT, StmtHandle, 'Could not fetch index metadata row.');
  1123. end;
  1124. until false;
  1125. finally
  1126. // unbind columns & close cursor
  1127. ODBCCheckResult(SQLFreeStmt(StmtHandle, SQL_UNBIND), SQL_HANDLE_STMT, StmtHandle, 'Could not unbind columns.');
  1128. ODBCCheckResult(SQLFreeStmt(StmtHandle, SQL_CLOSE), SQL_HANDLE_STMT, StmtHandle, 'Could not close cursor.');
  1129. end;
  1130. finally
  1131. if StmtHandle<>SQL_NULL_HANDLE then begin
  1132. // Free the statement handle
  1133. Res:=SQLFreeHandle(SQL_HANDLE_STMT, StmtHandle);
  1134. if Res=SQL_ERROR then
  1135. ODBCCheckResult(Res, SQL_HANDLE_STMT, STMTHandle, 'Could not free ODBC Statement handle.');
  1136. end;
  1137. end;
  1138. end;
  1139. function TODBCConnection.GetSchemaInfoSQL(SchemaType: TSchemaType; SchemaObjectName, SchemaObjectPattern: string): string;
  1140. begin
  1141. if SchemaObjectName<>'' then
  1142. Result := SchemaObjectName
  1143. else
  1144. Result := ' ';
  1145. if not (SchemaType in [stNoSchema, stTables, stColumns, stProcedures]) then
  1146. DatabaseError(SMetadataUnavailable);
  1147. end;
  1148. { TODBCEnvironment }
  1149. constructor TODBCEnvironment.Create;
  1150. begin
  1151. // make sure odbc is loaded
  1152. if ODBCLoadCount=0 then InitialiseOdbc;
  1153. Inc(ODBCLoadCount);
  1154. // allocate environment handle
  1155. if SQLAllocHandle(SQL_HANDLE_ENV, SQL_NULL_HANDLE, FENVHandle)=SQL_Error then
  1156. raise EODBCException.Create('Could not allocate ODBC Environment handle'); // we can't retrieve any more information, because we don't have a handle for the SQLGetDiag* functions
  1157. // set odbc version
  1158. ODBCCheckResult(
  1159. SQLSetEnvAttr(FENVHandle, SQL_ATTR_ODBC_VERSION, SQLPOINTER(SQL_OV_ODBC3), 0),
  1160. SQL_HANDLE_ENV, FENVHandle,'Could not set ODBC version to 3.'
  1161. );
  1162. end;
  1163. destructor TODBCEnvironment.Destroy;
  1164. var
  1165. Res:SQLRETURN;
  1166. begin
  1167. // free environment handle
  1168. Res:=SQLFreeHandle(SQL_HANDLE_ENV, FENVHandle);
  1169. if Res=SQL_ERROR then
  1170. ODBCCheckResult(Res,SQL_HANDLE_ENV, FENVHandle, 'Could not free ODBC Environment handle.');
  1171. // free odbc if not used by any TODBCEnvironment object anymore
  1172. Dec(ODBCLoadCount);
  1173. if ODBCLoadCount=0 then ReleaseOdbc;
  1174. end;
  1175. { TODBCCursor }
  1176. constructor TODBCCursor.Create(Connection:TODBCConnection);
  1177. begin
  1178. {$IF NOT((FPC_VERSION>=2) AND (FPC_RELEASE>=1))}
  1179. // allocate FBlobStreams
  1180. FBlobStreams:=TList.Create;
  1181. {$ENDIF}
  1182. end;
  1183. destructor TODBCCursor.Destroy;
  1184. var
  1185. Res:SQLRETURN;
  1186. begin
  1187. {$IF NOT((FPC_VERSION>=2) AND (FPC_RELEASE>=1))}
  1188. FBlobStreams.Free;
  1189. {$ENDIF}
  1190. inherited Destroy;
  1191. end;
  1192. {$IF (FPC_VERSION>=2) AND (FPC_RELEASE>=1)}
  1193. class function TODBCConnectionDef.TypeName: String;
  1194. begin
  1195. Result:='ODBC';
  1196. end;
  1197. class function TODBCConnectionDef.ConnectionClass: TSQLConnectionClass;
  1198. begin
  1199. Result:=TODBCConnection;
  1200. end;
  1201. class function TODBCConnectionDef.Description: String;
  1202. begin
  1203. Result:='Connect to any database via an ODBC driver';
  1204. end;
  1205. initialization
  1206. RegisterConnection(TODBCConnectionDef);
  1207. {$ENDIF}
  1208. finalization
  1209. {$IF (FPC_VERSION>=2) AND (FPC_RELEASE>=1)}
  1210. UnRegisterConnection(TODBCConnectionDef);
  1211. {$ENDIF}
  1212. if Assigned(DefaultEnvironment) then
  1213. DefaultEnvironment.Free;
  1214. end.