fib.pas

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

   * Get a local copy of the IBErrorMessages options.
   * Get the SQL error code.
   *)
  status_vector := StatusVector;
  IBErrorMessages := GetIBErrorMessages;
  sqlcode := ClientLibrary.isc_sqlcode(status_vector);
  vIBMessage:='';
  vSQLMessage:='';
  (*
   * Maybe show the SQL Code
   *)
  (*
   * Maybe show the SQL Error message
   *)
  if (ShowSQLMessage in IBErrorMessages) then
  begin
//    ClientLibrary.isc_sql_interprete(sqlcode, local_buffer, FIBLocalBufferLength);
   ClientLibrary.isc_sql_interprete(sqlcode, local_buffer, FIBBigLocalBufferLength);


    vSQLMessage:=string(local_buffer);
    vSQLMessage := ReplaceStr(vSQLMessage, '\n', '');
    if Length(vSQLMessage)>0 then
    begin
     if (vSQLMessage[1] >= 'a') and (vSQLMessage[1] <= 'z') then
      Dec(vSQLMessage[1], 32);
     if (vSQLMessage[Length(vSQLMessage)] <> '.') then
      vSQLMessage := vSQLMessage + '.'+CLRF;
    end;
  end;
  (*
   * Maybe show the interbase error messages
   *)
  if (ShowIBMessage in IBErrorMessages) then
  begin
    vIBMessage:='';
    while (ClientLibrary.isc_interprete(local_buffer, @status_vector) > 0) do
    begin
      tmpStr  :=String(local_buffer);
      if Length(tmpStr)>0 then
      begin
        if (tmpStr[1] >= 'a') and (tmpStr[1] <= 'z') then
         Dec(tmpStr[1],32);
        vIBMessage:=vIBMessage+tmpStr;
        if (vIBMessage[Length(vIBMessage)] <> '.') then
          vIBMessage := vIBMessage + '.';
        vIBMessage := vIBMessage + CRLF;
      end;
    end;
  end;
  (*
   * Finally raise the exception
   *)
  vRaiseExcept:=true;
  vEFIBInterBaseError:=EFIBInterBaseError.CreateEx(sqlcode,vIBMessage,vSQLMessage,'',Sender); // '' by IMS
  try
    if ErrorHandlerRegistered   then
     IBErrorHandler.DoOnErrorEvent(Sender,vEFIBInterBaseError,vRaiseExcept);
  except
   vEFIBInterBaseError.Free;
   raise;
  end;
  if vRaiseExcept then
   raise vEFIBInterBaseError
  else
   vEFIBInterBaseError.Free;
end;                         


(* Return the status vector for the current thread *)
function StatusVector: PISC_STATUS;
begin
   Result := PISC_STATUS(@FStatusVector)
end;

function StatusVectorArray: PStatusVector;
begin
  Result := @FStatusVector;
end;


function CheckStatusVector(ErrorCodes: array of ISC_STATUS): Boolean;
var
  p: PISC_STATUS;
  i: Integer;
  procedure NextP(i: Integer);
  begin
    p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
  end;
begin
  p := StatusVector;
  Result := False;
  while (p^ <> 0) and (not Result) do
    case p^ of
      3: NextP(3);
      1, 4:
      begin
        NextP(1);
        i := 0;
        while (i <= High(ErrorCodes)) and (not Result) do
        begin
          Result := p^ = ErrorCodes[i];
          Inc(i);
        end;
        NextP(1);
      end;
    else
        NextP(2);
    end;
end;

function StatusVectorAsText: String;
var
  p: PISC_STATUS;
  function NextP(i: Integer): PISC_STATUS;
  begin
    p := PISC_STATUS(PChar(p) + (i * SizeOf(ISC_STATUS)));
    Result := p;
  end;
begin
  p := StatusVector;
  Result := '';
  while (p^ <> 0) do
    if (p^ = 3) then
    begin
      Result := Result + Format('%d %d %d', [p^, NextP(1)^, NextP(1)^]) + CRLF;
      NextP(1);
    end
    else
    begin
      Result := Result + Format('%d %d', [p^, NextP(1)^]) + CRLF;
      NextP(1);
    end;
end;

(* EFIBError *)

{ IMS }

procedure EFIBError.RebuildMessage;
var sn: string;
begin
  sn := '';
  if (ShowRaiserName in IBErrorMessages) and (Length(FRaiserName) > 1)
  then sn := FRaiserName + ':'#13#10;
  if (ShowSQLMessage in IBErrorMessages)
  then sn := sn + FSQLMessage;
  if (ShowIBMessage in IBErrorMessages)
  then sn := sn + FIBMessage;
  if length(FCustomMessage) > 0
  then sn := sn + FCustomMessage;
  sn := sn + FMsg;
  Message := sn;
end;

procedure EFIBError.SetSQLMessage(Value: string);
begin
  FSQLMessage := Value; RebuildMessage;
end;

procedure EFIBError.SetIBMessage(Value: string);
begin
  FIBMessage := Value; RebuildMessage;
end;

