zdiribsql.pas

控件名称：WINZEOS.ZIP 2002年08月03日 作者：CapellaDevelopment Zeos系列构件套件包含一组可直接存取Linux知名的免费数据库MySQL、Postgre

{**************** TDirIbSqlConnect implementation ************}

{ Class constructor }
constructor TDirIbSqlConnect.Create;
begin
  inherited Create;
  FParams := TIbParamList.Create;
  FHandle := nil;
  FDialect := 1;
end;

{ Class destructor }
destructor TDirIbSqlConnect.Destroy;
begin
  inherited Destroy;
  FParams.Free;
end;

{ Get status vector item }
function TDirIbSqlConnect.GetStatusVector(Index: Word): ISC_STATUS;
begin
  Result := FStatusVector[Index];
end;

{ Set status vector item }
procedure TDirIbSqlConnect.SetStatusVector(Index: Word; Value: ISC_STATUS);
begin
  FStatusVector[Index] := Value;
end;

function TDirIbSqlConnect.HasError: Boolean;
begin
  Result := (StatusVector[0] = 1) and (StatusVector[1] > 0);
end;

{ Check result code }
function TDirIbSqlConnect.CheckResult(Cmd: string): Boolean;
begin
  if (StatusVector[0] = 1) and (StatusVector[1] > 0) then
    SetStatus(csFail)
  else
    SetStatus(csOk);
  Result := (Status = csOk);
  if Cmd <> '' then
    MonitorList.InvokeEvent(Cmd, Error, not Result);
end;

{ Get full database name with host name }
function TDirIbSqlConnect.GetFullDbName: string;
begin
  Result := Trim(Database);
  HostName := Trim(HostName);
  if HostName <> '' then
    Result := HostName + ':' + Result;
end;

{ Connect to existed database }
procedure TDirIbSqlConnect.Connect;
var
  Temp: string;
  DBName: array[0..512] of Char;
  DPB: PChar;
  DPBLen: Word;
begin
  inherited Connect;
  CheckIbSqlLoaded;

  if Login <> '' then
    Params.Add(isc_dpb_user_name, Login);
  if Passwd <> '' then
    Params.Add(isc_dpb_password, Passwd);
  Params.GenerateDPB(Temp, DPBLen);
  DPBLen := Length(Temp);
  DPB := StrAlloc(DPBLen + 1);
  StrPCopy(DPB, Temp);
  StrPCopy(DBName, GetFullDbName);

  { Connect database }
  FHandle := nil;
  isc_attach_database(@FStatusVector, StrLen(DBName), DBName, @Handle,
    DPBLen, DPB);
  StrDispose(DPB);

  SetActive(CheckResult(Format('CONNECT ''%s''', [GetFullDbName])));
end;

{ Disconnect from database }
procedure TDirIbSqlConnect.Disconnect;
begin
  if Active then
  begin
    isc_detach_database(@FStatusVector, @Handle);
    CheckResult(Format('DISCONNECT ''%s''', [GetFullDbName]));
    SetActive(False);
  end;
end;

{ Create new database }
procedure TDirIbSqlConnect.CreateDatabase(Params: string);
var
  TrHandle: TISC_TR_HANDLE;
  Buffer: string;
begin
  inherited CreateDatabase(Params);
  CheckIbSqlLoaded;
  Disconnect;
  TrHandle := nil;

  Buffer := Format('CREATE DATABASE ''%s'' USER ''%s'' PASSWORD ''%s'' %s',
    [GetFullDbName, Login, Passwd, Params]);
  isc_dsql_execute_immediate(@FStatusVector, @Handle, @TrHandle, 0,
    PChar(Buffer), Dialect, nil);
  CheckResult(Buffer);
end;

{ Drop existed database }
procedure TDirIbSqlConnect.DropDatabase;
begin
  if not Active then Connect;
  if Active then
  begin
    isc_drop_database(@FStatusVector, @Handle);
    CheckResult(Format('DROP DATABASE ''%s''', [GetFullDbName]));
    SetActive(False);
  end;
end;

{ Get Interbase Database Error }
function TDirIbSqlConnect.GetErrorMsg: ShortString;
var
  PStatusVector: PISC_STATUS;
  Msg: array[0..1024] of Char;
begin
  if (FStatusVector[0] = 1) and (FStatusVector[1] > 0) then
  begin
    PStatusVector := @FStatusVector;
    isc_interprete(Msg, @PStatusVector);
    Result := StrPas(Msg);
  end else if not Active then
    Result := SNotConnected
  else Result := '';
end;

{************* TDirIbSqlTransact implementation *************}

{ Class constructor }
constructor TDirIbSqlTransact.Create(AConnect: TDirIbSqlConnect);
begin
  inherited Create;
  FParams := TIbParamList.Create;
  FHandle := nil;
  Connect := AConnect;
end;

