ViewVC Help

View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing

root/public/ibx/trunk/runtime/IB.pas

Comparing ibx/trunk/runtime/IB.pas (file contents):
Revision 32 by tony, Tue Jul 14 15:31:25 2015 UTC vs.
Revision 33 by tony, Sat Jul 18 12:30:52 2015 UTC

#	Line 1 | Line 1
1	<	{************************************************************************}
2	<	{                                                                        }
3	<	{       Borland Delphi Visual Component Library                          }
4	<	{       InterBase Express core components                                }
5	<	{                                                                        }
6	<	{       Copyright (c) 1998-2000 Inprise Corporation                      }
7	<	{                                                                        }
8	<	{    InterBase Express is based in part on the product                   }
9	<	{    Free IB Components, written by Gregory H. Deatz for                 }
10	<	{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
11	<	{    Free IB Components is used under license.                           }
12	<	{                                                                        }
13	<	{    The contents of this file are subject to the InterBase              }
14	<	{    Public License Version 1.0 (the "License"); you may not             }
15	<	{    use this file except in compliance with the License. You            }
16	<	{    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17	<	{    Software distributed under the License is distributed on            }
18	<	{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
19	<	{    express or implied. See the License for the specific language       }
20	<	{    governing rights and limitations under the License.                 }
21	<	{    The Original Code was created by InterBase Software Corporation     }
22	<	{       and its successors.                                              }
23	<	{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
24	<	{       Corporation. All Rights Reserved.                                }
25	<	{    Contributor(s): Jeff Overcash                                       }
26	<	{                                                                        }
27	<	{    IBX For Lazarus (Firebird Express)                                  }
28	<	{    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29	<	{    Portions created by MWA Software are copyright McCallum Whyman      }
30	<	{    Associates Ltd 2011                                                 }
31	<	{                                                                        }
32	<	{************************************************************************}
33	<
34	<	unit IB;
35	<
36	<	{$Mode Delphi}
37	<
38	<	interface
39	<
40	<	uses
41	<	{$IFDEF WINDOWS }
42	<	Windows,
43	<	{$ELSE}
44	<	unix,
45	<	{$ENDIF}
46	<	SysUtils, Classes, IBExternals, IBUtils, DB, IBXConst, CustApp;
47	<
48	<	type
49	<	TIBGUIInterface = interface
50	<	function ServerLoginDialog(const AServerName: string;
51	<	var AUserName, APassword: string): Boolean;
52	<	function LoginDialogEx(const ADatabaseName: string;
53	<	var AUserName, APassword: string;
54	<	NameReadOnly: Boolean): Boolean;
55	<	procedure SetCursor;
56	<	procedure RestoreCursor;
57	<	end;
58	<
59	<	TTraceFlag = (tfQPrepare, tfQExecute, tfQFetch, tfError, tfStmt, tfConnect,
60	<	tfTransact, tfBlob, tfService, tfMisc);
61	<	TTraceFlags = set of TTraceFlag;
62	<
63	<	EIBError                  = class(EDatabaseError)
64	<	private
65	<	FSQLCode: Long;
66	<	FIBErrorCode: Long;
67	<	public
68	<	constructor Create(ASQLCode: Long; Msg: string); overload;
69	<	constructor Create(ASQLCode: Long; AIBErrorCode: Long; Msg: string); overload;
70	<	property SQLCode: Long read FSQLCode;
71	<	property IBErrorCode: Long read FIBErrorCode;
72	<	end;
73	<
74	<	EIBInterBaseError         = class(EIBError);
75	<	EIBClientError            = class(EIBError);
76	<
77	<	TIBDataBaseErrorMessage    = (ShowSQLCode,
78	<	ShowIBMessage,
79	<	ShowSQLMessage);
80	<	TIBDataBaseErrorMessages   = set of TIBDataBaseErrorMessage;
81	<	TIBClientError            = (
82	<	ibxeUnknownError,
83	<	ibxeInterBaseMissing,
84	<	ibxeInterBaseInstallMissing,
85	<	ibxeIB60feature,
86	<	ibxeNotSupported,
87	<	ibxeNotPermitted,
88	<	ibxeFileAccessError,
89	<	ibxeConnectionTimeout,
90	<	ibxeCannotSetDatabase,
91	<	ibxeCannotSetTransaction,
92	<	ibxeOperationCancelled,
93	<	ibxeDPBConstantNotSupported,
94	<	ibxeDPBConstantUnknown,
95	<	ibxeTPBConstantNotSupported,
96	<	ibxeTPBConstantUnknown,
97	<	ibxeDatabaseClosed,
98	<	ibxeDatabaseOpen,
99	<	ibxeDatabaseNameMissing,
100	<	ibxeNotInTransaction,
101	<	ibxeInTransaction,
102	<	ibxeTimeoutNegative,
103	<	ibxeNoDatabasesInTransaction,
104	<	ibxeUpdateWrongDB,
105	<	ibxeUpdateWrongTR,
106	<	ibxeDatabaseNotAssigned,
107	<	ibxeTransactionNotAssigned,
108	<	ibxeXSQLDAIndexOutOfRange,
109	<	ibxeXSQLDANameDoesNotExist,
110	<	ibxeEOF,
111	<	ibxeBOF,
112	<	ibxeInvalidStatementHandle,
113	<	ibxeSQLOpen,
114	<	ibxeSQLClosed,
115	<	ibxeDatasetOpen,
116	<	ibxeDatasetClosed,
117	<	ibxeUnknownSQLDataType,
118	<	ibxeInvalidColumnIndex,
119	<	ibxeInvalidParamColumnIndex,
120	<	ibxeInvalidDataConversion,
121	<	ibxeColumnIsNotNullable,
122	<	ibxeBlobCannotBeRead,
123	<	ibxeBlobCannotBeWritten,
124	<	ibxeEmptyQuery,
125	<	ibxeCannotOpenNonSQLSelect,
126	<	ibxeNoFieldAccess,
127	<	ibxeFieldReadOnly,
128	<	ibxeFieldNotFound,
129	<	ibxeNotEditing,
130	<	ibxeCannotInsert,
131	<	ibxeCannotPost,
132	<	ibxeCannotUpdate,
133	<	ibxeCannotDelete,
134	<	ibxeCannotRefresh,
135	<	ibxeBufferNotSet,
136	<	ibxeCircularReference,
137	<	ibxeSQLParseError,
138	<	ibxeUserAbort,
139	<	ibxeDataSetUniDirectional,
140	<	ibxeCannotCreateSharedResource,
141	<	ibxeWindowsAPIError,
142	<	ibxeColumnListsDontMatch,
143	<	ibxeColumnTypesDontMatch,
144	<	ibxeCantEndSharedTransaction,
145	<	ibxeFieldUnsupportedType,
146	<	ibxeCircularDataLink,
147	<	ibxeEmptySQLStatement,
148	<	ibxeIsASelectStatement,
149	<	ibxeRequiredParamNotSet,
150	<	ibxeNoStoredProcName,
151	<	ibxeIsAExecuteProcedure,
152	<	ibxeUpdateFailed,
153	<	ibxeNotCachedUpdates,
154	<	ibxeNotLiveRequest,
155	<	ibxeNoProvider,
156	<	ibxeNoRecordsAffected,
157	<	ibxeNoTableName,
158	<	ibxeCannotCreatePrimaryIndex,
159	<	ibxeCannotDropSystemIndex,
160	<	ibxeTableNameMismatch,
161	<	ibxeIndexFieldMissing,
162	<	ibxeInvalidCancellation,
163	<	ibxeInvalidEvent,
164	<	ibxeMaximumEvents,
165	<	ibxeNoEventsRegistered,
166	<	ibxeInvalidQueueing,
167	<	ibxeInvalidRegistration,
168	<	ibxeInvalidBatchMove,
169	<	ibxeSQLDialectInvalid,
170	<	ibxeSPBConstantNotSupported,
171	<	ibxeSPBConstantUnknown,
172	<	ibxeServiceActive,
173	<	ibxeServiceInActive,
174	<	ibxeServerNameMissing,
175	<	ibxeQueryParamsError,
176	<	ibxeStartParamsError,
177	<	ibxeOutputParsingError,
178	<	ibxeUseSpecificProcedures,
179	<	ibxeSQLMonitorAlreadyPresent,
180	<	ibxeCantPrintValue,
181	<	ibxeEOFReached,
182	<	ibxeEOFInComment,
183	<	ibxeEOFInString,
184	<	ibxeParamNameExpected,
185	<	ibxeSuccess,
186	<	ibxeDelphiException,
187	<	ibxeNoOptionsSet,
188	<	ibxeNoDestinationDirectory,
189	<	ibxeNosourceDirectory,
190	<	ibxeNoUninstallFile,
191	<	ibxeOptionNeedsClient,
192	<	ibxeOptionNeedsServer,
193	<	ibxeInvalidOption,
194	<	ibxeInvalidOnErrorResult,
195	<	ibxeInvalidOnStatusResult,
196	<	ibxeDPBConstantUnknownEx,
197	<	ibxeTPBConstantUnknownEx,
198	<	ibxeSV5APIError,
199	<	ibxeThreadFailed,
200	<	ibxeFieldSizeError,
201	<	ibxeTransactionNotEnding,
202	<	ibxeDscInfoTokenMissing,
203	<	ibxeNoLoginDialog
204	<	);
205	<
206	<	TStatusVector              = array[0..19] of ISC_STATUS;
207	<	PStatusVector              = ^TStatusVector;
208	<
209	<	{TResultBuffer inspired by IBPP RB class - access a isc_dsql_sql_info result buffer}
210	<
211	<	TResultBuffer = class
212	<	private
213	<	mBuffer: PChar;
214	<	mSize: short;
215	<	function FindToken(token: char): PChar; overload;
216	<	function FindToken(token: char; subtoken: char): PChar; overload;
217	<	public
218	<	constructor Create(aSize: integer = 1024);
219	<	destructor Destroy; override;
220	<	function Size: short;
221	<	procedure Reset;
222	<	function GetValue(token: char): integer; overload;
223	<	function GetValue(token: char; subtoken: char): integer; overload;
224	<	function GetCountValue(token: char): integer;
225	<	function GetBool(token: char): boolean;
226	<	function GetString(token: char; var data: string): integer;
227	<	function buffer: PChar;
228	<	end;
229	<
230	<	const
231	<	IBPalette1 = 'Firebird'; {do not localize}
232	<	IBPalette2 = 'Firebird Admin'; {do not localize}
233	<	IBPalette3 = 'Firebird Data Controls';   {do not localize}
234	<
235	<	IBLocalBufferLength = 512;
236	<	IBBigLocalBufferLength = IBLocalBufferLength * 2;
237	<	IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
238	<
239	<	IBErrorMessages: array[TIBClientError] of string = (
240	<	SUnknownError,
241	<	SInterBaseMissing,
242	<	SInterBaseInstallMissing,
243	<	SIB60feature,
244	<	SNotSupported,
245	<	SNotPermitted,
246	<	SFileAccessError,
247	<	SConnectionTimeout,
248	<	SCannotSetDatabase,
249	<	SCannotSetTransaction,
250	<	SOperationCancelled,
251	<	SDPBConstantNotSupported,
252	<	SDPBConstantUnknown,
253	<	STPBConstantNotSupported,
254	<	STPBConstantUnknown,
255	<	SDatabaseClosed,
256	<	SDatabaseOpen,
257	<	SDatabaseNameMissing,
258	<	SNotInTransaction,
259	<	SInTransaction,
260	<	STimeoutNegative,
261	<	SNoDatabasesInTransaction,
262	<	SUpdateWrongDB,
263	<	SUpdateWrongTR,
264	<	SDatabaseNotAssigned,
265	<	STransactionNotAssigned,
266	<	SXSQLDAIndexOutOfRange,
267	<	SXSQLDANameDoesNotExist,
268	<	SEOF,
269	<	SBOF,
270	<	SInvalidStatementHandle,
271	<	SSQLOpen,
272	<	SSQLClosed,
273	<	SDatasetOpen,
274	<	SDatasetClosed,
275	<	SUnknownSQLDataType,
276	<	SInvalidColumnIndex,
277	<	SInvalidParamColumnIndex,
278	<	SInvalidDataConversion,
279	<	SColumnIsNotNullable,
280	<	SBlobCannotBeRead,
281	<	SBlobCannotBeWritten,
282	<	SEmptyQuery,
283	<	SCannotOpenNonSQLSelect,
284	<	SNoFieldAccess,
285	<	SFieldReadOnly,
286	<	SFieldNotFound,
287	<	SNotEditing,
288	<	SCannotInsert,
289	<	SCannotPost,
290	<	SCannotUpdate,
291	<	SCannotDelete,
292	<	SCannotRefresh,
293	<	SBufferNotSet,
294	<	SCircularReference,
295	<	SSQLParseError,
296	<	SUserAbort,
297	<	SDataSetUniDirectional,
298	<	SCannotCreateSharedResource,
299	<	SWindowsAPIError,
300	<	SColumnListsDontMatch,
301	<	SColumnTypesDontMatch,
302	<	SCantEndSharedTransaction,
303	<	SFieldUnsupportedType,
304	<	SCircularDataLink,
305	<	SEmptySQLStatement,
306	<	SIsASelectStatement,
307	<	SRequiredParamNotSet,
308	<	SNoStoredProcName,
309	<	SIsAExecuteProcedure,
310	<	SUpdateFailed,
311	<	SNotCachedUpdates,
312	<	SNotLiveRequest,
313	<	SNoProvider,
314	<	SNoRecordsAffected,
315	<	SNoTableName,
316	<	SCannotCreatePrimaryIndex,
317	<	SCannotDropSystemIndex,
318	<	STableNameMismatch,
319	<	SIndexFieldMissing,
320	<	SInvalidCancellation,
321	<	SInvalidEvent,
322	<	SMaximumEvents,
323	<	SNoEventsRegistered,
324	<	SInvalidQueueing,
325	<	SInvalidRegistration,
326	<	SInvalidBatchMove,
327	<	SSQLDialectInvalid,
328	<	SSPBConstantNotSupported,
329	<	SSPBConstantUnknown,
330	<	SServiceActive,
331	<	SServiceInActive,
332	<	SServerNameMissing,
333	<	SQueryParamsError,
334	<	SStartParamsError,
335	<	SOutputParsingError,
336	<	SUseSpecificProcedures,
337	<	SSQLMonitorAlreadyPresent,
338	<	SCantPrintValue,
339	<	SEOFReached,
340	<	SEOFInComment,
341	<	SEOFInString,
342	<	SParamNameExpected,
343	<	SSuccess,
344	<	SDelphiException,
345	<	SNoOptionsSet,
346	<	SNoDestinationDirectory,
347	<	SNosourceDirectory,
348	<	SNoUninstallFile,
349	<	SOptionNeedsClient,
350	<	SOptionNeedsServer,
351	<	SInvalidOption,
352	<	SInvalidOnErrorResult,
353	<	SInvalidOnStatusResult,
354	<	SDPBConstantUnknownEx,
355	<	STPBConstantUnknownEx,
356	<	SSV5APIError,
357	<	SThreadFailed,
358	<	SFieldSizeError,
359	<	STransactionNotEnding,
360	<	SDscInfoTokenMissing,
361	<	SNoLoginDialog
362	<	);
363	<
364	<	const
365	<	IBGUIInterface: TIBGUIInterface = nil;
366	<
367	<
368	<	var
369	<	IBCS: TRTLCriticalSection;
370	<
371	<	procedure IBAlloc(var P; OldSize, NewSize: Integer);
372	<
373	<	procedure IBError(ErrMess: TIBClientError; const Args: array of const);
374	<	procedure IBDataBaseError;
375	<
376	<	function StatusVector: PISC_STATUS;
377	<	function StatusVectorArray: PStatusVector;
378	<	function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
379	<	function StatusVectorAsText: string;
380	<
381	<	procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
382	<	function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
383	<
384	<	implementation
385	<
386	<	uses
387	<	IBIntf, IBHeader;
388	<
389	<	var
390	<	IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
391	<	threadvar
392	<	FStatusVector : TStatusVector;
393	<
394	<	procedure IBAlloc(var P; OldSize, NewSize: Integer);
395	<	var
396	<	i: Integer;
397	<	begin
398	<	ReallocMem(Pointer(P), NewSize);
399	<	for i := OldSize to NewSize - 1 do PChar(P)[i] := #0;
400	<	end;
401	<
402	<	procedure IBError(ErrMess: TIBClientError; const Args: array of const);
403	<	begin
404	<	raise EIBClientError.Create(Ord(ErrMess),
405	<	Format(IBErrorMessages[ErrMess], Args));
406	<	end;
407	<
408	<	procedure IBDataBaseError;
409	<	var
410	<	sqlcode: Long;
411	<	IBErrorCode: Long;
412	<	local_buffer: array[0..IBHugeLocalBufferLength - 1] of char;
413	<	usr_msg: string;
414	<	status_vector: PISC_STATUS;
415	<	IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
416	<	begin
417	<	usr_msg := '';
418	<
419	<	{ Get a local reference to the status vector.
420	<	Get a local copy of the IBDataBaseErrorMessages options.
421	<	Get the SQL error code }
422	<	status_vector := StatusVector;
423	<	IBErrorCode := StatusVectorArray[1];
424	<	IBDataBaseErrorMessages := GetIBDataBaseErrorMessages;
425	<	sqlcode := isc_sqlcode(status_vector);
426	<
427	<	if (ShowSQLCode in IBDataBaseErrorMessages) then
428	<	usr_msg := usr_msg + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
429	<	Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
430	<	if (ShowSQLMessage in IBDataBaseErrorMessages) then
431	<	begin
432	<	isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
433	<	if (ShowSQLCode in IBDataBaseErrorMessages) then
434	<	usr_msg := usr_msg + CRLF;
435	<	usr_msg := usr_msg + strpas(local_buffer);
436	<	end;
437	<
438	<	if (ShowIBMessage in IBDataBaseErrorMessages) then
439	<	begin
440	<	if (ShowSQLCode in IBDataBaseErrorMessages) or
441	<	(ShowSQLMessage in IBDataBaseErrorMessages) then
442	<	usr_msg := usr_msg + CRLF;
443	<	while (isc_interprete(local_buffer, @status_vector) > 0) do
444	<	begin
445	<	if (usr_msg <> '') and (usr_msg[Length(usr_msg)] <> LF) then
446	<	usr_msg := usr_msg + CRLF;
447	<	usr_msg := usr_msg + strpas(local_buffer);
448	<	end;
449	<	end;
450	<	if (usr_msg <> '') and (usr_msg[Length(usr_msg)] = '.') then
451	<	Delete(usr_msg, Length(usr_msg), 1);
452	<	raise EIBInterBaseError.Create(sqlcode, IBErrorCode, usr_msg);
453	<	end;
454	<
455	<	{ Return the status vector for the current thread }
456	<	function StatusVector: PISC_STATUS;
457	<	begin
458	<	result := @FStatusVector;
459	<	end;
460	<
461	<	function StatusVectorArray: PStatusVector;
462	<	begin
463	<	result := @FStatusVector;
464	<	end;
465	<
466	<	function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
467	<	var
468	<	p: PISC_STATUS;
469	<	i: Integer;
470	<	procedure NextP(i: Integer);
471	<	begin
472	<	p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
473	<	end;
474	<	begin
475	<	p := @FStatusVector;
476	<	result := False;
477	<	while (p^ <> 0) and (not result) do
478	<	case p^ of
479	<	3: NextP(3);
480	<	1, 4:
481	<	begin
482	<	NextP(1);
483	<	i := 0;
484	<	while (i <= High(ErrorCodes)) and (not result) do
485	<	begin
486	<	result := p^ = ErrorCodes[i];
487	<	Inc(i);
488	<	end;
489	<	NextP(1);
490	<	end;
491	<	else
492	<	NextP(2);
493	<	end;
494	<	end;
495	<
496	<	function StatusVectorAsText: string;
497	<	var
498	<	p: PISC_STATUS;
499	<	function NextP(i: Integer): PISC_STATUS;
500	<	begin
501	<	p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
502	<	result := p;
503	<	end;
504	<	begin
505	<	p := @FStatusVector;
506	<	result := '';
507	<	while (p^ <> 0) do
508	<	if (p^ = 3) then
509	<	begin
510	<	result := result + Format('%d %d %d', [p^, NextP(1)^, NextP(1)^]) + CRLF;
511	<	NextP(1);
512	<	end
513	<	else begin
514	<	result := result + Format('%d %d', [p^, NextP(1)^]) + CRLF;
515	<	NextP(1);
516	<	end;
517	<	end;
518	<
519	<	{ TResultBuffer }
520	<
521	<	constructor TResultBuffer.Create(aSize: integer);
522	<	begin
523	<	inherited Create;
524	<	mSize := aSize;
525	<	GetMem(mBuffer,aSize);
526	<	FillChar(mBuffer^,mSize,255);
527	<	end;
528	<
529	<	destructor TResultBuffer.Destroy;
530	<	begin
531	<	if mBuffer <> nil then FreeMem(mBuffer);
532	<	inherited;
533	<	end;
534	<
535	<	function TResultBuffer.buffer: PChar;
536	<	begin
537	<	Result := mBuffer;
538	<	end;
539	<
540	<	function TResultBuffer.FindToken(token: char): PChar;
541	<	var p: PChar;
542	<	len: integer;
543	<	begin
544	<	Result := nil;
545	<	p := mBuffer;
546	<
547	<	while p^ <> char(isc_info_end) do
548	<	begin
549	<	if p^ = token then
550	<	begin
551	<	Result := p;
552	<	Exit;
553	<	end;
554	<	len := isc_vax_integer(p+1,2);
555	<	Inc(p,len+3);
556	<	end;
557	<	end;
558	<
559	<	function TResultBuffer.FindToken(token: char; subtoken: char): PChar;
560	<	var p: PChar;
561	<	len, inlen: integer;
562	<	begin
563	<	Result := nil;
564	<	p := mBuffer;
565	<
566	<	while p^ <> char(isc_info_end) do
567	<	begin
568	<	if p^ = token then
569	<	begin
570	<	{Found token, now find subtoken}
571	<	inlen := isc_vax_integer(p+1, 2);
572	<	Inc(p,3);
573	<	while inlen > 0 do
574	<	begin
575	<	if p^ = subtoken then
576	<	begin
577	<	Result := p;
578	<	Exit;
579	<	end;
580	<	len := isc_vax_integer(p+1, 2);
581	<	Inc(p,len + 3);
582	<	Dec(inlen,len + 3);
583	<	end;
584	<	Exit;
585	<	end;
586	<	len := isc_vax_integer(p+1, 2);
587	<	inc(p,len+3);
588	<	end;
589	<	end;
590	<
591	<	function TResultBuffer.GetBool(token: char): boolean;
592	<	var aValue: integer;
593	<	p: PChar;
594	<	begin
595	<	p := FindToken(token);
596	<
597	<	if p = nil then
598	<	IBError(ibxeDscInfoTokenMissing,[token]);
599	<
600	<	aValue := isc_vax_integer(p+1, 4);
601	<	Result := aValue <> 0;
602	<	end;
603	<
604	<	function TResultBuffer.GetCountValue(token: char): integer;
605	<	var len: integer;
606	<	p: PChar;
607	<	begin
608	<	{Specifically used on tokens like isc_info_insert_count and the like
609	<	which return detailed counts per relation. We sum up the values.}
610	<
611	<	p := FindToken(token);
612	<
613	<	if p = nil then
614	<	IBError(ibxeDscInfoTokenMissing,[token]);
615	<
616	<	{len is the number of bytes in the following array}
617	<
618	<	len := isc_vax_integer(p+1, 2);
619	<	Inc(p,3);
620	<	Result := 0;
621	<	while len > 0 do
622	<	begin
623	<	{Each array item is 6 bytes : 2 bytes for the relation_id which
624	<	we skip, and 4 bytes for the count value which we sum up across
625	<	all tables.}
626	<
627	<	Inc(Result,isc_vax_integer(p+2, 4));
628	<	Inc(p,6);
629	<	Dec(len,6);
630	<	end;
631	<	end;
632	<
633	<	function TResultBuffer.GetString(token: char; var data: string): integer;
634	<	var p: PChar;
635	<	begin
636	<	Result := 0;
637	<	p := FindToken(token);
638	<
639	<	if p = nil then
640	<	IBError(ibxeDscInfoTokenMissing,[token]);
641	<
642	<	Result := isc_vax_integer(p+1, 2);
643	<	SetString(data,p+3,Result);
644	<	end;
645	<
646	<	function TResultBuffer.GetValue(token: char): integer;
647	<	var len: integer;
648	<	p: PChar;
649	<	begin
650	<	Result := 0;
651	<	p := FindToken(token);
652	<
653	<	if p = nil then
654	<	IBError(ibxeDscInfoTokenMissing,[token]);
655	<
656	<	len := isc_vax_integer(p+1, 2);
657	<	if (len <> 0) then
658	<	Result := isc_vax_integer(p+3, len);
659	<	end;
660	<
661	<	function TResultBuffer.GetValue(token: char; subtoken: char): integer;
662	<	var len: integer;
663	<	p: PChar;
664	<	begin
665	<	Result := 0;
666	<	p := FindToken(token, subtoken);
667	<
668	<	if p = nil then
669	<	IBError(ibxeDscInfoTokenMissing,[token]);
670	<
671	<	len := isc_vax_integer(p+1, 2);
672	<	if (len <> 0) then
673	<	Result := isc_vax_integer(p+3, len);
674	<	end;
675	<
676	<	function TResultBuffer.Size: short;
677	<	begin
678	<	Result := mSize;
679	<	end;
680	<
681	<	procedure TResultBuffer.Reset;
682	<	begin
683	<	if mBuffer <> nil then FreeMem(mBuffer);
684	<	GetMem(mBuffer,mSize);
685	<	FillChar(mBuffer^,mSize,255);
686	<	end;
687	<
688	<
689	<	{ EIBError }
690	<	constructor EIBError.Create(ASQLCode: Long; Msg: string);
691	<	begin
692	<	inherited Create(Msg);
693	<	FSQLCode := ASQLCode;
694	<	end;
695	<
696	<	constructor EIBError.Create(ASQLCode: Long; AIBErrorCode: Long; Msg: string);
697	<	begin
698	<	inherited Create(Msg);
699	<	FSQLCode :=  ASQLCode;
700	<	FIBErrorCode := AIBErrorCode;
701	<	end;
702	<
703	<	procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
704	<	begin
705	<	EnterCriticalSection(IBCS);
706	<	try
707	<	IBDataBaseErrorMessages := Value;
708	<	finally
709	<	LeaveCriticalSection(IBCS);
710	<	end;
711	<	end;
712	<
713	<	function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
714	<	begin
715	<	EnterCriticalSection(IBCS);
716	<	try
717	<	result := IBDataBaseErrorMessages;
718	<	finally
719	<	LeaveCriticalSection(IBCS);
720	<	end;
721	<	end;
722	<
723	<	initialization
724	<	// IsMultiThread := True;
725	<	InitCriticalSection(IBCS);
726	<	IBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
727	<
728	<	finalization
729	<	DoneCriticalSection(IBCS);
730	<
731	<	end.
1	>	{************************************************************************}
2	>	{                                                                        }
3	>	{       Borland Delphi Visual Component Library                          }
4	>	{       InterBase Express core components                                }
5	>	{                                                                        }
6	>	{       Copyright (c) 1998-2000 Inprise Corporation                      }
7	>	{                                                                        }
8	>	{    InterBase Express is based in part on the product                   }
9	>	{    Free IB Components, written by Gregory H. Deatz for                 }
10	>	{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
11	>	{    Free IB Components is used under license.                           }
12	>	{                                                                        }
13	>	{    The contents of this file are subject to the InterBase              }
14	>	{    Public License Version 1.0 (the "License"); you may not             }
15	>	{    use this file except in compliance with the License. You            }
16	>	{    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17	>	{    Software distributed under the License is distributed on            }
18	>	{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
19	>	{    express or implied. See the License for the specific language       }
20	>	{    governing rights and limitations under the License.                 }
21	>	{    The Original Code was created by InterBase Software Corporation     }
22	>	{       and its successors.                                              }
23	>	{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
24	>	{       Corporation. All Rights Reserved.                                }
25	>	{    Contributor(s): Jeff Overcash                                       }
26	>	{                                                                        }
27	>	{    IBX For Lazarus (Firebird Express)                                  }
28	>	{    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29	>	{    Portions created by MWA Software are copyright McCallum Whyman      }
30	>	{    Associates Ltd 2011                                                 }
31	>	{                                                                        }
32	>	{************************************************************************}
33	>
34	>	unit IB;
35	>
36	>	{$Mode Delphi}
37	>
38	>	interface
39	>
40	>	uses
41	>	{$IFDEF WINDOWS }
42	>	Windows,
43	>	{$ELSE}
44	>	unix,
45	>	{$ENDIF}
46	>	SysUtils, Classes, IBExternals, IBUtils, DB, IBXConst, CustApp;
47	>
48	>	type
49	>	TIBGUIInterface = interface
50	>	function ServerLoginDialog(const AServerName: string;
51	>	var AUserName, APassword: string): Boolean;
52	>	function LoginDialogEx(const ADatabaseName: string;
53	>	var AUserName, APassword: string;
54	>	NameReadOnly: Boolean): Boolean;
55	>	procedure SetCursor;
56	>	procedure RestoreCursor;
57	>	end;
58	>
59	>	TTraceFlag = (tfQPrepare, tfQExecute, tfQFetch, tfError, tfStmt, tfConnect,
60	>	tfTransact, tfBlob, tfService, tfMisc);
61	>	TTraceFlags = set of TTraceFlag;
62	>
63	>	EIBError                  = class(EDatabaseError)
64	>	private
65	>	FSQLCode: Long;
66	>	FIBErrorCode: Long;
67	>	public
68	>	constructor Create(ASQLCode: Long; Msg: string); overload;
69	>	constructor Create(ASQLCode: Long; AIBErrorCode: Long; Msg: string); overload;
70	>	property SQLCode: Long read FSQLCode;
71	>	property IBErrorCode: Long read FIBErrorCode;
72	>	end;
73	>
74	>	EIBInterBaseError         = class(EIBError);
75	>	EIBClientError            = class(EIBError);
76	>
77	>	TIBDataBaseErrorMessage    = (ShowSQLCode,
78	>	ShowIBMessage,
79	>	ShowSQLMessage);
80	>	TIBDataBaseErrorMessages   = set of TIBDataBaseErrorMessage;
81	>	TIBClientError            = (
82	>	ibxeUnknownError,
83	>	ibxeInterBaseMissing,
84	>	ibxeInterBaseInstallMissing,
85	>	ibxeIB60feature,
86	>	ibxeNotSupported,
87	>	ibxeNotPermitted,
88	>	ibxeFileAccessError,
89	>	ibxeConnectionTimeout,
90	>	ibxeCannotSetDatabase,
91	>	ibxeCannotSetTransaction,
92	>	ibxeOperationCancelled,
93	>	ibxeDPBConstantNotSupported,
94	>	ibxeDPBConstantUnknown,
95	>	ibxeTPBConstantNotSupported,
96	>	ibxeTPBConstantUnknown,
97	>	ibxeDatabaseClosed,
98	>	ibxeDatabaseOpen,
99	>	ibxeDatabaseNameMissing,
100	>	ibxeNotInTransaction,
101	>	ibxeInTransaction,
102	>	ibxeTimeoutNegative,
103	>	ibxeNoDatabasesInTransaction,
104	>	ibxeUpdateWrongDB,
105	>	ibxeUpdateWrongTR,
106	>	ibxeDatabaseNotAssigned,
107	>	ibxeTransactionNotAssigned,
108	>	ibxeXSQLDAIndexOutOfRange,
109	>	ibxeXSQLDANameDoesNotExist,
110	>	ibxeEOF,
111	>	ibxeBOF,
112	>	ibxeInvalidStatementHandle,
113	>	ibxeSQLOpen,
114	>	ibxeSQLClosed,
115	>	ibxeDatasetOpen,
116	>	ibxeDatasetClosed,
117	>	ibxeUnknownSQLDataType,
118	>	ibxeInvalidColumnIndex,
119	>	ibxeInvalidParamColumnIndex,
120	>	ibxeInvalidDataConversion,
121	>	ibxeColumnIsNotNullable,
122	>	ibxeBlobCannotBeRead,
123	>	ibxeBlobCannotBeWritten,
124	>	ibxeEmptyQuery,
125	>	ibxeCannotOpenNonSQLSelect,
126	>	ibxeNoFieldAccess,
127	>	ibxeFieldReadOnly,
128	>	ibxeFieldNotFound,
129	>	ibxeNotEditing,
130	>	ibxeCannotInsert,
131	>	ibxeCannotPost,
132	>	ibxeCannotUpdate,
133	>	ibxeCannotDelete,
134	>	ibxeCannotRefresh,
135	>	ibxeBufferNotSet,
136	>	ibxeCircularReference,
137	>	ibxeSQLParseError,
138	>	ibxeUserAbort,
139	>	ibxeDataSetUniDirectional,
140	>	ibxeCannotCreateSharedResource,
141	>	ibxeWindowsAPIError,
142	>	ibxeColumnListsDontMatch,
143	>	ibxeColumnTypesDontMatch,
144	>	ibxeCantEndSharedTransaction,
145	>	ibxeFieldUnsupportedType,
146	>	ibxeCircularDataLink,
147	>	ibxeEmptySQLStatement,
148	>	ibxeIsASelectStatement,
149	>	ibxeRequiredParamNotSet,
150	>	ibxeNoStoredProcName,
151	>	ibxeIsAExecuteProcedure,
152	>	ibxeUpdateFailed,
153	>	ibxeNotCachedUpdates,
154	>	ibxeNotLiveRequest,
155	>	ibxeNoProvider,
156	>	ibxeNoRecordsAffected,
157	>	ibxeNoTableName,
158	>	ibxeCannotCreatePrimaryIndex,
159	>	ibxeCannotDropSystemIndex,
160	>	ibxeTableNameMismatch,
161	>	ibxeIndexFieldMissing,
162	>	ibxeInvalidCancellation,
163	>	ibxeInvalidEvent,
164	>	ibxeMaximumEvents,
165	>	ibxeNoEventsRegistered,
166	>	ibxeInvalidQueueing,
167	>	ibxeInvalidRegistration,
168	>	ibxeInvalidBatchMove,
169	>	ibxeSQLDialectInvalid,
170	>	ibxeSPBConstantNotSupported,
171	>	ibxeSPBConstantUnknown,
172	>	ibxeServiceActive,
173	>	ibxeServiceInActive,
174	>	ibxeServerNameMissing,
175	>	ibxeQueryParamsError,
176	>	ibxeStartParamsError,
177	>	ibxeOutputParsingError,
178	>	ibxeUseSpecificProcedures,
179	>	ibxeSQLMonitorAlreadyPresent,
180	>	ibxeCantPrintValue,
181	>	ibxeEOFReached,
182	>	ibxeEOFInComment,
183	>	ibxeEOFInString,
184	>	ibxeParamNameExpected,
185	>	ibxeSuccess,
186	>	ibxeDelphiException,
187	>	ibxeNoOptionsSet,
188	>	ibxeNoDestinationDirectory,
189	>	ibxeNosourceDirectory,
190	>	ibxeNoUninstallFile,
191	>	ibxeOptionNeedsClient,
192	>	ibxeOptionNeedsServer,
193	>	ibxeInvalidOption,
194	>	ibxeInvalidOnErrorResult,
195	>	ibxeInvalidOnStatusResult,
196	>	ibxeDPBConstantUnknownEx,
197	>	ibxeTPBConstantUnknownEx,
198	>	ibxeSV5APIError,
199	>	ibxeThreadFailed,
200	>	ibxeFieldSizeError,
201	>	ibxeTransactionNotEnding,
202	>	ibxeDscInfoTokenMissing,
203	>	ibxeNoLoginDialog
204	>	);
205	>
206	>	TStatusVector              = array[0..19] of ISC_STATUS;
207	>	PStatusVector              = ^TStatusVector;
208	>
209	>	{TResultBuffer inspired by IBPP RB class - access a isc_dsql_sql_info result buffer}
210	>
211	>	TResultBuffer = class
212	>	private
213	>	mBuffer: PChar;
214	>	mSize: short;
215	>	function FindToken(token: char): PChar; overload;
216	>	function FindToken(token: char; subtoken: char): PChar; overload;
217	>	public
218	>	constructor Create(aSize: integer = 1024);
219	>	destructor Destroy; override;
220	>	function Size: short;
221	>	procedure Reset;
222	>	function GetValue(token: char): integer; overload;
223	>	function GetValue(token: char; subtoken: char): integer; overload;
224	>	function GetCountValue(token: char): integer;
225	>	function GetBool(token: char): boolean;
226	>	function GetString(token: char; var data: string): integer;
227	>	function buffer: PChar;
228	>	end;
229	>
230	>	const
231	>	IBPalette1 = 'Firebird'; {do not localize}
232	>	IBPalette2 = 'Firebird Admin'; {do not localize}
233	>	IBPalette3 = 'Firebird Data Controls';   {do not localize}
234	>
235	>	IBLocalBufferLength = 512;
236	>	IBBigLocalBufferLength = IBLocalBufferLength * 2;
237	>	IBHugeLocalBufferLength = IBBigLocalBufferLength * 20;
238	>
239	>	IBErrorMessages: array[TIBClientError] of string = (
240	>	SUnknownError,
241	>	SInterBaseMissing,
242	>	SInterBaseInstallMissing,
243	>	SIB60feature,
244	>	SNotSupported,
245	>	SNotPermitted,
246	>	SFileAccessError,
247	>	SConnectionTimeout,
248	>	SCannotSetDatabase,
249	>	SCannotSetTransaction,
250	>	SOperationCancelled,
251	>	SDPBConstantNotSupported,
252	>	SDPBConstantUnknown,
253	>	STPBConstantNotSupported,
254	>	STPBConstantUnknown,
255	>	SDatabaseClosed,
256	>	SDatabaseOpen,
257	>	SDatabaseNameMissing,
258	>	SNotInTransaction,
259	>	SInTransaction,
260	>	STimeoutNegative,
261	>	SNoDatabasesInTransaction,
262	>	SUpdateWrongDB,
263	>	SUpdateWrongTR,
264	>	SDatabaseNotAssigned,
265	>	STransactionNotAssigned,
266	>	SXSQLDAIndexOutOfRange,
267	>	SXSQLDANameDoesNotExist,
268	>	SEOF,
269	>	SBOF,
270	>	SInvalidStatementHandle,
271	>	SSQLOpen,
272	>	SSQLClosed,
273	>	SDatasetOpen,
274	>	SDatasetClosed,
275	>	SUnknownSQLDataType,
276	>	SInvalidColumnIndex,
277	>	SInvalidParamColumnIndex,
278	>	SInvalidDataConversion,
279	>	SColumnIsNotNullable,
280	>	SBlobCannotBeRead,
281	>	SBlobCannotBeWritten,
282	>	SEmptyQuery,
283	>	SCannotOpenNonSQLSelect,
284	>	SNoFieldAccess,
285	>	SFieldReadOnly,
286	>	SFieldNotFound,
287	>	SNotEditing,
288	>	SCannotInsert,
289	>	SCannotPost,
290	>	SCannotUpdate,
291	>	SCannotDelete,
292	>	SCannotRefresh,
293	>	SBufferNotSet,
294	>	SCircularReference,
295	>	SSQLParseError,
296	>	SUserAbort,
297	>	SDataSetUniDirectional,
298	>	SCannotCreateSharedResource,
299	>	SWindowsAPIError,
300	>	SColumnListsDontMatch,
301	>	SColumnTypesDontMatch,
302	>	SCantEndSharedTransaction,
303	>	SFieldUnsupportedType,
304	>	SCircularDataLink,
305	>	SEmptySQLStatement,
306	>	SIsASelectStatement,
307	>	SRequiredParamNotSet,
308	>	SNoStoredProcName,
309	>	SIsAExecuteProcedure,
310	>	SUpdateFailed,
311	>	SNotCachedUpdates,
312	>	SNotLiveRequest,
313	>	SNoProvider,
314	>	SNoRecordsAffected,
315	>	SNoTableName,
316	>	SCannotCreatePrimaryIndex,
317	>	SCannotDropSystemIndex,
318	>	STableNameMismatch,
319	>	SIndexFieldMissing,
320	>	SInvalidCancellation,
321	>	SInvalidEvent,
322	>	SMaximumEvents,
323	>	SNoEventsRegistered,
324	>	SInvalidQueueing,
325	>	SInvalidRegistration,
326	>	SInvalidBatchMove,
327	>	SSQLDialectInvalid,
328	>	SSPBConstantNotSupported,
329	>	SSPBConstantUnknown,
330	>	SServiceActive,
331	>	SServiceInActive,
332	>	SServerNameMissing,
333	>	SQueryParamsError,
334	>	SStartParamsError,
335	>	SOutputParsingError,
336	>	SUseSpecificProcedures,
337	>	SSQLMonitorAlreadyPresent,
338	>	SCantPrintValue,
339	>	SEOFReached,
340	>	SEOFInComment,
341	>	SEOFInString,
342	>	SParamNameExpected,
343	>	SSuccess,
344	>	SDelphiException,
345	>	SNoOptionsSet,
346	>	SNoDestinationDirectory,
347	>	SNosourceDirectory,
348	>	SNoUninstallFile,
349	>	SOptionNeedsClient,
350	>	SOptionNeedsServer,
351	>	SInvalidOption,
352	>	SInvalidOnErrorResult,
353	>	SInvalidOnStatusResult,
354	>	SDPBConstantUnknownEx,
355	>	STPBConstantUnknownEx,
356	>	SSV5APIError,
357	>	SThreadFailed,
358	>	SFieldSizeError,
359	>	STransactionNotEnding,
360	>	SDscInfoTokenMissing,
361	>	SNoLoginDialog
362	>	);
363	>
364	>	const
365	>	IBGUIInterface: TIBGUIInterface = nil;
366	>
367	>
368	>	var
369	>	IBCS: TRTLCriticalSection;
370	>
371	>	procedure IBAlloc(var P; OldSize, NewSize: Integer);
372	>
373	>	procedure IBError(ErrMess: TIBClientError; const Args: array of const);
374	>	procedure IBDataBaseError;
375	>
376	>	function StatusVector: PISC_STATUS;
377	>	function StatusVectorArray: PStatusVector;
378	>	function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
379	>	function StatusVectorAsText: string;
380	>
381	>	procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
382	>	function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
383	>
384	>	implementation
385	>
386	>	uses
387	>	IBIntf, IBHeader;
388	>
389	>	var
390	>	IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
391	>	threadvar
392	>	FStatusVector : TStatusVector;
393	>
394	>	procedure IBAlloc(var P; OldSize, NewSize: Integer);
395	>	var
396	>	i: Integer;
397	>	begin
398	>	ReallocMem(Pointer(P), NewSize);
399	>	for i := OldSize to NewSize - 1 do PChar(P)[i] := #0;
400	>	end;
401	>
402	>	procedure IBError(ErrMess: TIBClientError; const Args: array of const);
403	>	begin
404	>	raise EIBClientError.Create(Ord(ErrMess),
405	>	Format(IBErrorMessages[ErrMess], Args));
406	>	end;
407	>
408	>	procedure IBDataBaseError;
409	>	var
410	>	sqlcode: Long;
411	>	IBErrorCode: Long;
412	>	local_buffer: array[0..IBHugeLocalBufferLength - 1] of char;
413	>	usr_msg: string;
414	>	status_vector: PISC_STATUS;
415	>	IBDataBaseErrorMessages: TIBDataBaseErrorMessages;
416	>	begin
417	>	usr_msg := '';
418	>
419	>	{ Get a local reference to the status vector.
420	>	Get a local copy of the IBDataBaseErrorMessages options.
421	>	Get the SQL error code }
422	>	status_vector := StatusVector;
423	>	IBErrorCode := StatusVectorArray[1];
424	>	IBDataBaseErrorMessages := GetIBDataBaseErrorMessages;
425	>	sqlcode := isc_sqlcode(status_vector);
426	>
427	>	if (ShowSQLCode in IBDataBaseErrorMessages) then
428	>	usr_msg := usr_msg + 'SQLCODE: ' + IntToStr(sqlcode); {do not localize}
429	>	Exclude(IBDataBaseErrorMessages, ShowSQLMessage);
430	>	if (ShowSQLMessage in IBDataBaseErrorMessages) then
431	>	begin
432	>	isc_sql_interprete(sqlcode, local_buffer, IBLocalBufferLength);
433	>	if (ShowSQLCode in IBDataBaseErrorMessages) then
434	>	usr_msg := usr_msg + CRLF;
435	>	usr_msg := usr_msg + strpas(local_buffer);
436	>	end;
437	>
438	>	if (ShowIBMessage in IBDataBaseErrorMessages) then
439	>	begin
440	>	if (ShowSQLCode in IBDataBaseErrorMessages) or
441	>	(ShowSQLMessage in IBDataBaseErrorMessages) then
442	>	usr_msg := usr_msg + CRLF;
443	>	while (isc_interprete(local_buffer, @status_vector) > 0) do
444	>	begin
445	>	if (usr_msg <> '') and (usr_msg[Length(usr_msg)] <> LF) then
446	>	usr_msg := usr_msg + CRLF;
447	>	usr_msg := usr_msg + strpas(local_buffer);
448	>	end;
449	>	end;
450	>	if (usr_msg <> '') and (usr_msg[Length(usr_msg)] = '.') then
451	>	Delete(usr_msg, Length(usr_msg), 1);
452	>	raise EIBInterBaseError.Create(sqlcode, IBErrorCode, usr_msg);
453	>	end;
454	>
455	>	{ Return the status vector for the current thread }
456	>	function StatusVector: PISC_STATUS;
457	>	begin
458	>	result := @FStatusVector;
459	>	end;
460	>
461	>	function StatusVectorArray: PStatusVector;
462	>	begin
463	>	result := @FStatusVector;
464	>	end;
465	>
466	>	function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
467	>	var
468	>	p: PISC_STATUS;
469	>	i: Integer;
470	>	procedure NextP(i: Integer);
471	>	begin
472	>	p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
473	>	end;
474	>	begin
475	>	p := @FStatusVector;
476	>	result := False;
477	>	while (p^ <> 0) and (not result) do
478	>	case p^ of
479	>	3: NextP(3);
480	>	1, 4:
481	>	begin
482	>	NextP(1);
483	>	i := 0;
484	>	while (i <= High(ErrorCodes)) and (not result) do
485	>	begin
486	>	result := p^ = ErrorCodes[i];
487	>	Inc(i);
488	>	end;
489	>	NextP(1);
490	>	end;
491	>	else
492	>	NextP(2);
493	>	end;
494	>	end;
495	>
496	>	function StatusVectorAsText: string;
497	>	var
498	>	p: PISC_STATUS;
499	>	function NextP(i: Integer): PISC_STATUS;
500	>	begin
501	>	p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
502	>	result := p;
503	>	end;
504	>	begin
505	>	p := @FStatusVector;
506	>	result := '';
507	>	while (p^ <> 0) do
508	>	if (p^ = 3) then
509	>	begin
510	>	result := result + Format('%d %d %d', [p^, NextP(1)^, NextP(1)^]) + CRLF;
511	>	NextP(1);
512	>	end
513	>	else begin
514	>	result := result + Format('%d %d', [p^, NextP(1)^]) + CRLF;
515	>	NextP(1);
516	>	end;
517	>	end;
518	>
519	>	{ TResultBuffer }
520	>
521	>	constructor TResultBuffer.Create(aSize: integer);
522	>	begin
523	>	inherited Create;
524	>	mSize := aSize;
525	>	GetMem(mBuffer,aSize);
526	>	FillChar(mBuffer^,mSize,255);
527	>	end;
528	>
529	>	destructor TResultBuffer.Destroy;
530	>	begin
531	>	if mBuffer <> nil then FreeMem(mBuffer);
532	>	inherited;
533	>	end;
534	>
535	>	function TResultBuffer.buffer: PChar;
536	>	begin
537	>	Result := mBuffer;
538	>	end;
539	>
540	>	function TResultBuffer.FindToken(token: char): PChar;
541	>	var p: PChar;
542	>	len: integer;
543	>	begin
544	>	Result := nil;
545	>	p := mBuffer;
546	>
547	>	while p^ <> char(isc_info_end) do
548	>	begin
549	>	if p^ = token then
550	>	begin
551	>	Result := p;
552	>	Exit;
553	>	end;
554	>	len := isc_vax_integer(p+1,2);
555	>	Inc(p,len+3);
556	>	end;
557	>	end;
558	>
559	>	function TResultBuffer.FindToken(token: char; subtoken: char): PChar;
560	>	var p: PChar;
561	>	len, inlen: integer;
562	>	begin
563	>	Result := nil;
564	>	p := mBuffer;
565	>
566	>	while p^ <> char(isc_info_end) do
567	>	begin
568	>	if p^ = token then
569	>	begin
570	>	{Found token, now find subtoken}
571	>	inlen := isc_vax_integer(p+1, 2);
572	>	Inc(p,3);
573	>	while inlen > 0 do
574	>	begin
575	>	if p^ = subtoken then
576	>	begin
577	>	Result := p;
578	>	Exit;
579	>	end;
580	>	len := isc_vax_integer(p+1, 2);
581	>	Inc(p,len + 3);
582	>	Dec(inlen,len + 3);
583	>	end;
584	>	Exit;
585	>	end;
586	>	len := isc_vax_integer(p+1, 2);
587	>	inc(p,len+3);
588	>	end;
589	>	end;
590	>
591	>	function TResultBuffer.GetBool(token: char): boolean;
592	>	var aValue: integer;
593	>	p: PChar;
594	>	begin
595	>	p := FindToken(token);
596	>
597	>	if p = nil then
598	>	IBError(ibxeDscInfoTokenMissing,[token]);
599	>
600	>	aValue := isc_vax_integer(p+1, 4);
601	>	Result := aValue <> 0;
602	>	end;
603	>
604	>	function TResultBuffer.GetCountValue(token: char): integer;
605	>	var len: integer;
606	>	p: PChar;
607	>	begin
608	>	{Specifically used on tokens like isc_info_insert_count and the like
609	>	which return detailed counts per relation. We sum up the values.}
610	>
611	>	p := FindToken(token);
612	>
613	>	if p = nil then
614	>	IBError(ibxeDscInfoTokenMissing,[token]);
615	>
616	>	{len is the number of bytes in the following array}
617	>
618	>	len := isc_vax_integer(p+1, 2);
619	>	Inc(p,3);
620	>	Result := 0;
621	>	while len > 0 do
622	>	begin
623	>	{Each array item is 6 bytes : 2 bytes for the relation_id which
624	>	we skip, and 4 bytes for the count value which we sum up across
625	>	all tables.}
626	>
627	>	Inc(Result,isc_vax_integer(p+2, 4));
628	>	Inc(p,6);
629	>	Dec(len,6);
630	>	end;
631	>	end;
632	>
633	>	function TResultBuffer.GetString(token: char; var data: string): integer;
634	>	var p: PChar;
635	>	begin
636	>	Result := 0;
637	>	p := FindToken(token);
638	>
639	>	if p = nil then
640	>	IBError(ibxeDscInfoTokenMissing,[token]);
641	>
642	>	Result := isc_vax_integer(p+1, 2);
643	>	SetString(data,p+3,Result);
644	>	end;
645	>
646	>	function TResultBuffer.GetValue(token: char): integer;
647	>	var len: integer;
648	>	p: PChar;
649	>	begin
650	>	Result := 0;
651	>	p := FindToken(token);
652	>
653	>	if p = nil then
654	>	IBError(ibxeDscInfoTokenMissing,[token]);
655	>
656	>	len := isc_vax_integer(p+1, 2);
657	>	if (len <> 0) then
658	>	Result := isc_vax_integer(p+3, len);
659	>	end;
660	>
661	>	function TResultBuffer.GetValue(token: char; subtoken: char): integer;
662	>	var len: integer;
663	>	p: PChar;
664	>	begin
665	>	Result := 0;
666	>	p := FindToken(token, subtoken);
667	>
668	>	if p = nil then
669	>	IBError(ibxeDscInfoTokenMissing,[token]);
670	>
671	>	len := isc_vax_integer(p+1, 2);
672	>	if (len <> 0) then
673	>	Result := isc_vax_integer(p+3, len);
674	>	end;
675	>
676	>	function TResultBuffer.Size: short;
677	>	begin
678	>	Result := mSize;
679	>	end;
680	>
681	>	procedure TResultBuffer.Reset;
682	>	begin
683	>	if mBuffer <> nil then FreeMem(mBuffer);
684	>	GetMem(mBuffer,mSize);
685	>	FillChar(mBuffer^,mSize,255);
686	>	end;
687	>
688	>
689	>	{ EIBError }
690	>	constructor EIBError.Create(ASQLCode: Long; Msg: string);
691	>	begin
692	>	inherited Create(Msg);
693	>	FSQLCode := ASQLCode;
694	>	end;
695	>
696	>	constructor EIBError.Create(ASQLCode: Long; AIBErrorCode: Long; Msg: string);
697	>	begin
698	>	inherited Create(Msg);
699	>	FSQLCode :=  ASQLCode;
700	>	FIBErrorCode := AIBErrorCode;
701	>	end;
702	>
703	>	procedure SetIBDataBaseErrorMessages(Value: TIBDataBaseErrorMessages);
704	>	begin
705	>	EnterCriticalSection(IBCS);
706	>	try
707	>	IBDataBaseErrorMessages := Value;
708	>	finally
709	>	LeaveCriticalSection(IBCS);
710	>	end;
711	>	end;
712	>
713	>	function GetIBDataBaseErrorMessages: TIBDataBaseErrorMessages;
714	>	begin
715	>	EnterCriticalSection(IBCS);
716	>	try
717	>	result := IBDataBaseErrorMessages;
718	>	finally
719	>	LeaveCriticalSection(IBCS);
720	>	end;
721	>	end;
722	>
723	>	initialization
724	>	// IsMultiThread := True;
725	>	InitCriticalSection(IBCS);
726	>	IBDataBaseErrorMessages := [ShowSQLMessage, ShowIBMessage];
727	>
728	>	finalization
729	>	DoneCriticalSection(IBCS);
730	>
731	>	end.

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines