Chip 2002 June/Chip_2002-06_cd1.bin/zkuste/delphi/kolekce/d6/rxlibsetup.exe/{app}/units/BdeUtils.pas

Pascal/Delphi Source File | 2002-02-19 | 47.9 KB | 1,756 lines

{*******************************************************}
{                                                       }
{         Delphi VCL Extensions (RX)                    }
{                                                       }
{         Copyright (c) 2001,2002 SGB Software          }
{         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
{                        Igor Pavluk and Serge Korolev  }
{                                                       }
{*******************************************************}



unit BdeUtils;

{$I RX.INC}
{$W-,R-,B-,N+,P+}

interface

uses SysUtils, Windows, Bde, Registry, RTLConsts, Classes, DB, DBTables,
  IniFiles, DBUtils;

type
{$IFNDEF WIN32}
  TLocateFilter = (lfTree, lfCallback);
{$ENDIF}

{$IFNDEF RX_D3}
  TBDEDataSet = TDataSet;
{$ENDIF}

{$IFNDEF RX_D5}
  TDatabaseLoginEvent = TLoginEvent;
{$ENDIF}

  TDBLocate = class(TLocateObject)
  private
{$IFNDEF WIN32}
    FFilterHandle: HDBIFilter;
    FTree: PChar;
    FTreeSize: Integer;
    FFilterKind: TLocateFilter;
    procedure ActivateFilter;
    procedure DeactivateFilter;
    procedure DropFilter;
    procedure CheckFilterKind;
    procedure ChangeBookmark;
    procedure BuildFilterHeader(var Rec);
    procedure BuildFilterTree;
    procedure FreeTree;
    function RecordFilter(RecBuf: Pointer; RecNo: Longint): Smallint;
      {$IFDEF WIN32} stdcall; {$ENDIF}
{$ELSE}
    function LocateCallback: Boolean;
    procedure RecordFilter(DataSet: TDataSet; var Accept: Boolean);
{$ENDIF WIN32}
  protected
{$IFDEF WIN32}
    function LocateFilter: Boolean; override;
{$ELSE}
    procedure ActiveChanged; override;
    function LocateFilter: Boolean; override;
{$ENDIF WIN32}
    procedure CheckFieldType(Field: TField); override;
    function LocateKey: Boolean; override;
    function UseKey: Boolean; override;
    function FilterApplicable: Boolean; override;
  public
    destructor Destroy; override;
  end;

{ TCloneDataset }

  TCloneDataset = class(TBDEDataSet)
  private
    FSourceHandle: HDBICur;
    FReadOnly: Boolean;
    procedure SetReadOnly(Value: Boolean);
    procedure SetSourceHandle(ASourceHandle: HDBICur);
  protected
    function CreateHandle: HDBICur; override;
  public
    property SourceHandle: HDBICur read FSourceHandle write SetSourceHandle;
  published
    property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
  end;

{ TCloneDbDataset }

  TCloneDbDataset = class(TDBDataSet)
  private
    FSourceHandle: HDBICur;
    FReadOnly: Boolean;
    procedure SetReadOnly(Value: Boolean);
    procedure SetSourceHandle(ASourceHandle: HDBICur);
  protected
    function CreateHandle: HDBICur; override;
  public
    procedure InitFromDataSet(Source: TDBDataSet; Reset: Boolean);
    property SourceHandle: HDBICur read FSourceHandle write SetSourceHandle;
  published
    property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
  end;

{ TCloneTable }

  TCloneTable = class(TTable)
  private
    FSourceHandle: HDBICur;
    FReadOnly: Boolean;
    procedure SetReadOnly(Value: Boolean);
    procedure SetSourceHandle(ASourceHandle: HDBICur);
  protected
    function CreateHandle: HDBICur; override;
  public
    procedure InitFromTable(SourceTable: TTable; Reset: Boolean);
  published
    property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
  end;

{ Utility routines }

function CreateDbLocate: TLocateObject;
{$IFNDEF WIN32}
function CheckOpen(Status: DBIResult): Boolean;
{$ENDIF}
procedure FetchAllRecords(DataSet: TBDEDataSet);
function TransActive(Database: TDatabase): Boolean;
function AsyncQrySupported(Database: TDatabase): Boolean;
{$IFDEF WIN32}
function GetQuoteChar(Database: TDatabase): string;
{$ENDIF}
procedure ExecuteQuery(const DbName, QueryText: string);
procedure ExecuteQueryEx(const SessName, DbName, QueryText: string);
procedure BdeTranslate(Locale: TLocale; Source, Dest: PChar; ToOem: Boolean);
function FieldLogicMap(FldType: TFieldType): Integer;
function FieldSubtypeMap(FldType: TFieldType): Integer;
procedure ConvertStringToLogicType(Locale: TLocale; FldLogicType: Integer;
  FldSize: Word; const FldName, Value: string; Buffer: Pointer);
function GetAliasPath(const AliasName: string): string;
function IsDirectory(const DatabaseName: string): Boolean;
function GetBdeDirectory: string;
function BdeErrorMsg(ErrorCode: DBIResult): string;
function LoginToDatabase(Database: TDatabase; OnLogin: TDatabaseLoginEvent): Boolean;
function DataSetFindValue(ADataSet: TBDEDataSet; const Value,
  FieldName: string): Boolean;
function DataSetFindLike(ADataSet: TBDEDataSet; const Value,
  FieldName: string): Boolean;
function DataSetRecNo(DataSet: TDataSet): Longint;
function DataSetRecordCount(DataSet: TDataSet): Longint;
function DataSetPositionStr(DataSet: TDataSet): string;
procedure DataSetShowDeleted(DataSet: TBDEDataSet; Show: Boolean);
function CurrentRecordDeleted(DataSet: TBDEDataSet): Boolean;
function IsFilterApplicable(DataSet: TDataSet): Boolean;
function IsBookmarkStable(DataSet: TBDEDataSet): Boolean;
function BookmarksCompare(DataSet: TBDEDataSet; Bookmark1,
  Bookmark2: TBookmark): Integer;
function SetToBookmark(ADataSet: TDataSet; ABookmark: TBookmark): Boolean;
procedure SetIndex(Table: TTable; const IndexFieldNames: string);
procedure RestoreIndex(Table: TTable);
procedure DeleteRange(Table: TTable; IndexFields: array of const;
  FieldValues: array of const);
procedure PackTable(Table: TTable);
procedure ReindexTable(Table: TTable);
procedure BdeFlushBuffers;
function GetNativeHandle(Database: TDatabase; Buffer: Pointer;
  BufSize: Integer): Pointer;
procedure ToggleDebugLayer(Active: Boolean; const DebugFile: string);
procedure DbNotSupported;

{ Export/import DataSet routines }

procedure ExportDataSet(Source: TBDEDataSet; DestTable: TTable;
  TableType: TTableType; const AsciiCharSet: string;
  AsciiDelimited: Boolean; MaxRecordCount: Longint);
procedure ExportDataSetEx(Source: TBDEDataSet; DestTable: TTable;
  TableType: TTableType; const AsciiCharSet: string;
  AsciiDelimited: Boolean; AsciiDelimiter, AsciiSeparator: Char;
  MaxRecordCount: Longint);
procedure ImportDataSet(Source: TBDEDataSet; DestTable: TTable;
  MaxRecordCount: Longint; Mappings: TStrings; Mode: TBatchMode);

{ ReportSmith initialization }

procedure InitRSRUN(Database: TDatabase; const ConName: string;
  ConType: Integer; const ConServer: string);

implementation

uses Forms, Controls, Dialogs, Consts, DBConsts, RXDConst, VCLUtils,
  FileUtil, AppUtils, rxStrUtils, MaxMin, {$IFNDEF WIN32} Str16, {$ENDIF}
  {$IFDEF RX_D3} BDEConst, DBCommon, {$ENDIF} DateUtil;

{ Utility routines }

{$IFDEF RX_D5}
procedure DBError(Ident: Word);
begin
  DatabaseError(LoadStr(Ident));
end;
{$ENDIF}

function IsBookmarkStable(DataSet: TBDEDataSet): Boolean;
var
  Props: CURProps;
begin
  with DataSet do
    Result := Active and (DbiGetCursorProps(Handle, Props) = DBIERR_NONE) and
      Props.bBookMarkStable;
end;

function SetToBookmark(ADataSet: TDataSet; ABookmark: TBookmark): Boolean;
begin
  Result := False;
{$IFDEF RX_D3}
  with ADataSet do
    if Active and (ABookmark <> nil) and not (Bof and Eof) and
      BookmarkValid(ABookmark) then
    try
      ADataSet.GotoBookmark(ABookmark);
      Result := True;
    except
    end;
{$ELSE}
  with TBDEDataSet(ADataSet) do
    if Active and (ABookmark <> nil) and not (Bof and Eof) then
      if DbiSetToBookmark(Handle, ABookmark) = DBIERR_NONE then
      try
        Resync([rmExact, rmCenter]);
        Result := True;
      except
      end;
{$ENDIF}
end;

function BookmarksCompare(DataSet: TBDEDataSet; Bookmark1, Bookmark2: TBookmark): Integer;
const
  RetCodes: array[Boolean, Boolean] of ShortInt =
    ((2, CMPLess), (CMPGtr, CMPEql));
begin
  Result := RetCodes[Bookmark1 = nil, Bookmark2 = nil];
  if Result = 2 then begin
    Check(DbiCompareBookmarks(DataSet.Handle, Bookmark1, Bookmark2,
      {$IFDEF WIN32} Result)); {$ELSE} Word(Result))); {$ENDIF}
    if Result = CMPKeyEql then Result := CMPEql;
  end;