{ Class destructor }
destructor TDirIbSqlTransact.Destroy;
begin
  inherited Destroy;
  FParams.Free;
end;

{ Connect transaction }
procedure TDirIbSqlTransact.Open;
begin
  inherited Open;
  SetStatus(csFail);
  StartTransaction;
  SetActive(Status = csOk);
end;

{ Disconnect transaction }
procedure TDirIbSqlTransact.Close;
begin
  EndTransaction;
  SetActive(False);
end;

{ Start transaction }
procedure TDirIbSqlTransact.StartTransaction;
var
  Temp: string;
  PTPB: PChar;
  TPBLen: Word;
  PTEB: PISC_TEB;
  TempParams: TIbParamList;
begin
  SetStatus(csFail);
  if not Assigned(Connect) or not Connect.Active then
    Exit;

  TempParams := TIbParamList.Create;
  try
    case TransIsolation of
      itConsistency:
        begin
          TempParams.Add(isc_tpb_consistency, '');
        end;
      itConcurrency :
        begin
          TempParams.Add(isc_tpb_concurrency, '');
        end;
      itReadCommitted:
        begin
          TempParams.Add(isc_tpb_read_committed, '');
          TempParams.Add(isc_tpb_no_rec_version, '');
        end;
      itReadCommittedRec:
        begin
          TempParams.Add(isc_tpb_read_committed, '');
          TempParams.Add(isc_tpb_rec_version, '');
        end;
    end;
    TempParams.AddParams(Params);
    TempParams.Add(isc_tpb_nowait, '');
    TempParams.GenerateTPB(Temp, TPBLen);
  finally
    TempParams.Free;
  end;
  TPBLen := Length(Temp);
  if TPBLen > 0 then
  begin
    PTPB := StrAlloc(TPBLen + 1);
    PTPB := StrPCopy(PTPB, Temp);
  end else
    PTPB := nil;

  FHandle := nil;
  PTEB := AllocMem(Sizeof(TISC_TEB));
  try
    {
     //problem with GDS32.dll ---> ib6
     isc_start_transaction(@TDirIbSqlConnect(Connect).FStatusVector, @FHandle, 1,
       @TDirIbSqlConnect(Connect).Handle, TPBLen, PTPB);
    }

    //ajouter par fourat-----> isc_start_multiple
    with PTEB^ do
    begin
      db_handle := @TDirIbSqlConnect(Connect).FHandle;
      tpb_length := TPBLen;
      tpb_address := PTPB;
    end;

    isc_start_multiple(@TDirIbSqlConnect(Connect).FStatusVector, @FHandle, 1, PTEB);
  finally
    StrDispose(PTPB);
    FreeMem(PTEB);
  end;

  TDirIbSqlConnect(Connect).CheckResult('START TRANSACTION');
  SetStatus(Connect.Status);
end;

{ End transaction }
procedure TDirIbSqlTransact.EndTransaction;
begin
  SetStatus(csFail);
  if Active then
  begin
    isc_rollback_transaction(@TDirIbSqlConnect(Connect).FStatusVector, @Handle);
    TDirIbSqlConnect(Connect).CheckResult('END TRANSACTION');
    SetStatus(Connect.Status);
    FHandle := nil;
  end else
    SetStatus(csOk);
end;

{ Commit transaction }
procedure TDirIbSqlTransact.Commit;
begin
  SetStatus(csFail);
  if Active then
  begin
    isc_commit_retaining(@TDirIbSqlConnect(Connect).FStatusVector, @Handle);
    TDirIbSqlConnect(Connect).CheckResult('COMMIT');
    SetStatus(Connect.Status);
  end;
end;

{ Rollback transaction }
procedure TDirIbSqlTransact.Rollback;
begin
  SetStatus(csFail);
  if Active then
  begin
    if GetIbSqlClientVersion >= 6 then
    begin
      isc_rollback_retaining(@TDirIbSqlConnect(Connect).FStatusVector, @Handle);
      TDirIbSqlConnect(Connect).CheckResult('ROLLBACK');
      SetStatus(Connect.Status);
    end
    else
    begin
      isc_rollback_transaction(@TDirIbSqlConnect(Connect).FStatusVector, @Handle);
      TDirIbSqlConnect(Connect).CheckResult('ROLLBACK');
      SetStatus(Connect.Status);
      if Connect.Status = csOk then
        StartTransaction;
    end;
  end;
end;

{************* TDirIbSqlQuery implementation ************}

{ Class constructor }
constructor TDirIbSqlQuery.Create(AConnect: TDirIbSqlConnect;
  ATransact: TDirIbSqlTransact);