procedure EFIBError.SetCustomMessage(const Value: string);
begin
  FCustomMessage := Value; RebuildMessage;
end;

procedure EFIBError.SetMsg(const Value: string);
begin
  FMsg := Value; RebuildMessage;
end;

{ /IMS }

constructor EFIBError.Create(ASQLCode: Long; const aMsg: String;Sender:TObject);
// var sn:string;
begin
  if (Sender <> nil) and (Sender is TComponent)
  then FRaiserName := CmpFullName(TComponent(Sender))
  else FRaiserName := ''; // IMS
{ IMS
  if (Sender<>nil) and (Sender is TComponent)
   and (ShowRaiserName in IBErrorMessages)
  then
   sn:=CmpFullName(TComponent(Sender))+':'+#13#10
  else
   sn:='';
}
  inherited Create(''); // IMS - (sn+aMsg);
  Msg := aMsg; // IMS
  FSQLCode := ASQLCode;
  FIBErrorCode :=StatusVectorArray[1];
  SenderObj := Sender;
end;

// Added CstmMsg by IMS
constructor EFIBError.CreateEx(ASQLCode: Long; const IBMsg,SQLMsg,CstmMsg: String;Sender:TObject);
// var sn:string;
begin
{ IMS
  if Length(SQLMsg)>0 then
   sn:=SQLMsg
  else
    sn:='';
  if Length(IBMsg)>0 then  sn:=sn+IBMsg;
  // IMS
  if Length(CstmMsg)>0 then sn:=sn+CstmMsg;
}
  FSQLMessage :=SQLMsg;
  FIBMessage  :=IBMsg;
  // IMS
  FCustomMessage := CstmMsg;
  Create(ASQLCode,''{sn - IMS},Sender);
end;

(*
 * GenerateDPB -
 *  Given a string containing a textual representation
 *  of the database parameters, generate a database
 *  parameter buffer, and return it and its length
 *  in DPB and DPBLength, respectively.
 *)
procedure GenerateDPB(sl: TStrings; var DPB: String;
  var DPBLength: Short);
var
  i : integer;
  j, DPBVal:integer;
  param_name, param_value: String;
  pval: Integer;
begin
  (*
   * The DPB is initially empty, with the exception that
   * the DPB version must be the first byte of the string.
   *)
  DPBLength := 1;
  DPB := Char(isc_dpb_version1);
  (*
   * Iterate through the textual database parameters, constructing
   * a DPB 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_dpb_' prefix
     *)
    sl[i]:=FastTrim(sl[i]);
    if sl[i]='' then Continue;

    GetNameAndValue(sl[i],param_name,param_value);
    DoLowerCase(param_name);

    if (param_name[1]=DPBPrefix[1]) and (Pos(DPBPrefix, param_name) = 1) then
       param_name:=FastCopy(param_name,Length(DPBPrefix)+1,MaxInt);
//      Delete(param_name, 1, Length(DPBPrefix));
    (*
     * We want to translate the parameter name to some integer
     * value. We do this by scanning through a list of known
     * database parameter names (DPBConstantNames, defined above).
     *)
    if DPBConstants.Find(param_name,j) then
      DPBVal :=Integer(DPBConstants.Objects[j])
    else
      DPBVal := 0;

    (*
     * A database parameter either contains a string value (case 1)
     * or an integer value (case 2)
     * or no value at all (case 3)
     * or an error needs to be generated (case else)
     *)
    case DPBVal of
      isc_dpb_user_name, isc_dpb_password, isc_dpb_password_enc,
      isc_dpb_sys_user_name, isc_dpb_license, isc_dpb_encrypt_key,
      isc_dpb_lc_messages, isc_dpb_lc_ctype,
      isc_dpb_sql_role_name,isc_dpb_sql_dialect,
      isc_dpb_instance_name, isc_dpb_old_file
     :
      begin
        if DPBVal = isc_dpb_sql_dialect then
          param_value[1] := Char(Ord(param_value[1]) - 48);

        DPB := DPB +
               Char(DPBVal) +
               Char(Length(param_value)) +
               param_value;
        Inc(DPBLength, 2 + Length(param_value));
      end;
      isc_dpb_num_buffers, isc_dpb_dbkey_scope, isc_dpb_force_write,
      isc_dpb_no_reserve, isc_dpb_damaged, isc_dpb_verify,
      isc_dpb_dummy_packet_interval, isc_dpb_connect_timeout,
      isc_dpb_online_dump, isc_dpb_overwrite, isc_dpb_old_file_size
      :
      begin
        DPB := DPB +Char(DPBVal) +#1+Char(StrToInt(param_value));
        Inc(DPBLength, 3);
      end;
      isc_dpb_sweep:
      begin
        DPB := DPB +Char(DPBVal) +#1 +Char(isc_dpb_records);
        Inc(DPBLength, 3);
      end;
      isc_dpb_sweep_interval:
      begin
        pval := StrToInt(param_value);
        DPB := DPB +Char(DPBVal) +#4 +
               PChar(@pval)[0] +
               PChar(@pval)[1] +
               PChar(@pval)[2] +
               PChar(@pval)[3];
        Inc(DPBLength, 6);
      end;
      isc_dpb_activate_shadow, isc_dpb_delete_shadow, isc_dpb_begin_log,
      isc_dpb_quit_log:
      begin
        DPB := DPB +Char(DPBVal) +#1#0;
        Inc(DPBLength, 3);
      end;

      //
      isc_dpb_no_garbage_collect,isc_dpb_garbage_collect:
      begin
        DPB := DPB + Char(DPBVal) + #1#0;
        Inc(DPBLength, 3);
      end;
    else
      begin
        if (DPBVal > 0) and (DPBVal <= isc_dpb_last_dpb_constant) then
          FIBError(feDPBConstantNotSupported,[DPBConstantNames[DPBVal]])
        else
          FIBError(feDPBConstantUnknown, [param_name]);
      end;
    end;
  end;