end;

function DBGetIntProp(const Handle: Pointer; PropName: Longint): Longint;
var
  Length: Word;
  Value: Longint;
begin
  Value := 0;
  Check(DbiGetProp(HDBIObj(Handle), PropName, @Value, SizeOf(Value), Length));
  Result := Value;
end;

{$IFDEF WIN32}
function GetQuoteChar(Database: TDatabase): string;
{$IFNDEF RX_D3}
const
  dbQUOTECHAR = $0404000A;
{$ENDIF}
var
  Q: Char;
  Len: Word;
begin
  Result := '';
  if Database.IsSQLBased then begin
    Q := #0;
    DbiGetProp(HDBIObj(Database.Handle), dbQUOTECHAR, @Q, SizeOf(Q), Len);
    if Q <> #0 then Result := Q;
  end
  else Result := '"';
end;
{$ENDIF}

function AsyncQrySupported(Database: TDatabase): Boolean;
begin
  Result := False;
  if Database.Connected then
    if Database.IsSQLBased then
      try
        Result := BOOL(DBGetIntProp(Database.Handle, dbASYNCSUPPORT));
      except
      end
    else Result := {$IFDEF WIN32} True {$ELSE} False {$ENDIF};
end;

function FieldLogicMap(FldType: TFieldType): Integer;
{$IFNDEF RX_D3}
{$IFDEF VER80}
const
  FldTypeMap: array[TFieldType] of Integer = (
    fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
    fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
    fldVARBYTES, fldBLOB, fldBLOB, fldBLOB);
{$ELSE}
const
  FldTypeMap: array[TFieldType] of Integer = (
    fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
    fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
    fldVARBYTES, fldINT32, fldBLOB, fldBLOB, fldBLOB, fldBLOB, fldBLOB,
    fldBLOB, fldBLOB);
{$ENDIF}
{$ENDIF}
begin
  Result := FldTypeMap[FldType];
end;

function FieldSubtypeMap(FldType: TFieldType): Integer;
{$IFNDEF RX_D3}
{$IFDEF VER80}
const
  FldSubtypeMap: array[TFieldType] of Integer = (
    0, 0, 0, 0, 0, 0, 0, fldstMONEY, 0, 0, 0, 0, 0, 0, fldstBINARY,
    fldstMEMO, fldstGRAPHIC);
{$ELSE}
const
  FldSubtypeMap: array[TFieldType] of Integer = (
    0, 0, 0, 0, 0, 0, 0, fldstMONEY, 0, 0, 0, 0, 0, 0, fldstAUTOINC,
    fldstBINARY, fldstMEMO, fldstGRAPHIC, fldstFMTMEMO, fldstOLEOBJ,
    fldstDBSOLEOBJ, fldstTYPEDBINARY);
{$ENDIF}
{$ENDIF}
begin
  Result := FldSubtypeMap[FldType];
end;

{$IFNDEF WIN32}
function CheckOpen(Status: DBIResult): Boolean;
begin
  case Status of
    DBIERR_NONE:
      Result := True;
    DBIERR_NOTSUFFTABLERIGHTS:
      begin
        if not Session.GetPassword then DbiError(Status);
        Result := False;
      end;
  else
    DbiError(Status);
  end;
end;
{$ENDIF}

{ Routine for convert string to IDAPI logical field type }

procedure ConvertStringToLogicType(Locale: TLocale; FldLogicType: Integer;
  FldSize: Word; const FldName, Value: string; Buffer: Pointer);
