ib_services.pas

FIBPlus is a component suite intended for work with InterBase. It is direct, fast and flexible Inter

      FProtocol := TCP
    else
      if (FProtocol <> Local) and (FServerName = '') then
        FProtocol := Local;
  end;
end;

procedure TpFIBCustomService.SetProtocol(const Value: TProtocol);
begin
  if FProtocol <> Value then
  begin
    CheckInactive;
    FProtocol := Value;
    if (Value = Local) then
      FServerName := '';
  end;
end;

procedure TpFIBCustomService.SetServiceParamBySPB(const Idx: Integer;
  const Value: String);
var
  ConstIdx: Integer;
begin
  ConstIdx := IndexOfSPBConst(SPBConstantNames[Idx]);
  if (Value = '') then
  begin
    if ConstIdx <> -1 then
      Params.Delete(ConstIdx);
  end
  else
  begin
    if (ConstIdx = -1) then
      Params.Add(SPBConstantNames[Idx] + '=' + Value)
    else
      Params[ConstIdx] := SPBConstantNames[Idx] + '=' + Value;
  end;
end;

function TpFIBCustomService.IndexOfSPBConst(st: String): Integer;
var
  i, pos_of_str: Integer;
begin
  result := -1;
  for i := 0 to Params.Count - 1 do
  begin
    pos_of_str := Pos(st, Params[i]); {mbcs ok}
    if (pos_of_str = 1) or (pos_of_str = Length(SPBPrefix) + 1) then
    begin
      result := i;
      break;
    end;
  end;
end;

procedure TpFIBCustomService.ParamsChange(Sender: TObject);
begin
  FParamsChanged := True;
end;

procedure TpFIBCustomService.ParamsChanging(Sender: TObject);
begin
  CheckInactive;
end;

procedure TpFIBCustomService.CheckServerName;
begin
  if (FServerName = '') and (FProtocol <> Local) then
    FIBError(feServerNameMissing, [nil]);
end;

function TpFIBCustomService.Call(ErrCode: ISC_STATUS;
  RaiseError: Boolean): ISC_STATUS;
begin
  result := ErrCode;
  if RaiseError and (ErrCode > 0) then
    IBError(FClientLibrary, Self);
end;

function TpFIBCustomService.ParseString(var RunLen: Integer): string;
var
  Len: UShort;
  tmp: Char;
begin
  LoadLibrary;
  Len := FClientLibrary.isc_vax_integer(OutputBuffer + RunLen, 2);
  RunLen := RunLen + 2;
  if (Len <> 0) then
  begin
    tmp := OutputBuffer[RunLen + Len];
    OutputBuffer[RunLen + Len] := #0;
    result := String(PChar(@OutputBuffer[RunLen]));
    OutputBuffer[RunLen + Len] := tmp;
    RunLen := RunLen + Len;
  end
  else
    result := '';
end;

function TpFIBCustomService.ParseInteger(var RunLen: Integer): Integer;
begin
  LoadLibrary;
  Result := FClientLibrary.isc_vax_integer(OutputBuffer + RunLen, 4);
  RunLen := RunLen + 4;
end;

{
 * GenerateSPB -
 *  Given a string containing a textual representation
 *  of the Service parameters, generate a service
 *  parameter buffer, and return it and its length
 *  in SPB and SPBLength, respectively.
}
procedure TpFIBCustomService.GenerateSPB(sl: TStrings; var SPB: String;
  var SPBLength: Short);
var
  i, j : Integer;
  SPBVal, SPBServerVal: UShort;
  param_name, param_value: String;
begin
  { The SPB is initially empty, with the exception that
   the SPB version must be the first byte of the string.
  }
  SPBLength := 2;
  SPB := Char(isc_spb_version);
  SPB := SPB + Char(isc_spb_current_version);
  { Iterate through the textual service parameters, constructing
   a SPB on-the-fly}
  for i := 0 to sl.Count - 1 do
  begin
   { Get the parameter's name and value from the list,
     and make sure that the name is all lowercase with
     no leading 'isc_spb_' prefix }
    if (Trim(sl.Names[i]) = '') then
      continue;
    param_name := LowerCase(sl.Names[i]); {mbcs ok}
    param_value := Copy(sl[i], Pos('=', sl[i]) + 1, Length(sl[i])); {mbcs ok}
    if (Pos(SPBPrefix, param_name) = 1) then {mbcs ok}
      Delete(param_name, 1, Length(SPBPrefix));
    { We want to translate the parameter name to some integer
      value. We do this by scanning through a list of known
      service parameter names (SPBConstantNames, defined above). }
    SPBVal := 0;
    SPBServerVal := 0;
    { Find the parameter }
    for j := 1 to isc_spb_last_spb_constant do
      if (param_name = SPBConstantNames[j]) then
      begin
        SPBVal := j;
        SPBServerVal := SPBConstantValues[j];
        break;
      end;
    case SPBVal of
      isc_spb_user_name, isc_spb_password, isc_spb_sql_role_name:
      begin
        SPB := SPB +
               Char(SPBServerVal) +
               Char(Length(param_value)) +
               param_value;
        Inc(SPBLength, 2 + Length(param_value));
      end;
      else
      begin
        if (SPBVal > 0) and
           (SPBVal <= isc_dpb_last_dpb_constant) then
          FIBError(feSPBConstantNotSupported,
                   [SPBConstantNames[SPBVal]])
        else
          FIBError(feSPBConstantUnknown, [SPBVal]);
      end;
    end;
  end;