begin
  inherited Create;
  Connect := AConnect;
  Transact := ATransact;

  FOutSqlDa := AllocMem(XSQLDA_LENGTH(MAX_XSQLVAR));
  FOutSqlDa.version := SQLDA_VERSION1;
  FOutSqlDa.sqln := MAX_XSQLVAR;

  FInSqlDa := AllocMem(XSQLDA_LENGTH(MAX_XSQLVAR));
  FInSqlDa.version := SQLDA_VERSION1;
  FInSqlDa.sqln := MAX_XSQLVAR;

  FHandle := nil;
  FPrepared := False;
  FStatementType := stUnknown;
end;

{ Class destructor }
destructor TDirIbSqlQuery.Destroy;
begin
  inherited Destroy;
  FreeMem(FInSqlDa);
  FreeMem(FOutSqlDa);
  FreeStatement;
end;

{ Get an error message }
function TDirIbSqlQuery.GetErrorMsg: ShortString;
var
  Msg: array[0..1024] of Char;
  SqlCode: LongInt;
  LastError: string;
  PStatusVector: PISC_STATUS;
  IbConnect: TDirIbSqlConnect;
begin
  Result := 'Connection is not defined';
  if not Assigned(Connect) then Exit;
  IbConnect := TDirIbSqlConnect(Connect);

  if IbConnect.HasError then
  begin
    PStatusVector := @IbConnect.FStatusVector;
    while isc_interprete(Msg, @PStatusVector) <> 0 do
    begin
      LastError := Trim(StrPas(Msg));
      if LastError <> '' then
      begin
        if Result <> '' then
          Result := Result + #13#10;
          Result := Result + LastError;
      end;
    end;

    SqlCode := isc_sqlcode(@IbConnect.FStatusVector);
    isc_sql_interprete(SqlCode, Msg, 1024);

    if Result <> '' then
      Result := Result + #13#10;
    Result := Result + Trim(StrPas(Msg));
  end;
end;

procedure TDirIbSqlQuery.AbortOnError;
var
  IbConnect: TDirIbSqlConnect;
begin
  IbConnect := TDirIbSqlConnect(Connect);
  IbConnect.CheckResult('');
  if IbConnect.HasError then
  begin
    SetStatus(qsFail);
    Abort;
  end;
end;

function TDirIbSqlQuery.GetPlan: string;
var
  Out_buffer: array[0..16384] of Char;
  Out_length: Integer;
  req_info: Char;
  IbConnect: TDirIbSqlConnect;
begin
  IbConnect := TDirIbSqlConnect(Connect);
  if (FHandle = nil) or (not FPrepared) or
    not (FStatementType in [stSelect, stSelectForUpdate,
    {stExecProc,} stUpdate, stDelete]) then
    Result := ''
  else
  begin
    req_info := Char(isc_info_sql_get_plan);

    isc_dsql_sql_info(@IbConnect.FStatusVector, @FHandle,
      1, @req_info, SizeOf(Out_buffer), Out_buffer);

    if Out_buffer[0] <> Char(isc_info_sql_get_plan) then
      DatabaseError('Unknown Plan');

    Out_length := isc_vax_integer(@Out_buffer[1], 2);

    SetString(result, nil, Out_length);
    Move(Out_buffer[3], Result[1], Out_length);
    Result := Trim(result);
  end;
end;

function TDirIbSqlQuery.SqlAffectedRows: Integer;
var
  OutBuffer: array[0..255] of Char;
  ReqInfo: Char;
  IbConnect: TDirIbSqlConnect;
begin
  Result := -1;
  if (FHandle = nil) or not FPrepared then Exit;
  IbConnect := TDirIbSqlConnect(Connect);

  ReqInfo := Char(isc_info_sql_records);
  if isc_dsql_sql_info(@IbConnect.FStatusVector, @FHandle, 1, @ReqInfo,
    SizeOf(OutBuffer), OutBuffer) > 0 then
    Exit;
  if OutBuffer[0] = Char(isc_info_sql_records) then
  begin
    case FStatementType of
      {
      stSelectForUpdate,
      stSelect: Result := isc_vax_integer(@Out_buffer[1], 4);
      }
      stUpdate: Result := isc_vax_integer(@OutBuffer[6], 4);
      stDelete: Result := isc_vax_integer(@OutBuffer[13], 4);
      stInsert: Result := isc_vax_integer(@OutBuffer[27], 4);
      else Result := -1;
    end;
  end;
end;

function TDirIbSqlQuery.SqlStatementType: Boolean;
var
  StatementLen: Integer;
  StatementBuffer: array[0..7] of Char;
  TypeItem: Char;
  IbConnect: TDirIbSqlConnect;
begin
  Result := False;
  FStatementType := stUnknown;
  if (FHandle = nil) or not FPrepared then Exit;
  IbConnect := TDirIbSqlConnect(Connect);

  TypeItem := Char(isc_info_sql_stmt_type);
  isc_dsql_sql_info(@IbConnect.FStatusVector, @FHandle, 1, @TypeItem,
    SizeOf(StatementBuffer), StatementBuffer);

  if StatementBuffer[0] = Char(isc_info_sql_stmt_type) then