var
  Allocate: Boolean;
  BCD: FMTBcd;
  E: Integer;
  L: Longint;
  B: WordBool;
  DateTime: TDateTime;
  DtData: TDateTime;
  D: Double absolute DtData;
  Data: Longint absolute DtData;
{$IFDEF WIN32}
  TimeStamp: TTimeStamp;
{$ENDIF}
begin
  if Buffer = nil then begin
    Buffer := AllocMem(FldSize);
    Allocate := Buffer <> nil;
  end
  else Allocate := False;
  try
    case FldLogicType of
      fldZSTRING:
        begin
          AnsiToNative(Locale, Value, PChar(Buffer), FldSize);
        end;
      fldBYTES, fldVARBYTES:
        begin
          Move(Value[1], Buffer^, Min(Length(Value), FldSize));
        end;
      fldINT16, fldINT32, fldUINT16:
        begin
          if Value = '' then FillChar(Buffer^, FldSize, 0)
          else begin
            Val(Value, L, E);
            if E <> 0 then
{$IFDEF RX_D3}
              DatabaseErrorFmt(SInvalidIntegerValue, [Value, FldName]);
{$ELSE}
              DBErrorFmt(SInvalidIntegerValue, [Value, FldName]);
{$ENDIF}
            Move(L, Buffer^, FldSize);
          end;
        end;
      fldBOOL:
        begin
          L := Length(Value);
          if L = 0 then B := False
          else begin
            if Value[1] in ['Y', 'y', 'T', 't', '1'] then B := True
            else B := False;
          end;
          Move(B, Buffer^, SizeOf(WordBool));
        end;
      fldFLOAT, fldBCD:
        begin
          if Value = '' then FillChar(Buffer^, FldSize, 0)
          else begin
            D := StrToFloat(Value);
            if FldLogicType <> fldBCD then Move(D, Buffer^, SizeOf(Double))
            else begin
              DbiBcdFromFloat(D, 32, FldSize, BCD);
              Move(BCD, Buffer^, SizeOf(BCD));
            end;
          end;
        end;
      fldDATE, fldTIME, fldTIMESTAMP:
        begin
          if Value = '' then Data := Trunc(NullDate)
          else begin
            case FldLogicType of
              fldDATE:
                begin
                  DateTime := StrToDate(Value);
{$IFDEF WIN32}
                  TimeStamp := DateTimeToTimeStamp(DateTime);
                  Data := TimeStamp.Date;
{$ELSE}
                  Data := Trunc(DateTime);
{$ENDIF}
                end;
              fldTIME:
                begin
                  DateTime := StrToTime(Value);
{$IFDEF WIN32}
                  TimeStamp := DateTimeToTimeStamp(DateTime);
                  Data := TimeStamp.Time;
{$ELSE}
                  Data := Round(Frac(DateTime) * MSecsPerDay);
{$ENDIF}
                end;
              fldTIMESTAMP:
                begin
                  DateTime := StrToDateTime(Value);
{$IFDEF WIN32}
                  TimeStamp := DateTimeToTimeStamp(DateTime);
                  D := TimeStampToMSecs(DateTimeToTimeStamp(DateTime));
{$ELSE}
                  DtData := DateTime * MSecsPerDay;
{$ENDIF}
                end;
            end;
          end;
          Move(D, Buffer^, FldSize);
        end;
      else DbiError(DBIERR_INVALIDFLDTYPE);
    end;
  finally
    if Allocate then FreeMem(Buffer, FldSize);
  end;
end;

{ Execute Query routine }

procedure ExecuteQueryEx(const SessName, DbName, QueryText: string);
begin
  with TQuery.Create(Application) do
  try
    DatabaseName := DbName;
{$IFDEF WIN32}
    SessionName := SessName;
{$ENDIF}
    SQL.Add(QueryText);
    ExecSQL;
  finally
    Free;
  end;
end;

procedure ExecuteQuery(const DbName, QueryText: string);
begin
  ExecuteQueryEx('', DbName, QueryText);
end;

{ Database Login routine }

function LoginToDatabase(Database: TDatabase; OnLogin: TDatabaseLoginEvent): Boolean;
var
  EndLogin: Boolean;
begin
  Result := Database.Connected;
  if Result then Exit;
  Database.OnLogin := OnLogin;
  EndLogin := True;
  repeat
    try
      Database.Connected := True;
      EndLogin := True;
    except
      on E: EDbEngineError do begin
        EndLogin := (MessageDlg(E.Message + '. ' + LoadStr(SRetryLogin),
          mtConfirmation, [mbYes, mbNo], 0) <> mrYes);
      end;
      on E: EDatabaseError do begin
        { User select "Cancel" in login dialog }
        MessageDlg(E.Message, mtError, [mbOk], 0);
      end;
      else raise;
    end;
  until EndLogin;
  Result := Database.Connected;
end;

{ ReportSmith runtime initialization routine }

procedure InitRSRUN(Database: TDatabase; const ConName: string;
  ConType: Integer; const ConServer: string);
const
  IniFileName = 'RPTSMITH.CON';
  scConNames = 'ConnectNamesSection';
  idConNames = 'ConnectNames';
  idType = 'Type';
  idServer = 'Server';
  idSQLDataFilePath = 'Database';
  idDataFilePath = 'DataFilePath';
  idSQLUserID = 'USERID';
var
  ParamList: TStringList;
  DBPath: string[127];
  TempStr, AppConName: string[127];
  UserName: string[30];
  ExeName: string[12];
  IniFile: TIniFile;
begin
  ParamList := TStringList.Create;
  try
{$IFDEF WIN32}
    Database.Session.GetAliasParams(Database.AliasName, ParamList);
{$ELSE}
    Session.GetAliasParams(Database.AliasName, ParamList);
{$ENDIF}
    if Database.IsSQLBased then DBPath := ParamList.Values['SERVER NAME']
    else DBPath := ParamList.Values['PATH'];
    UserName := ParamList.Values['USER NAME'];
  finally
    ParamList.Free;
  end;
  AppConName := ConName;
  if AppConName = '' then begin
    ExeName := ExtractFileName(Application.ExeName);
    AppConName := Copy(ExeName, 1, Pos('.', ExeName) - 1);
  end;
  IniFile := TIniFile.Create(IniFileName);
  try
    TempStr := IniFile.ReadString(scConNames, idConNames, '');
    if Pos(AppConName, TempStr) = 0 then begin
      if TempStr <> '' then TempStr := TempStr + ',';
      IniFile.WriteString(scConNames, idConNames, TempStr + AppConName);
    end;
    IniFile.WriteInteger(AppConName, idType, ConType);
    IniFile.WriteString(AppConName, idServer, ConServer);
    if Database.IsSQLBased then begin
      IniFile.WriteString(AppConName, idSQLDataFilePath, DBPath);
      IniFile.WriteString(AppConName, idSQLUserID, UserName);
    end
    else IniFile.WriteString(AppConName, idDataFilePath, DBPath);
  finally
    IniFile.Free;
  end;
end;

{ BDE aliases routines }

function IsDirectory(const DatabaseName: string): Boolean;
var
  I: Integer;
