ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IB.pas
Revision: 33
Committed: Sat Jul 18 12:30:52 2015 UTC (8 years, 8 months ago) by tony
Content type: text/x-pascal
File size: 19337 byte(s)
Log Message:
Committing updates for Release R1-3-1

File Contents

# Content
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.