end;

procedure TpFIBCustomService.SetLibraryName(const Value: string);
begin
  CheckInactive;
  if FLibraryName <> Value then
  begin
    FLibraryName := Value;
    FClientLibrary := nil;
  end;
end;

function TpFIBCustomService.StoredLibraryName: Boolean;
begin
  Result := FLibraryName <> IBASE_DLL;
end;

{ TpFIBServerProperties }
constructor TpFIBServerProperties.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDatabaseInfo := TDatabaseInfo.Create;
  FLicenseInfo := TLicenseInfo.Create;
  FLicenseMaskInfo := TLicenseMaskInfo.Create;
  FVersionInfo := TVersionInfo.Create;
  FConfigParams := TConfigParams.Create;
end;

destructor TpFIBServerProperties.Destroy;
begin
  FDatabaseInfo.Free;
  FLicenseInfo.Free;
  FLicenseMaskInfo.Free;
  FVersionInfo.Free;
  FConfigParams.Free;
  inherited Destroy;
end;

procedure TpFIBServerProperties.ParseConfigFileData(var RunLen: Integer);
begin
  Inc(RunLen);
  with FConfigParams.ConfigFileData do
  begin
    SetLength (ConfigFileValue, Length(ConfigFileValue)+1);
    SetLength (ConfigFileKey, Length(ConfigFileKey)+1);

    ConfigFileKey[High(ConfigFileKey)] := Integer(OutputBuffer[RunLen-1]);
    ConfigFileValue[High(ConfigFileValue)] := ParseInteger(RunLen);
  end;
end;

procedure TpFIBServerProperties.Fetch;
begin
  if (Database in Options) then
    FetchDatabaseInfo;
  if (License in Options) then
    FetchLicenseInfo;
  if (LicenseMask in Options) then
    FetchLicenseMaskInfo;
  if (ConfigParameters in Options) then
    FetchConfigParams;
  if (Version in Options) then
    FetchVersionInfo;
end;

procedure TpFIBServerProperties.FetchConfigParams;
var
  RunLen: Integer;

begin
  ServiceQueryParams := Char(isc_info_svc_get_config) +
                        Char(isc_info_svc_get_env) +
                        Char(isc_info_svc_get_env_lock) +
                        Char(isc_info_svc_get_env_msg) +
                        Char(isc_info_svc_user_dbpath);

  InternalServiceQuery;
  RunLen := 0;
  While (not (Integer(OutputBuffer[RunLen]) = isc_info_end)) do
  begin
    case Integer(OutputBuffer[RunLen]) of
      isc_info_svc_get_config:
      begin
        FConfigParams.ConfigFileData.ConfigFileKey := nil;
        FConfigParams.ConfigFileData.ConfigFileValue := nil;
        Inc (RunLen);
        while (not (Integer(OutputBuffer[RunLen]) = isc_info_flag_end)) do
          ParseConfigFileData (RunLen);
        if (Integer(OutputBuffer[RunLen]) = isc_info_flag_end) then
          Inc (RunLen);
      end;

      isc_info_svc_get_env:
      begin
        Inc (RunLen);
        FConfigParams.BaseLocation := ParseString(RunLen);
      end;

      isc_info_svc_get_env_lock:
      begin
        Inc (RunLen);
        FConfigParams.LockFileLocation := ParseString(RunLen);
      end;

      isc_info_svc_get_env_msg:
      begin
        Inc (RunLen);
        FConfigParams.MessageFileLocation := ParseString(RunLen);
      end;

      isc_info_svc_user_dbpath:
      begin
        Inc (RunLen);
        FConfigParams.SecurityDatabaseLocation := ParseString(RunLen);
      end;
      else
        FIBError(feOutputParsingError, [nil]);
    end;
  end;
end;

procedure TpFIBServerProperties.FetchDatabaseInfo;
var
  i, RunLen: Integer;