begin
  Result := True;
  if (DatabaseName = '') then Exit;
  I := 1;
  while I <= Length(DatabaseName) do begin
{$IFDEF RX_D3}
    if DatabaseName[I] in LeadBytes then Inc(I) else
{$ENDIF RX_D3}
    if DatabaseName[I] in [':','\'] then Exit;
    Inc(I);
  end;
  Result := False;
end;

function GetAliasPath(const AliasName: string): string;
var
  SAlias: DBINAME;
  Desc: DBDesc;
  Params: TStrings;
begin
  Result := '';
  StrPLCopy(SAlias, AliasName, SizeOf(SAlias) - 1);
  AnsiToOem(SAlias, SAlias);
  Check(DbiGetDatabaseDesc(SAlias, @Desc));
  if StrIComp(Desc.szDbType, szCFGDBSTANDARD) = 0 then begin
    OemToAnsi(Desc.szPhyName, Desc.szPhyName);
    Result := StrPas(Desc.szPhyName);
  end
  else begin
    Params := TStringList.Create;
    try
{$IFDEF WIN32}
      Session.Active := True;
{$ENDIF}
      Session.GetAliasParams(AliasName, Params);
      Result := Params.Values['SERVER NAME'];
    finally
      Params.Free;
    end;
  end;
end;

{ TCloneDataset }

procedure TCloneDataset.SetSourceHandle(ASourceHandle: HDBICur);
begin
  if ASourceHandle <> FSourceHandle then begin
    Close;
    FSourceHandle := ASourceHandle;
    if FSourceHandle <> nil then Open;
  end;
end;

function TCloneDataset.CreateHandle: HDBICur;
begin
  Check(DbiCloneCursor(FSourceHandle, FReadOnly, False, Result));
end;

procedure TCloneDataset.SetReadOnly(Value: Boolean);
begin
  CheckInactive;
  FReadOnly := Value;
end;

{ TCloneDbDataset }

procedure TCloneDbDataset.InitFromDataSet(Source: TDBDataSet; Reset: Boolean);
begin
  with Source do begin
{$IFDEF WIN32}
    Self.SessionName := SessionName;
{$ENDIF}
    Self.DatabaseName := DatabaseName;
    SetSourceHandle(Handle);
{$IFDEF WIN32}
    Self.Filter := Filter;
    Self.OnFilterRecord := OnFilterRecord;
    if not Reset then Self.Filtered := Filtered;
{$ENDIF}
  end;
  if Reset then begin
{$IFDEF WIN32}
    Filtered := False;
{$ENDIF}
    First;
  end;
end;

procedure TCloneDbDataset.SetSourceHandle(ASourceHandle: HDBICur);
begin
  if ASourceHandle <> FSourceHandle then begin
    Close;
    FSourceHandle := ASourceHandle;
    if FSourceHandle <> nil then Open;
  end;
end;

function TCloneDbDataset.CreateHandle: HDBICur;
begin
  Check(DbiCloneCursor(FSourceHandle, FReadOnly, False, Result));
end;

procedure TCloneDbDataset.SetReadOnly(Value: Boolean);
begin
  CheckInactive;
  FReadOnly := Value;
end;

{ TCloneTable }

procedure TCloneTable.InitFromTable(SourceTable: TTable; Reset: Boolean);
begin
  with SourceTable do begin
    Self.TableType := TableType;
    Self.TableName := TableName;
{$IFDEF WIN32}
    Self.SessionName := SessionName;
{$ENDIF}
    Self.DatabaseName := DatabaseName;
    if not Reset then begin
      if IndexName <> '' then
        Self.IndexName := IndexName
      else if IndexFieldNames <> '' then
        Self.IndexFieldNames := IndexFieldNames;
    end;
    SetSourceHandle(Handle);
{$IFDEF WIN32}
    Self.Filter := Filter;
    Self.OnFilterRecord := OnFilterRecord;
    if not Reset then Self.Filtered := Filtered;
{$ENDIF}
  end;
  if Reset then begin
{$IFDEF WIN32}
    Filtered := False;
{$ENDIF}
    DbiResetRange(Handle);
    IndexName := '';
    IndexFieldNames := '';
    First;
  end;
end;

procedure TCloneTable.SetSourceHandle(ASourceHandle: HDBICur);
begin
  if ASourceHandle <> FSourceHandle then begin
    Close;
    FSourceHandle := ASourceHandle;
    if FSourceHandle <> nil then Open;
  end;
end;

procedure TCloneTable.SetReadOnly(Value: Boolean);
begin
  CheckInactive;
  FReadOnly := Value;
end;

function TCloneTable.CreateHandle: HDBICur;
begin
  Check(DbiCloneCursor(FSourceHandle, FReadOnly, False, Result));
end;

{ TDBLocate }

function CreateDbLocate: TLocateObject;
begin
  Result := TDBLocate.Create;
end;

{$IFNDEF WIN32}
function CallbackFilter(pDBLocate: Longint; RecBuf: Pointer;
  RecNo: Longint): Smallint;
  {$IFDEF WIN32} stdcall; {$ELSE} export; {$ENDIF WIN32}
begin
  Result := TDBLocate(pDBLocate).RecordFilter(RecBuf, RecNo);
end;
{$ENDIF WIN32}

destructor TDBLocate.Destroy;
begin
{$IFNDEF WIN32}
  DropFilter;
{$ENDIF}
  inherited Destroy;
end;

procedure TDBLocate.CheckFieldType(Field: TField);
var
  Locale: TLocale;
begin
  if not (Field.DataType in [ftDate, ftTime, ftDateTime]) then begin
    if DataSet is TBDEDataSet then Locale := TBDEDataSet(DataSet).Locale
    else Locale := Session.Locale;
    ConvertStringToLogicType(Locale, FieldLogicMap(Field.DataType),
      Field.DataSize, Field.FieldName, LookupValue, nil);
  end;
end;

function TDBLocate.UseKey: Boolean;
var
  I: Integer;
begin
  Result := False;
  if DataSet is TTable then
    with DataSet as TTable do begin
      if (not Self.LookupField.IsIndexField) and (not IndexSwitch or
        (not CaseSensitive and Database.IsSQLBased)) then Exit;
      if (not LookupExact) and (Self.LookupField.DataType <> ftString) then Exit;
      IndexDefs.Update;
      for I := 0 to IndexDefs.Count - 1 do
        with IndexDefs[I] do
          if not (ixExpression in Options) and
            ((ixCaseInsensitive in Options) or CaseSensitive) then
            if AnsiCompareText(Fields, Self.LookupField.FieldName) = 0 then
            begin
              Result := True;
              Exit;
            end;
    end;
end;

function TDBLocate.LocateKey: Boolean;
var
  Clone: TCloneTable;

  function LocateIndex(Table: TTable): Boolean;
  begin
    with Table do begin
      SetKey;
      FieldByName(Self.LookupField.FieldName).AsString := LookupValue;
      if LookupExact then Result := GotoKey
      else begin
        GotoNearest;
        Result := MatchesLookup(FieldByName(Self.LookupField.FieldName));
      end;
    end;
  end;

begin
  try
    TTable(DataSet).CheckBrowseMode;
    if TTable(DataSet).IndexFieldNames = LookupField.FieldName then
      Result := LocateIndex(TTable(DataSet))
    else begin
      Clone := TCloneTable.Create(DataSet);
      with Clone do
      try
        ReadOnly := True;
        InitFromTable(TTable(DataSet), True);
        IndexFieldNames := Self.LookupField.FieldName;
        Result := LocateIndex(Clone);
        if Result then begin
          Check(DbiSetToCursor(TTable(DataSet).Handle, Handle));
          DataSet.Resync([rmExact, rmCenter]);
        end;
      finally
        Free;
      end;
    end;
  except
    Result := False;
  end;
end;

function TDBLocate.FilterApplicable: Boolean;
begin
  Result := IsFilterApplicable(DataSet);
end;

{$IFDEF WIN32}

function TDBLocate.LocateCallback: Boolean;
var
  Clone: TCloneDbDataset;
begin
  Result := False;
  try
    TBDEDataSet(DataSet).CheckBrowseMode;
    Clone := TCloneDbDataset.Create(DataSet);
    with Clone do
    try
      ReadOnly := True;
      InitFromDataset(TDBDataSet(DataSet), True);
      OnFilterRecord := RecordFilter;
      Filtered := True;
      if not (BOF and EOF) then begin
        First;
        Result := True;
      end;
      if Result then begin
        Check(DbiSetToCursor(TBDEDataSet(DataSet).Handle, Handle));
        DataSet.Resync([rmExact, rmCenter]);
      end;
    finally
      Free;
    end;
  except
    Result := False;
  end;
end;

procedure TDBLocate.RecordFilter(DataSet: TDataSet; var Accept: Boolean);
begin
  Accept := MatchesLookup(DataSet.FieldByName(LookupField.FieldName));
end;

function TDBLocate.LocateFilter: Boolean;
var
  SaveCursor: TCursor;
begin
  if LookupExact or (LookupField.DataType = ftString) or
    not (DataSet is TDBDataSet) then
    Result := inherited LocateFilter
  else begin
    SaveCursor := Screen.Cursor;
    Screen.Cursor := crHourGlass;
    try
      Result := LocateCallback;
    finally
      Screen.Cursor := SaveCursor;
    end;
  end;
end;

{$ELSE WIN32}

type
  TFilterRec = record { the simple filter tree with one condition }
    Header: CANExpr;
    Condition: CANBinary;
    FieldNode: CANField;
    ConstNode: CANConst;
  end;

function TDBLocate.LocateFilter: Boolean;
var
  SaveCursor: TCursor;
  Status: DBIResult;
begin
  SaveCursor := Screen.Cursor;
  Screen.Cursor := crHourGlass;
  try
    ActivateFilter;
    try
      Check(DbiSetToBegin(TBDEDataSet(DataSet).Handle));
      Status := DbiGetNextRecord(TBDEDataSet(DataSet).Handle, dbiNoLock,
        nil, nil);
      if Status = DBIERR_NONE then begin
        DataSet.Resync([rmExact, rmCenter]);
        ChangeBookmark;
        Result := True;
      end
      else Result := False;
    finally
      DeactivateFilter;
      if Result then SetToBookmark(DataSet, Bookmark);
    end;
  finally
    Screen.Cursor := SaveCursor;
  end;
end;

procedure TDBLocate.BuildFilterHeader(var Rec);
const
  FCondition: array[Boolean] of CANOp = (canGE, canEQ);
  FilterHeaderSize = SizeOf(CANExpr) + SizeOf(CANBinary) +
    SizeOf(CANField) + SizeOf(CANConst);
begin
  with TFilterRec(Rec) do begin
    with Header do begin
      iVer := CANEXPRVERSION;
      iNodes := 3;
      iNodeStart := SizeOf(CANExpr);
      iLiteralStart := FilterHeaderSize;
    end;
    with Condition do begin
      nodeClass := nodeBINARY;
      canOp := FCondition[LookupExact];
      iOperand1 := SizeOf(CANBinary);
      iOperand2 := iOperand1 + SizeOf(CANField);
    end;
    with FieldNode do begin
      nodeClass := nodeFIELD;
      canOp := canFIELD2;
      iFieldNum := LookupField.FieldNo;
      iNameOffset := 0;
    end;
    with ConstNode do begin
      canOp := canCONST2;
      iType := FieldLogicMap(LookupField.DataType);
      iSize := LookupField.DataSize;
      iOffset := Length(LookupField.FieldName) + 1;
    end;
    Header.iTotalSize := FilterHeaderSize + ConstNode.iSize +
      ConstNode.iOffset;
  end;
end;

procedure TDBLocate.BuildFilterTree;
var
  Temp: PChar;
  Rec: TFilterRec;
begin
  if FTree <> nil then FreeMem(FTree, FTreeSize);
  FTree := nil;
  BuildFilterHeader(Rec);
  FTreeSize := Rec.Header.iTotalSize;
  FTree := AllocMem(FTreeSize);
  try
    FillChar(FTree^, FTreeSize, 0);
    Temp := FTree;
    Move(Rec, FTree^, SizeOf(TFilterRec));
    Inc(Temp, SizeOf(TFilterRec));
    StrPCopy(PChar(Temp), LookupField.FieldName);
    Inc(Temp, Rec.ConstNode.iOffset);
    ConvertStringToLogicType(DataSet.Locale, FieldLogicMap(LookupField.DataType),
      LookupField.DataSize, LookupField.FieldName, LookupValue, Temp);
  except
    FreeTree;
    raise;
  end;
end;

procedure TDBLocate.FreeTree;
begin
  if FTree <> nil then FreeMem(FTree, FTreeSize);
  FTree := nil;
  FTreeSize := 0;
end;

procedure TDBLocate.CheckFilterKind;
var
  NewKind: TLocateFilter;
begin
  if CaseSensitive and LookupExact then NewKind := lfTree
  else NewKind := lfCallback;
  if (FFilterKind <> NewKind) or (NewKind = lfTree) then begin
    DropFilter;
    FFilterKind := NewKind;
  end;
end;

procedure TDBLocate.ActivateFilter;
begin
  CheckFilterKind;
  if FFilterHandle = nil then begin
    if FFilterKind = lfCallback then begin
      Check(DbiAddFilter(DataSet.Handle, Longint(Self), 0, True, nil,
        CallbackFilter, FFilterHandle));
    end
    else { lfTree } begin
      BuildFilterTree;
      Check(DbiAddFilter(DataSet.Handle, 0, 1, False,
        pCANExpr(FTree), nil, FFilterHandle));
    end;
  end;
  DbiActivateFilter(DataSet.Handle, FFilterHandle);
end;

procedure TDBLocate.DeactivateFilter;
begin
  DbiDeactivateFilter(DataSet.Handle, FFilterHandle);
end;

procedure TDBLocate.DropFilter;
begin
  if FFilterHandle <> nil then
    DbiDropFilter(DataSet.Handle, FFilterHandle);
  FreeTree;
  FFilterHandle := nil;
end;

function TDBLocate.RecordFilter(RecBuf: Pointer; RecNo: Longint): Smallint;
var
  Accept: Boolean;
begin
  try
    Move(RecBuf^, DataSet.ActiveBuffer^, DataSet.RecordSize);
    if LookupField <> nil then Accept := MatchesLookup(LookupField)
    else Accept := True;
    Result := Ord(Accept);
  except
    Application.HandleException(Self);
    Result := ABORT;
  end;
end;

procedure TDBLocate.ChangeBookmark;
begin
  if Bookmark <> nil then DataSet.FreeBookmark(Bookmark);
  Bookmark := DataSet.GetBookmark;
end;

procedure TDBLocate.ActiveChanged;
begin
  DropFilter;
end;

{$ENDIF WIN32}

{ DataSet locate routines }

function IsFilterApplicable(DataSet: TDataSet): Boolean;
var
  Status: DBIResult;
  Filter: hDBIFilter;
begin
  if DataSet is TBDEDataSet then begin
    Status := DbiAddFilter(TBDEDataSet(DataSet).Handle, 0, 0, False, nil,
      nil, Filter);
    Result := (Status = DBIERR_NONE) or (Status = DBIERR_INVALIDFILTER);
    if Result then DbiDropFilter(TBDEDataSet(DataSet).Handle, Filter);
  end
  else Result := True;
end;

function DataSetFindValue(ADataSet: TBDEDataSet; const Value,
  FieldName: string): Boolean;
begin
  with TDBLocate.Create do
  try
    DataSet := ADataSet;
    if ADataSet is TDBDataSet then
      IndexSwitch := not TDBDataSet(DataSet).Database.IsSQLBased;
    Result := Locate(FieldName, Value, True, False);
  finally
    Free;
  end;
end;

function DataSetFindLike(ADataSet: TBDEDataSet; const Value,
  FieldName: string): Boolean;
begin
  with TDBLocate.Create do
  try
    DataSet := ADataSet;
    if ADataSet is TDBDataSet then
      IndexSwitch := not TDBDataSet(DataSet).Database.IsSQLBased;
    Result := Locate(FieldName, Value, False, False);
  finally
    Free;
  end;
end;

const
  SaveIndexFieldNames: TStrings = nil;

procedure UsesSaveIndexies;
begin
  if SaveIndexFieldNames = nil then
    SaveIndexFieldNames := TStringList.Create;
end;

procedure ReleaseSaveIndexies; far;
begin
  if SaveIndexFieldNames <> nil then begin
    SaveIndexFieldNames.Free;
    SaveIndexFieldNames := nil;
  end;
end;

procedure SetIndex(Table: TTable; const IndexFieldNames: string);
var
  IndexToSave: string;
begin
  IndexToSave := Table.IndexFieldNames;
  Table.IndexFieldNames := IndexFieldNames;
  UsesSaveIndexies;
  SaveIndexFieldNames.AddObject(IndexToSave, Table.MasterSource);
end;

procedure RestoreIndex(Table: TTable);
begin
  if (SaveIndexFieldNames <> nil) and (SaveIndexFieldNames.Count > 0) then
  begin
    try
      Table.IndexFieldNames :=
        SaveIndexFieldNames[SaveIndexFieldNames.Count - 1];
      Table.MasterSource :=
        TDataSource(SaveIndexFieldNames.Objects[SaveIndexFieldNames.Count - 1]);
    finally
      SaveIndexFieldNames.Delete(SaveIndexFieldNames.Count - 1);
      if SaveIndexFieldNames.Count = 0 then
        ReleaseSaveIndexies;
    end;
  end;
end;

procedure DeleteRange(Table: TTable; IndexFields: array of const;
  FieldValues: array of const);
var
  I: Integer;
  NewIndex: string;
begin
  NewIndex := '';
  for I := Low(IndexFields) to High(IndexFields) do begin
    NewIndex := NewIndex + TVarRec(IndexFields[I]).VString^;
    if I <> High(IndexFields) then
      NewIndex := NewIndex + ';';
  end;
  SetIndex(Table, NewIndex);
  try
    Table.SetRange(FieldValues, FieldValues);
    try
      while not Table.EOF do Table.Delete;
    finally
      Table.CancelRange;
    end;
  finally
    RestoreIndex(Table);
  end;
end;

procedure ReindexTable(Table: TTable);
var
  WasActive: Boolean;
  WasExclusive: Boolean;
begin
  with Table do begin
    WasActive := Active;
    WasExclusive := Exclusive;
    DisableControls;
    try
      if not (WasActive and WasExclusive) then Close;
      try
        Exclusive := True;
        Open;
        Check(dbiRegenIndexes(Handle));
      finally
        if not (WasActive and WasExclusive) then begin
          Close;
          Exclusive := WasExclusive;
          Active := WasActive;
        end;
      end;
    finally
      EnableControls;
    end;
  end;
end;

procedure PackTable(Table: TTable);
{ This routine copied and modified from demo unit TableEnh.pas
  from Borland Int. }
var
  { FCurProp holds information about the structure of the table }
  FCurProp: CurProps;
  { Specific information about the table structure, indexes, etc. }
  TblDesc: CRTblDesc;
  { Uses as a handle to the database }
  hDb: hDbiDB;
  { Path to the currently opened table }
  TablePath: array[0..dbiMaxPathLen] of Char;
  Exclusive: Boolean;
begin
  if not Table.Active then _DBError(SDataSetClosed);
  Check(DbiGetCursorProps(Table.Handle, FCurProp));
  if StrComp(FCurProp.szTableType, szParadox) = 0 then begin
    { Call DbiDoRestructure procedure if PARADOX table }
    hDb := nil;
    { Initialize the table descriptor }
    FillChar(TblDesc, SizeOf(CRTblDesc), 0);
    with TblDesc do begin
      { Place the table name in descriptor }
      StrPCopy(szTblName, Table.TableName);
      { Place the table type in descriptor }
      StrCopy(szTblType, FCurProp.szTableType);
      bPack := True;
      bProtected := FCurProp.bProtected;
    end;
    { Get the current table's directory. This is why the table MUST be
      opened until now }
    Check(DbiGetDirectory(Table.DBHandle, False, TablePath));
    { Close the table }
    Table.Close;
    try
      { NOW: since the DbiDoRestructure call needs a valid DB handle BUT the
        table cannot be opened, call DbiOpenDatabase to get a valid handle.
        Setting TTable.Active = False does not give you a valid handle }
      Check(DbiOpenDatabase(nil, szCFGDBSTANDARD, dbiReadWrite, dbiOpenExcl, nil,
        0, nil, nil, hDb));
      { Set the table's directory to the old directory }
      Check(DbiSetDirectory(hDb, TablePath));
      { Pack the PARADOX table }
      Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False));
      { Close the temporary database handle }
      Check(DbiCloseDatabase(hDb));
    finally
      { Re-Open the table }
      Table.Open;
    end;
  end
  else if StrComp(FCurProp.szTableType, szDBase) = 0 then begin
    { Call DbiPackTable procedure if dBase table }
    Exclusive := Table.Exclusive;
    Table.Close;
    try
      Table.Exclusive := True;
      Table.Open;
      try
        Check(DbiPackTable(Table.DBHandle, Table.Handle, nil, nil, True));
      finally
        Table.Close;
      end;
    finally
      Table.Exclusive := Exclusive;
      Table.Open;
    end;
  end
  else DbiError(DBIERR_WRONGDRVTYPE);
