jvuiblib.pas

East make Tray Icon in delphi

  function GetFacility(code: ISCStatus): Word;
  begin
    Result := (code and FAC_MASK) shr 16;
  end;

  function GetClass(code: ISCStatus): Word;
  begin
    Result := (code and CLASS_MASK) shr 30;
  end;

  function GETCode(code: ISCStatus): Word;
  begin
    Result := (code and CODE_MASK) shr 0;
  end;

  procedure TUIBLibrary.CheckUIBApiCall(const Status: ISCStatus);
  var
    Exception: EUIBError;
    Number: Integer;
    Excep: EUIBExceptionClass;
  begin
    if (Status <> 0) and FRaiseErrors then
    if (GetClass(Status) = CLASS_ERROR) then // only raise CLASS_ERROR
    begin
      case GetFacility(Status) of
        FAC_JRD     :
          if Status = isc_except then
        begin
          Number := FStatusVector[3];
          if assigned(FOnGetDBExceptionClass) then
          begin
            FOnGetDBExceptionClass(Number, Excep);
            Exception := Excep.Create(ErrInterprete)
          end else
            Exception := EUIBException.Create(ErrInterprete);
          EUIBException(Exception).FNumber := Number;
        end else
          Exception := EUIBError.Create(ErrInterprete);
        FAC_GFIX    : Exception := EUIBGFIXError.Create(ErrInterprete);
        FAC_DSQL    : Exception := EUIBDSQLError.Create(ErrInterprete);
        FAC_DYN     : Exception := EUIBDYNError.Create(ErrInterprete);
        FAC_GBAK    : Exception := EUIBGBAKError.Create(ErrInterprete);
        FAC_GSEC    : Exception := EUIBGSECError.Create(ErrInterprete);
        FAC_LICENSE : Exception := EUIBLICENSEError.Create(ErrInterprete);
        FAC_GSTAT   : Exception := EUIBGSTATError.Create(ErrInterprete);
      else
        Exception := EUIBError.Create(ErrInterprete);
      end;
      Exception.FSQLCode   := ErrSqlcode;
      if Exception.FSQLCode <> 0 then
        Exception.Message := Exception.Message + ErrSQLInterprete(Exception.FSQLCode) + BreakLine;
      Exception.FErrorCode := GETCode(Status);
      Exception.Message := Exception.Message + 'Error Code: ' + IntToStr(Exception.FErrorCode);
      if (Exception.FErrorCode = 401) and Assigned(FOnConnectionLost) then
        FOnConnectionLost(Self);
      raise Exception;
    end;
  end;