begin
  ServiceQueryParams := Char(isc_info_svc_svr_db_info);
  InternalServiceQuery;
  if (OutputBuffer[0] <> Char(isc_info_svc_svr_db_info)) then
      FIBError(feOutputParsingError, [nil]);
  RunLen := 1;
  if (OutputBuffer[RunLen] <> Char(isc_spb_num_att)) then
      FIBError(feOutputParsingError, [nil]);
  Inc(RunLen);
  FDatabaseInfo.NoOfAttachments := ParseInteger(RunLen);
  if (OutputBuffer[RunLen] <> Char(isc_spb_num_db)) then
      FIBError(feOutputParsingError, [nil]);
  Inc(RunLen);
  FDatabaseInfo.NoOfDatabases := ParseInteger(RunLen);
  FDatabaseInfo.DbName := nil;
  SetLength(FDatabaseInfo.DbName, FDatabaseInfo.NoOfDatabases);
  i := 0;
  while (OutputBuffer[RunLen] <> Char(isc_info_flag_end)) do
  begin
    if (OutputBuffer[RunLen] <> Char(SPBConstantValues[isc_spb_dbname])) then
      FIBError(feOutputParsingError, [nil]);
    Inc(RunLen);
    FDatabaseInfo.DbName[i] := ParseString(RunLen);
    Inc (i);
  end;
end;

procedure TpFIBServerProperties.FetchLicenseInfo;
var
  i, RunLen: Integer;
  done: Integer;
begin
  ServiceQueryParams := Char(isc_info_svc_get_license) +
                        Char(isc_info_svc_get_licensed_users);
  InternalServiceQuery;
  RunLen := 0;
  done := 0;
  i := 0;
  FLicenseInfo.key := nil;
  FLicenseInfo.id := nil;
  FLicenseInfo.desc := nil;

  While done < 2 do begin
    Inc(Done);
    Inc(RunLen);
    case Integer(OutputBuffer[RunLen-1]) of
      isc_info_svc_get_license:
      begin
        while (OutputBuffer[RunLen] <> Char(isc_info_flag_end)) do
        begin
          if (i >= Length(FLicenseInfo.key)) then
          begin
            SetLength(FLicenseInfo.key, i + 10);
            SetLength(FLicenseInfo.id, i + 10);
            SetLength(FLicenseInfo.desc, i + 10);
          end;
          if (OutputBuffer[RunLen] <> Char(isc_spb_lic_id)) then
              FIBError(feOutputParsingError, [nil]);
          Inc(RunLen);
          FLicenseInfo.id[i] := ParseString(RunLen);
          if (OutputBuffer[RunLen] <> Char(isc_spb_lic_key)) then
              FIBError(feOutputParsingError, [nil]);
          Inc(RunLen);
          FLicenseInfo.key[i] := ParseString(RunLen);
          if (OutputBuffer[RunLen] <> Char(7)) then
              FIBError(feOutputParsingError, [nil]);
          Inc(RunLen);
          FLicenseInfo.desc[i] := ParseString(RunLen);
          Inc(i);
        end;
        Inc(RunLen);
        if (Length(FLicenseInfo.key) > i) then
        begin
          SetLength(FLicenseInfo.key, i);
          SetLength(FLicenseInfo.id, i);
          SetLength(FLicenseInfo.desc, i);
        end;
      end;
      isc_info_svc_get_licensed_users:
        FLicenseInfo.LicensedUsers := ParseInteger(RunLen);
      else
        FIBError(feOutputParsingError, [nil]);
    end;
  end;
end;

procedure TpFIBServerProperties.FetchLicenseMaskInfo();
var
  done,RunLen:integer;
begin
  ServiceQueryParams := Char(isc_info_svc_get_license_mask) +
                        Char(isc_info_svc_capabilities);
  InternalServiceQuery;
  RunLen := 0;
  done := 0;
  While done <= 1 do
  begin
    Inc(done);
    Inc(RunLen);
    case Integer(OutputBuffer[RunLen-1]) of
      isc_info_svc_get_license_mask:
        FLicenseMaskInfo.LicenseMask := ParseInteger(RunLen);
      isc_info_svc_capabilities:
        FLicenseMaskInfo.CapabilityMask := ParseInteger(RunLen);
      else
        FIBError(feOutputParsingError, [nil]);
    end;
  end;
end;


procedure TpFIBServerProperties.FetchVersionInfo;
var
  RunLen: Integer;
  done: Integer;
begin
  ServiceQueryParams := Char(isc_info_svc_version) +
                        Char(isc_info_svc_server_version) +
                        Char(isc_info_svc_implementation);
  InternalServiceQuery;
  RunLen := 0;
  done := 0;

  While done <= 2 do
  begin