end;

procedure FetchAllRecords(DataSet: TBDEDataSet);
begin
  with DataSet do
    if not EOF then begin
      CheckBrowseMode;
      Check(DbiSetToEnd(Handle));
      Check(DbiGetPriorRecord(Handle, dbiNoLock, nil, nil));
      CursorPosChanged;
      UpdateCursorPos;
    end;
end;

procedure BdeFlushBuffers;
var
  I, L: Integer;
{$IFDEF WIN32}
  Session: TSession;
  J: Integer;
{$ENDIF}
begin
{$IFDEF WIN32}
  for J := 0 to Sessions.Count - 1 do begin
    Session := Sessions[J];
    if not Session.Active then Continue;
{$ENDIF}
    for I := 0 to Session.DatabaseCount - 1 do begin
      with Session.Databases[I] do
        if Connected and not IsSQLBased then begin
          for L := 0 to DataSetCount - 1 do begin
            if DataSets[L].Active then
              DbiSaveChanges(DataSets[L].Handle);
          end;
        end;
    end;
{$IFDEF WIN32}
  end;
{$ENDIF}
end;

{$IFNDEF WIN32}
type
  TDbiGetExactRecordCount = function (hCursor: hDBICur;
    var iRecCount: Longint): DbiResult;

const
  DbiGetExactRecCnt: TDbiGetExactRecordCount = nil;