//******************************************************************************
// Database
//******************************************************************************


  constructor TUIBLibrary.Create;
  begin
    inherited;
    FRaiseErrors := True;
    FSegmentSize := 16*1024;
  end;

  function GetClientLibrary: string;
  {$IFDEF DLLREGISTRY}
  var
    Key: HKEY;
    Size: Cardinal;
    HR: Integer;
  {$ENDIF DLLREGISTRY}
  begin
  {$IFDEF DLLREGISTRY}
    HR := RegOpenKeyEx(HKEY_LOCAL_MACHINE, FBINSTANCES, 0, KEY_READ, Key);
    if (HR = ERROR_SUCCESS) then
    begin
      HR := RegQueryValueEx(Key, 'DefaultInstance', nil, nil, nil, @Size);
      if (HR = ERROR_SUCCESS) then
      begin
        SetLength(Result, Size);
        HR := RegQueryValueEx(Key, 'DefaultInstance', nil, nil, Pointer(Result), @Size);
        if (HR = ERROR_SUCCESS) then
          Result := Trim(Result)+ 'bin\' + GDS32DLL;
      end;
      RegCloseKey(Key);
    end;
    if (HR <> ERROR_SUCCESS) then
  {$ENDIF DLLREGISTRY}
    Result := GDS32DLL;
  end;

  function CreateDBParams(Params: String; Delimiter: Char = ';'): string;
  var
    BufferSize: Integer;
    CurPos, NextPos: PChar;
    CurStr, CurValue: String;
    EqualPos: Integer;
    Code: Byte;
    AValue: Integer;
    FinalSize: Integer;
    function Min(v1, v2: Integer): Integer;
    begin
      if v1 > v2 then Result := v2 else Result := v1;
    end;
    // dont reallocate memory each time, step by step ...
    procedure CheckBufferSize;
    begin
      while (FinalSize > BufferSize) do
        begin
          Inc(BufferSize, 32);
          SetLength(Result, BufferSize);
        end;
    end;
    procedure AddByte(AByte: Byte);
    begin
      inc(FinalSize);
      CheckBufferSize;
      Result[FinalSize] := chr(AByte);
    end;
    procedure AddWord(AWord: Word);
    begin
      inc(FinalSize,2);
      CheckBufferSize;
      PWord(@Result[FinalSize-1])^ := AWord;
    end;
    procedure AddCard(ACard: Cardinal);
    begin
      case ACard of
      0  ..   255 :
        begin
          AddByte(1);
          AddByte(Byte(ACard))
        end;
      256.. 65535 :
        begin
          AddByte(2);
          AddWord(Word(ACard))
        end;
      else
        AddByte(4);
        inc(FinalSize,4);
        CheckBufferSize;
        PCardinal(@Result[FinalSize-3])^ := ACard;
      end;
    end;
    procedure AddString(var AString: String);
    var l: Integer;
    begin
      l := Min(Length(AString), 255);
      inc(FinalSize,l+1);
      CheckBufferSize;
      Result[FinalSize-l] := chr(l);
      Move(PChar(AString)^, Result[FinalSize-l+1], l);
    end;

  begin
    FinalSize := 1;
    BufferSize := 32;
    SetLength(Result, BufferSize);
    Result[1] := chr(isc_dpb_version1);
    CurPos  := PChar(Params);
    while (CurPos <> nil) do
    begin
      NextPos := StrScan(CurPos, Delimiter);
      if (NextPos = nil) then
        CurStr := CurPos else
        begin
          CurStr := Copy(CurPos, 0, NextPos-CurPos);
          Inc(NextPos);
        end;
      CurPos := NextPos;
      if (CurStr = '') then Continue;
      begin
        CurValue := '';
        EqualPos := Pos('=', CurStr);
        if EqualPos <> 0 then
        begin
          CurValue := Copy(CurStr, EqualPos+1, Length(CurStr) - EqualPos);
          CurStr   := Copy(CurStr, 0, EqualPos-1);
        end;
        CurStr := Trim(LowerCase(CurStr));
        CurValue := Trim(CurValue);
        for Code := 1 to isc_dpb_Max_Value do
          with DPBInfos[Code] do
            if (Name = CurStr) then
            begin
              case ParamType of
                prNone : AddByte(Code);
                prByte :
                  if TryStrToInt(CurValue, AValue) and (AValue >= 0) and (AValue <= 255) then
                  begin
                    AddByte(Code);
                    AddByte(Byte(AValue));
                  end;
                prCard :
                  if TryStrToInt(CurValue, AValue) and (AValue > 0) then
                  begin
                    AddByte(Code);
                    AddCard(AValue);
                  end;
                prStrg :
                  if (Length(CurValue) > 0) then
                  begin
                    AddByte(Code);
                    AddString(CurValue)
                  end;
              end;
              break;
            end;
      end;
    end;
    SetLength(Result, FinalSize);
  end;

  procedure TUIBLibrary.AttachDatabase(FileName: String; var DbHandle: IscDbHandle;
    Params: String; Sep: Char = ';');
  begin
    Params := CreateDBParams(Params, Sep);
    Lock;
    try
      CheckUIBApiCall(isc_attach_database(@FStatusVector, Length(FileName), Pointer(FileName),
        @DBHandle, Length(Params), PChar(Params)));
    finally
      UnLock;
    end;
  end;

  procedure TUIBLibrary.DetachDatabase(var DBHandle: IscDbHandle);
  begin
    Lock;
    try
      CheckUIBApiCall(isc_detach_database(@FStatusVector, @DBHandle));
      // if connection lost DBHandle must be set manually to nil.
      DBHandle := nil;
    finally
      UnLock;
    end;
  end;

  function StrToCharacterSet(const CharacterSet: string): TCharacterSet;
  var
    len: Integer;
  begin
    len := length(CharacterSet);
    for Result := low(TCharacterSet) to High(TCharacterSet) do
      if (len = Length(CharacterSetStr[Result])) and
        (CompareText(CharacterSetStr[Result], CharacterSet) = 0) then
          Exit;
    raise Exception.CreateFmt(EUIB_CHARSETNOTFOUND, [CharacterSet]);
  end;  

//******************************************************************************
// Transaction
//******************************************************************************

  procedure TUIBLibrary.TransactionStart(var TraHandle: IscTrHandle; var DbHandle: IscDbHandle;
    const TPB: string = '');
  var Vector: TISCTEB;
  begin
    Vector.Handle  := @DbHandle;
    Vector.Len     := Length(TPB);
    Vector.Address := PChar(TPB);
    TransactionStartMultiple(TraHandle, 1, @Vector);
  end;

  procedure TUIBLibrary.TransactionStartMultiple(var TraHandle: IscTrHandle; DBCount: Smallint; Vector: PISCTEB);
  begin
    Lock;
    try
      CheckUIBApiCall(isc_start_multiple(@FStatusVector, @TraHandle, DBCount, Vector));
    finally
      UnLock;
    end;
  end;

  procedure TUIBLibrary.TransactionCommit(var TraHandle: IscTrHandle);
  begin
    Lock;
    try
      CheckUIBApiCall(isc_commit_transaction(@FStatusVector, @TraHandle));
      // if connection lost TraHandle must be set manually to nil.
      TraHandle := nil;
    finally
      UnLock;
    end;
  end;

  procedure TUIBLibrary.TransactionRollback(var TraHandle: IscTrHandle);
  begin
    Lock;
    try
      CheckUIBApiCall(isc_rollback_transaction(@FStatusVector, @TraHandle));
      // if connection lost TraHandle must be set manually to nil.
      TraHandle := nil;
    finally
      UnLock;
    end;
  end;

  procedure TUIBLibrary.TransactionCommitRetaining(var TraHandle: IscTrHandle);
  begin
    Lock;
    try
      CheckUIBApiCall(isc_commit_retaining(@FStatusVector, @TraHandle));
    finally
      UnLock;
    end;
  end;

  procedure TUIBLibrary.TransactionPrepare(var TraHandle: IscTrHandle);
  begin