end;

(*
 * GenerateTPB -
 *  Given a string containing a textual representation
 *  of the transaction parameters, generate a transaction
 *  parameter buffer, and return it and its length in
 *  TPB and TPBLength, respectively.
 *)
procedure GenerateTPB(sl: TStrings; var TPB: String;
  var TPBLength: Short);
var
  i, j, TPBVal, ParamLength: Integer;
  param_name, param_value: String;
begin
  TPB := '';
  if (sl.Count = 0) then
    TPBLength := 0
  else
  begin
    TPBLength := sl.Count + 1;
    TPB := TPB + Char(isc_tpb_version3);
  end;
  for i := 0 to sl.Count - 1 do
  begin
    sl[i]:=FastTrim(sl[i]);
    if sl[i]='' then
    begin
     Dec(TPBLength);
     Continue;
    end;
    GetNameAndValue(sl[i],param_name,param_value);
    DoLowerCase(param_name);
    {$IFDEF WINDOWS} {SVD}
    if (TPBPrefix[1] = param_name[1]) and (Pos(TPBPrefix, param_name) = 1) then
       param_name:=FastCopy(param_name,Length(TPBPrefix)+1,MaxInt);
    {$ENDIF}
    if TPBConstants.Find(param_name,j) then
      TPBVal :=Integer(TPBConstants.Objects[j])
    else
      TPBVal := 0;
    (* Now act on it *)
    case TPBVal of
      isc_tpb_consistency, isc_tpb_exclusive, isc_tpb_protected,
      isc_tpb_concurrency, isc_tpb_shared, isc_tpb_wait, isc_tpb_nowait,
      isc_tpb_read, isc_tpb_write, isc_tpb_ignore_limbo,
      isc_tpb_read_committed, isc_tpb_rec_version, isc_tpb_no_rec_version,
      isc_tpb_no_auto_undo,isc_tpb_no_savepoint:
        TPB := TPB + Char(TPBVal);
      isc_tpb_lock_read, isc_tpb_lock_write:
      begin
        TPB := TPB + Char(TPBVal);
        // Now set the string parameter
        ParamLength := Length(param_value);
        Inc(TPBLength, ParamLength + 1);
        TPB := TPB + Char(ParamLength) + param_value;
      end;
    else
      begin
        if (TPBVal > 0) and
           (TPBVal <= isc_tpb_last_tpb_constant) then
          FIBError(feTPBConstantNotSupported,
                   [TPBConstantNames[TPBVal]])
        else
          FIBError(feTPBConstantUnknown, [param_name]);
      end;
    end;
  end;
end;

procedure SetIBErrorMessages(Value: TIBErrorMessages);
begin
  EnterCriticalSection(FIBCS);
  try
    IBErrorMessages := Value;
  finally
    LeaveCriticalSection(FIBCS);
  end;
end;

function GetIBErrorMessages: TIBErrorMessages;
begin
  EnterCriticalSection(FIBCS);
  try
    Result := IBErrorMessages;
  finally
    LeaveCriticalSection(FIBCS);
  end;
end;

procedure InitTPBConstantsList;
var i:integer;
begin
  TPBConstants:= TStringList.Create;
  with TPBConstants do
  begin
   Capacity:=isc_tpb_last_tpb_constant;
   for i:=1 to isc_tpb_last_tpb_constant do
    AddObject(TPBConstantNames[i],TObject(i));
   Sorted:=true;
  end;
end;

procedure InitDPBConstantsList;
var i:integer;
begin
  DPBConstants:= TStringList.Create;
  with DPBConstants do
  begin
   Capacity:=isc_dpb_last_dpb_constant;
   for i:=1 to isc_dpb_last_dpb_constant do
    AddObject(DPBConstantNames[i],TObject(i));
   Sorted:=true;
  end;
end;


initialization
  InitializeCriticalSection(FIBCS);
  IBErrorMessages := [ShowSQLMessage, ShowIBMessage,ShowRaiserName];
  InitTPBConstantsList;
  InitDPBConstantsList;

finalization
  FreeAndNil(TPBConstants);
  FreeAndNil(DPBConstants);
  DeleteCriticalSection(FIBCS);
end.