function DbiGetExactRecordCount(hCursor: hDBICur;
  var iRecCount: Longint): DbiResult;
var
  HModule: THandle;
  ErrMode: Cardinal;
begin
  if not Assigned(DbiGetExactRecCnt) then begin
    ErrMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
    HModule := LoadLibrary('IDAPI01.DLL');
    SetErrorMode(ErrMode);
    if HModule >= HINSTANCE_ERROR then begin
      @DbiGetExactRecCnt := GetProcAddress(HModule, 'DBIGETEXACTRECORDCOUNT');
      FreeLibrary(HModule);
    end;
  end;
  if Assigned(DbiGetExactRecCnt) then
    Result := DbiGetExactRecCnt(hCursor, iRecCount)
  else Result := DbiGetRecordCount(hCursor, iRecCount);
end;
{$ENDIF}

function DataSetRecordCount(DataSet: TDataSet): Longint;
var
  IsCount: Boolean;
begin
{$IFDEF RX_D3}
  if DataSet is TBDEDataSet then begin
{$ENDIF}
    IsCount := (DbiGetExactRecordCount(TBDEDataSet(DataSet).Handle,
      Result) = DBIERR_NONE) or (DbiGetRecordCount(TBDEDataSet(DataSet).Handle,
      Result) = DBIERR_NONE);
{$IFDEF RX_D3}
  end
  else
    try
      Result := DataSet.RecordCount;
      IsCount := True;
    except
      IsCount := False;
    end;
{$ENDIF}
  if not IsCount then Result := -1;
end;

function DataSetRecNo(DataSet: TDataSet): Longint;
var
  FCurProp: CURProps;
  FRecProp: RECProps;
begin
  Result := -1;
  if (DataSet <> nil) and DataSet.Active and (DataSet.State in [dsBrowse,
    dsEdit]) then
  begin
{$IFDEF RX_D3}
    if not (DataSet is TBDEDataSet) then begin
      Result := DataSet.RecNo;
      Exit;
    end;
{$ENDIF}
    if DbiGetCursorProps(TBDEDataSet(DataSet).Handle, FCurProp) <> DBIERR_NONE then
      Exit;
    if (StrComp(FCurProp.szTableType, szParadox) = 0) or
      (FCurProp.iSeqNums = 1) then
    begin
      DataSet.GetCurrentRecord(nil);
      if DbiGetSeqNo(TBDEDataSet(DataSet).Handle, Result) <> DBIERR_NONE then
        Result := -1;
    end
    else if StrComp(FCurProp.szTableType, szDBase) = 0 then begin
      DataSet.GetCurrentRecord(nil);
      if DbiGetRecord(TBDEDataSet(DataSet).Handle, dbiNOLOCK, nil, @FRecProp) = DBIERR_NONE
        then Result := FRecProp.iPhyRecNum;
    end;
  end;
end;

function DataSetPositionStr(DataSet: TDataSet): string;
var
  RecNo, RecCount: Longint;
begin
  try
    RecNo := DataSetRecNo(DataSet);
  except
    RecNo := -1;
  end;
  if RecNo >= 0 then begin
    RecCount := DataSetRecordCount(DataSet);
    if RecCount >= 0 then Result := Format('%d:%d', [RecNo, RecCount])
    else Result := IntToStr(RecNo);
  end
  else Result := '';
end;

function TransActive(Database: TDatabase): Boolean;
var
  Info: XInfo;
{$IFDEF WIN32}
  S: hDBISes;
{$ENDIF}
begin
{$IFDEF WIN32}
  Result := False;
  if DbiGetCurrSession(S) <> DBIERR_NONE then Exit;
{$ENDIF}
  Result := (Database.Handle <> nil) and
    (DbiGetTranInfo(Database.Handle, nil, @Info) = DBIERR_NONE) and
    (Info.exState = xsActive);
{$IFDEF WIN32}
  DbiSetCurrSession(S);
{$ENDIF}
end;

function GetBdeDirectory: string;
const
  Ident = 'DLLPATH';
var
{$IFDEF WIN32}
  Ini: TRegistry;
const
  BdeKey = 'SOFTWARE\Borland\Database Engine';
{$ELSE}
  Ini: TIniFile;
{$ENDIF}
begin
  Result := '';
{$IFDEF WIN32}
  Ini := TRegistry.Create;
  try
    Ini.RootKey := HKEY_LOCAL_MACHINE;
    if Ini.OpenKey(BdeKey, False) then
      if Ini.ValueExists(Ident) then Result := Ini.ReadString(Ident);
{$ELSE}
  Ini := TIniFile.Create('WIN.INI');
  try
    Result := Ini.ReadString('IDAPI', Ident, '');
{$ENDIF}
  { Check for multiple directories, use only the first one }
  if Pos(';', Result) > 0 then Delete(Result, Pos(';', Result), MaxInt);
  if (Length(Result) > 2) and (Result[Length(Result)] <> '\') then
    Result := Result + '\';
  finally
    Ini.Free;
  end;
end;

procedure ExportDataSetEx(Source: TBDEDataSet; DestTable: TTable;
  TableType: TTableType; const AsciiCharSet: string;
  AsciiDelimited: Boolean; AsciiDelimiter, AsciiSeparator: Char;
  MaxRecordCount: Longint);

  function ExportAsciiField(Field: TField): Boolean;
  begin
    Result := Field.Visible and not (Field.Calculated
      {$IFDEF WIN32} or Field.Lookup {$ENDIF}) and not (Field.DataType in
      ftNonTextTypes + [ftUnknown]);
  end;

const
  TextExt = '.TXT';
  SchemaExt = '.SCH';
var
  I: Integer;
  S, Path: string;
  BatchMove: TBatchMove;
  TablePath: array[0..dbiMaxPathLen] of Char;
begin
  if Source = nil then _DBError(SDataSetEmpty);
  if DestTable.Active then DestTable.Close;
{$IFDEF WIN32}
  if Source is TDBDataSet then
    DestTable.SessionName := TDBDataSet(Source).SessionName;
{$ENDIF}
  if (TableType = ttDefault) then begin
    if DestTable.TableType <> ttDefault then
      TableType := DestTable.TableType
    else if (CompareText(ExtractFileExt(DestTable.TableName), TextExt) = 0) then
      TableType := ttASCII;
  end;
  BatchMove := TBatchMove.Create(Application);
  try
    StartWait;
    try
      BatchMove.Mode := batCopy;
      BatchMove.Source := Source;
      BatchMove.Destination := DestTable;
      DestTable.TableType := TableType;
      BatchMove.Mappings.Clear;
      if (DestTable.TableType = ttASCII) then begin
        if CompareText(ExtractFileExt(DestTable.TableName), SchemaExt) = 0 then
          DestTable.TableName := ChangeFileExt(DestTable.TableName, TextExt);
        with Source do
          for I := 0 to FieldCount - 1 do begin
            if ExportAsciiField(Fields[I]) then
              BatchMove.Mappings.Add(Format('%s=%0:s',
                [Fields[I].FieldName]));
          end;
        BatchMove.RecordCount := 1;
      end
      else BatchMove.RecordCount := MaxRecordCount;
      BatchMove.Execute;
      if (DestTable.TableType = ttASCII) then begin
        { ASCII table always created in "fixed" format with "ascii"
          character set }
        with BatchMove do begin
          Mode := batAppend;
          RecordCount := MaxRecordCount;
        end;
        S := ChangeFileExt(ExtractFileName(DestTable.TableName), '');
        Path := NormalDir(ExtractFilePath(DestTable.TableName));
        if Path = '' then begin
          DestTable.Open;
          try
            Check(DbiGetDirectory(DestTable.DBHandle, False, TablePath));
            Path := NormalDir(OemToAnsiStr(StrPas(TablePath)));
          finally
            DestTable.Close;
          end;
        end;
        with TIniFile.Create(ChangeFileExt(Path + S, SchemaExt)) do
        try
          if AsciiCharSet <> '' then
            WriteString(S, 'CharSet', AsciiCharSet)
          else WriteString(S, 'CharSet', 'ascii');
          if AsciiDelimited then begin { change ASCII-file format to CSV }
            WriteString(S, 'Filetype', 'VARYING');
            WriteString(S, 'Delimiter', AsciiDelimiter);
            WriteString(S, 'Separator', AsciiSeparator);
          end;
        finally
          Free;
        end;
        { clear previous output - overwrite existing file }
        S := Path + ExtractFileName(DestTable.TableName);
        if Length(ExtractFileExt(S)) < 2 then
          S := ChangeFileExt(S, TextExt);
        I := FileCreate(S);
        if I < 0 then
          raise EFCreateError.CreateFmt(ResStr(SFCreateError), [S]);
        FileClose(I);
        BatchMove.Execute;
      end;
    finally
      StopWait;
    end;
  finally
    BatchMove.Free;
  end;
end;

procedure ExportDataSet(Source: TBDEDataSet; DestTable: TTable;
  TableType: TTableType; const AsciiCharSet: string;
  AsciiDelimited: Boolean; MaxRecordCount: Longint);
begin
  ExportDataSetEx(Source, DestTable, TableType, AsciiCharSet,
    AsciiDelimited, '"', ',', MaxRecordCount);
end;

procedure ImportDataSet(Source: TBDEDataSet; DestTable: TTable;
  MaxRecordCount: Longint; Mappings: TStrings; Mode: TBatchMode);
var
  BatchMove: TBatchMove;
begin
  if Source = nil then _DBError(SDataSetEmpty);
{$IFDEF WIN32}
  if (Source is TDBDataSet) and not Source.Active then
    TDBDataSet(Source).SessionName := DestTable.SessionName;
{$ENDIF}
  BatchMove := TBatchMove.Create(Application);
  try
    StartWait;
    try
      BatchMove.Mode := Mode;
      BatchMove.Source := Source;
      BatchMove.Destination := DestTable;
      if Mappings.Count > 0 then
        BatchMove.Mappings.AddStrings(Mappings);
      BatchMove.RecordCount := MaxRecordCount;
      BatchMove.Execute;
    finally
      StopWait;
    end;
  finally
    BatchMove.Free;
  end;
end;

function GetNativeHandle(Database: TDatabase; Buffer: Pointer;
  BufSize: Integer): Pointer;
var
  Len: Word;
begin
  Result := nil;
  if Assigned(Database) and Database.Connected then begin
    if Database.IsSQLBased then begin
      Check(DbiGetProp(HDBIOBJ(Database.Handle), dbNATIVEHNDL,
        Buffer, BufSize, Len));
      Result := Buffer;
    end
    else DBError(SLocalDatabase);
  end
  else _DBError(SDatabaseClosed);
end;

procedure BdeTranslate(Locale: TLocale; Source, Dest: PChar; ToOem: Boolean);
var
  Len: Cardinal;
begin
  Len := StrLen(Source);
  if ToOem then AnsiToNativeBuf(Locale, Source, Dest, Len)
  else NativeToAnsiBuf(Locale, Source, Dest, Len);
  if Source <> Dest then Dest[Len] := #0;
end;

function TrimMessage(Msg: PChar): PChar;
var
  Blank: Boolean;
  Source, Dest: PChar;
begin
  Source := Msg;
  Dest := Msg;
  Blank := False;
  while Source^ <> #0 do begin
    if Source^ <= ' ' then Blank := True
    else begin
      if Blank then begin
        Dest^ := ' ';
        Inc(Dest);
        Blank := False;
      end;
      Dest^ := Source^;
      Inc(Dest);
    end;
    Inc(Source);
  end;
  if (Dest > Msg) and ((Dest - 1)^ = '.') then Dec(Dest);
  Dest^ := #0;
  Result := Msg;
end;

function BdeErrorMsg(ErrorCode: DBIResult): string;
var
  I: Integer;
  NativeError: Longint;
  Msg, LastMsg: DBIMSG;
begin
  I := 1;
  DbiGetErrorString(ErrorCode, Msg);
  TrimMessage(Msg);
  if Msg[0] = #0 then Result := Format(ResStr(SBDEError), [ErrorCode])
  else Result := StrPas(Msg);
  while True do begin
    StrCopy(LastMsg, Msg);
    ErrorCode := DbiGetErrorEntry(I, NativeError, Msg);
    if (ErrorCode = DBIERR_NONE) or
      (ErrorCode = DBIERR_NOTINITIALIZED) then Break;
    TrimMessage(Msg);
    if (Msg[0] <> #0) and (StrComp(Msg, LastMsg) <> 0) then
      Result := Format('%s. %s', [Result, Msg]);
    Inc(I);
  end;
  for I := 1 to Length(Result) do
    if Result[I] < ' ' then Result[I] := ' ';
end;

procedure DataSetShowDeleted(DataSet: TBDEDataSet; Show: Boolean);
begin
  with DataSet do begin
    CheckBrowseMode;
    Check(DbiValidateProp(hDBIObj(Handle), curSOFTDELETEON, True));
    DisableControls;
    try
      Check(DbiSetProp(hDBIObj(Handle), curSOFTDELETEON, Ord(Show)));
    finally
      EnableControls;
    end;
    if DataSet is TTable then TTable(DataSet).Refresh
    else begin
      CursorPosChanged;
      First;
    end;
  end;
end;

function CurrentRecordDeleted(DataSet: TBDEDataSet): Boolean;
var
  FRecProp: RECProps;
begin
  Result := False;
  if (DataSet <> nil) and DataSet.Active then begin
    DataSet.GetCurrentRecord(nil);
    if DbiGetRecord(DataSet.Handle, dbiNOLOCK, nil, @FRecProp) = DBIERR_NONE
      then Result := FRecProp.bDeleteFlag;
  end;
end;

procedure DbNotSupported;
begin
  DbiError(DBIERR_NOTSUPPORTED);
end;

procedure ToggleDebugLayer(Active: Boolean; const DebugFile: string);
const
  Options: array[Boolean] of Longint = (0, DEBUGON or OUTPUTTOFILE or
    APPENDTOLOG);
var
  FileName: DBIPATH;
begin
  Check(DbiDebugLayerOptions(Options[Active], StrPLCopy(FileName,
    DebugFile, SizeOf(DBIPATH) - 1)));
end;

initialization
  DbUtils.CreateLocateObject := CreateDbLocate;
{$IFDEF WIN32}
finalization
  ReleaseSaveIndexies;
{$ELSE}
  AddExitProc(ReleaseSaveIndexies);
{$ENDIF}
end.