home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d6 / RX275D6.ZIP / Units / BdeUtils.pas < prev    next >
Pascal/Delphi Source File  |  2001-06-24  |  49KB  |  1,753 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 1995, 1996 AO ROSNO             }
  6. {         Copyright (c) 1997, 1998 Master-Bank          }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit BdeUtils;
  11.  
  12. {$I RX.INC}
  13. {$W-,R-,B-,N+,P+}
  14.  
  15. interface
  16.  
  17. uses SysUtils, Windows, Bde, Registry, RTLConsts, Classes, DB, DBTables,
  18.   IniFiles, DBUtils;
  19.  
  20. type
  21. {$IFNDEF WIN32}
  22.   TLocateFilter = (lfTree, lfCallback);
  23. {$ENDIF}
  24.  
  25. {$IFNDEF RX_D3}
  26.   TBDEDataSet = TDataSet;
  27. {$ENDIF}
  28.  
  29. {$IFNDEF RX_D5}
  30.   TDatabaseLoginEvent = TLoginEvent;
  31. {$ENDIF}
  32.  
  33.   TDBLocate = class(TLocateObject)
  34.   private
  35. {$IFNDEF WIN32}
  36.     FFilterHandle: HDBIFilter;
  37.     FTree: PChar;
  38.     FTreeSize: Integer;
  39.     FFilterKind: TLocateFilter;
  40.     procedure ActivateFilter;
  41.     procedure DeactivateFilter;
  42.     procedure DropFilter;
  43.     procedure CheckFilterKind;
  44.     procedure ChangeBookmark;
  45.     procedure BuildFilterHeader(var Rec);
  46.     procedure BuildFilterTree;
  47.     procedure FreeTree;
  48.     function RecordFilter(RecBuf: Pointer; RecNo: Longint): Smallint;
  49.       {$IFDEF WIN32} stdcall; {$ENDIF}
  50. {$ELSE}
  51.     function LocateCallback: Boolean;
  52.     procedure RecordFilter(DataSet: TDataSet; var Accept: Boolean);
  53. {$ENDIF WIN32}
  54.   protected
  55. {$IFDEF WIN32}
  56.     function LocateFilter: Boolean; override;
  57. {$ELSE}
  58.     procedure ActiveChanged; override;
  59.     function LocateFilter: Boolean; override;
  60. {$ENDIF WIN32}
  61.     procedure CheckFieldType(Field: TField); override;
  62.     function LocateKey: Boolean; override;
  63.     function UseKey: Boolean; override;
  64.     function FilterApplicable: Boolean; override;
  65.   public
  66.     destructor Destroy; override;
  67.   end;
  68.  
  69. { TCloneDataset }
  70.  
  71.   TCloneDataset = class(TBDEDataSet)
  72.   private
  73.     FSourceHandle: HDBICur;
  74.     FReadOnly: Boolean;
  75.     procedure SetReadOnly(Value: Boolean);
  76.     procedure SetSourceHandle(ASourceHandle: HDBICur);
  77.   protected
  78.     function CreateHandle: HDBICur; override;
  79.   public
  80.     property SourceHandle: HDBICur read FSourceHandle write SetSourceHandle;
  81.   published
  82.     property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
  83.   end;
  84.  
  85. { TCloneDbDataset }
  86.  
  87.   TCloneDbDataset = class(TDBDataSet)
  88.   private
  89.     FSourceHandle: HDBICur;
  90.     FReadOnly: Boolean;
  91.     procedure SetReadOnly(Value: Boolean);
  92.     procedure SetSourceHandle(ASourceHandle: HDBICur);
  93.   protected
  94.     function CreateHandle: HDBICur; override;
  95.   public
  96.     procedure InitFromDataSet(Source: TDBDataSet; Reset: Boolean);
  97.     property SourceHandle: HDBICur read FSourceHandle write SetSourceHandle;
  98.   published
  99.     property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
  100.   end;
  101.  
  102. { TCloneTable }
  103.  
  104.   TCloneTable = class(TTable)
  105.   private
  106.     FSourceHandle: HDBICur;
  107.     FReadOnly: Boolean;
  108.     procedure SetReadOnly(Value: Boolean);
  109.     procedure SetSourceHandle(ASourceHandle: HDBICur);
  110.   protected
  111.     function CreateHandle: HDBICur; override;
  112.   public
  113.     procedure InitFromTable(SourceTable: TTable; Reset: Boolean);
  114.   published
  115.     property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
  116.   end;
  117.  
  118. { Utility routines }
  119.  
  120. function CreateDbLocate: TLocateObject;
  121. {$IFNDEF WIN32}
  122. function CheckOpen(Status: DBIResult): Boolean;
  123. {$ENDIF}
  124. procedure FetchAllRecords(DataSet: TBDEDataSet);
  125. function TransActive(Database: TDatabase): Boolean;
  126. function AsyncQrySupported(Database: TDatabase): Boolean;
  127. {$IFDEF WIN32}
  128. function GetQuoteChar(Database: TDatabase): string;
  129. {$ENDIF}
  130. procedure ExecuteQuery(const DbName, QueryText: string);
  131. procedure ExecuteQueryEx(const SessName, DbName, QueryText: string);
  132. procedure BdeTranslate(Locale: TLocale; Source, Dest: PChar; ToOem: Boolean);
  133. function FieldLogicMap(FldType: TFieldType): Integer;
  134. function FieldSubtypeMap(FldType: TFieldType): Integer;
  135. procedure ConvertStringToLogicType(Locale: TLocale; FldLogicType: Integer;
  136.   FldSize: Word; const FldName, Value: string; Buffer: Pointer);
  137. function GetAliasPath(const AliasName: string): string;
  138. function IsDirectory(const DatabaseName: string): Boolean;
  139. function GetBdeDirectory: string;
  140. function BdeErrorMsg(ErrorCode: DBIResult): string;
  141. function LoginToDatabase(Database: TDatabase; OnLogin: TDatabaseLoginEvent): Boolean;
  142. function DataSetFindValue(ADataSet: TBDEDataSet; const Value,
  143.   FieldName: string): Boolean;
  144. function DataSetFindLike(ADataSet: TBDEDataSet; const Value,
  145.   FieldName: string): Boolean;
  146. function DataSetRecNo(DataSet: TDataSet): Longint;
  147. function DataSetRecordCount(DataSet: TDataSet): Longint;
  148. function DataSetPositionStr(DataSet: TDataSet): string;
  149. procedure DataSetShowDeleted(DataSet: TBDEDataSet; Show: Boolean);
  150. function CurrentRecordDeleted(DataSet: TBDEDataSet): Boolean;
  151. function IsFilterApplicable(DataSet: TDataSet): Boolean;
  152. function IsBookmarkStable(DataSet: TBDEDataSet): Boolean;
  153. function BookmarksCompare(DataSet: TBDEDataSet; Bookmark1,
  154.   Bookmark2: TBookmark): Integer;
  155. function SetToBookmark(ADataSet: TDataSet; ABookmark: TBookmark): Boolean;
  156. procedure SetIndex(Table: TTable; const IndexFieldNames: string);
  157. procedure RestoreIndex(Table: TTable);
  158. procedure DeleteRange(Table: TTable; IndexFields: array of const;
  159.   FieldValues: array of const);
  160. procedure PackTable(Table: TTable);
  161. procedure ReindexTable(Table: TTable);
  162. procedure BdeFlushBuffers;
  163. function GetNativeHandle(Database: TDatabase; Buffer: Pointer;
  164.   BufSize: Integer): Pointer;
  165. procedure ToggleDebugLayer(Active: Boolean; const DebugFile: string);
  166. procedure DbNotSupported;
  167.  
  168. { Export/import DataSet routines }
  169.  
  170. procedure ExportDataSet(Source: TBDEDataSet; DestTable: TTable;
  171.   TableType: TTableType; const AsciiCharSet: string;
  172.   AsciiDelimited: Boolean; MaxRecordCount: Longint);
  173. procedure ExportDataSetEx(Source: TBDEDataSet; DestTable: TTable;
  174.   TableType: TTableType; const AsciiCharSet: string;
  175.   AsciiDelimited: Boolean; AsciiDelimiter, AsciiSeparator: Char;
  176.   MaxRecordCount: Longint);
  177. procedure ImportDataSet(Source: TBDEDataSet; DestTable: TTable;
  178.   MaxRecordCount: Longint; Mappings: TStrings; Mode: TBatchMode);
  179.  
  180. { ReportSmith initialization }
  181.  
  182. procedure InitRSRUN(Database: TDatabase; const ConName: string;
  183.   ConType: Integer; const ConServer: string);
  184.  
  185. implementation
  186.  
  187. uses Forms, Controls, Dialogs, Consts, DBConsts, RXDConst, VCLUtils,
  188.   FileUtil, AppUtils, rxStrUtils, MaxMin, {$IFNDEF WIN32} Str16, {$ENDIF}
  189.   {$IFDEF RX_D3} BDEConst, DBCommon, {$ENDIF} DateUtil;
  190.  
  191. { Utility routines }
  192.  
  193. {$IFDEF RX_D5}
  194. procedure DBError(Ident: Word);
  195. begin
  196.   DatabaseError(LoadStr(Ident));
  197. end;
  198. {$ENDIF}
  199.  
  200. function IsBookmarkStable(DataSet: TBDEDataSet): Boolean;
  201. var
  202.   Props: CURProps;
  203. begin
  204.   with DataSet do
  205.     Result := Active and (DbiGetCursorProps(Handle, Props) = DBIERR_NONE) and
  206.       Props.bBookMarkStable;
  207. end;
  208.  
  209. function SetToBookmark(ADataSet: TDataSet; ABookmark: TBookmark): Boolean;
  210. begin
  211.   Result := False;
  212. {$IFDEF RX_D3}
  213.   with ADataSet do
  214.     if Active and (ABookmark <> nil) and not (Bof and Eof) and
  215.       BookmarkValid(ABookmark) then
  216.     try
  217.       ADataSet.GotoBookmark(ABookmark);
  218.       Result := True;
  219.     except
  220.     end;
  221. {$ELSE}
  222.   with TBDEDataSet(ADataSet) do
  223.     if Active and (ABookmark <> nil) and not (Bof and Eof) then
  224.       if DbiSetToBookmark(Handle, ABookmark) = DBIERR_NONE then
  225.       try
  226.         Resync([rmExact, rmCenter]);
  227.         Result := True;
  228.       except
  229.       end;
  230. {$ENDIF}
  231. end;
  232.  
  233. function BookmarksCompare(DataSet: TBDEDataSet; Bookmark1, Bookmark2: TBookmark): Integer;
  234. const
  235.   RetCodes: array[Boolean, Boolean] of ShortInt =
  236.     ((2, CMPLess), (CMPGtr, CMPEql));
  237. begin
  238.   Result := RetCodes[Bookmark1 = nil, Bookmark2 = nil];
  239.   if Result = 2 then begin
  240.     Check(DbiCompareBookmarks(DataSet.Handle, Bookmark1, Bookmark2, 
  241.       {$IFDEF WIN32} Result)); {$ELSE} Word(Result))); {$ENDIF}
  242.     if Result = CMPKeyEql then Result := CMPEql;
  243.   end;
  244. end;
  245.  
  246. function DBGetIntProp(const Handle: Pointer; PropName: Longint): Longint;
  247. var
  248.   Length: Word;
  249.   Value: Longint;
  250. begin
  251.   Value := 0;
  252.   Check(DbiGetProp(HDBIObj(Handle), PropName, @Value, SizeOf(Value), Length));
  253.   Result := Value;
  254. end;
  255.  
  256. {$IFDEF WIN32}
  257. function GetQuoteChar(Database: TDatabase): string;
  258. {$IFNDEF RX_D3}
  259. const
  260.   dbQUOTECHAR = $0404000A;
  261. {$ENDIF}
  262. var
  263.   Q: Char;
  264.   Len: Word;
  265. begin
  266.   Result := '';
  267.   if Database.IsSQLBased then begin
  268.     Q := #0;
  269.     DbiGetProp(HDBIObj(Database.Handle), dbQUOTECHAR, @Q, SizeOf(Q), Len);
  270.     if Q <> #0 then Result := Q;
  271.   end
  272.   else Result := '"';
  273. end;
  274. {$ENDIF}
  275.  
  276. function AsyncQrySupported(Database: TDatabase): Boolean;
  277. begin
  278.   Result := False;
  279.   if Database.Connected then
  280.     if Database.IsSQLBased then
  281.       try
  282.         Result := BOOL(DBGetIntProp(Database.Handle, dbASYNCSUPPORT));
  283.       except
  284.       end
  285.     else Result := {$IFDEF WIN32} True {$ELSE} False {$ENDIF};
  286. end;
  287.  
  288. function FieldLogicMap(FldType: TFieldType): Integer;
  289. {$IFNDEF RX_D3}
  290. {$IFDEF VER80}
  291. const
  292.   FldTypeMap: array[TFieldType] of Integer = (
  293.     fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
  294.     fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
  295.     fldVARBYTES, fldBLOB, fldBLOB, fldBLOB);
  296. {$ELSE}
  297. const
  298.   FldTypeMap: array[TFieldType] of Integer = (
  299.     fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
  300.     fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
  301.     fldVARBYTES, fldINT32, fldBLOB, fldBLOB, fldBLOB, fldBLOB, fldBLOB,
  302.     fldBLOB, fldBLOB);
  303. {$ENDIF}
  304. {$ENDIF}
  305. begin
  306.   Result := FldTypeMap[FldType];
  307. end;
  308.  
  309. function FieldSubtypeMap(FldType: TFieldType): Integer;
  310. {$IFNDEF RX_D3}
  311. {$IFDEF VER80}
  312. const
  313.   FldSubtypeMap: array[TFieldType] of Integer = (
  314.     0, 0, 0, 0, 0, 0, 0, fldstMONEY, 0, 0, 0, 0, 0, 0, fldstBINARY,
  315.     fldstMEMO, fldstGRAPHIC);
  316. {$ELSE}
  317. const
  318.   FldSubtypeMap: array[TFieldType] of Integer = (
  319.     0, 0, 0, 0, 0, 0, 0, fldstMONEY, 0, 0, 0, 0, 0, 0, fldstAUTOINC,
  320.     fldstBINARY, fldstMEMO, fldstGRAPHIC, fldstFMTMEMO, fldstOLEOBJ,
  321.     fldstDBSOLEOBJ, fldstTYPEDBINARY);
  322. {$ENDIF}
  323. {$ENDIF}
  324. begin
  325.   Result := FldSubtypeMap[FldType];
  326. end;
  327.  
  328. {$IFNDEF WIN32}
  329. function CheckOpen(Status: DBIResult): Boolean;
  330. begin
  331.   case Status of
  332.     DBIERR_NONE:
  333.       Result := True;
  334.     DBIERR_NOTSUFFTABLERIGHTS:
  335.       begin
  336.         if not Session.GetPassword then DbiError(Status);
  337.         Result := False;
  338.       end;
  339.   else
  340.     DbiError(Status);
  341.   end;
  342. end;
  343. {$ENDIF}
  344.  
  345. { Routine for convert string to IDAPI logical field type }
  346.  
  347. procedure ConvertStringToLogicType(Locale: TLocale; FldLogicType: Integer;
  348.   FldSize: Word; const FldName, Value: string; Buffer: Pointer);
  349. var
  350.   Allocate: Boolean;
  351.   BCD: FMTBcd;
  352.   E: Integer;
  353.   L: Longint;
  354.   B: WordBool;
  355.   DateTime: TDateTime;
  356.   DtData: TDateTime;
  357.   D: Double absolute DtData;
  358.   Data: Longint absolute DtData;
  359. {$IFDEF WIN32}
  360.   TimeStamp: TTimeStamp;
  361. {$ENDIF}
  362. begin
  363.   if Buffer = nil then begin
  364.     Buffer := AllocMem(FldSize);
  365.     Allocate := Buffer <> nil;
  366.   end
  367.   else Allocate := False;
  368.   try
  369.     case FldLogicType of
  370.       fldZSTRING:
  371.         begin
  372.           AnsiToNative(Locale, Value, PChar(Buffer), FldSize);
  373.         end;
  374.       fldBYTES, fldVARBYTES:
  375.         begin
  376.           Move(Value[1], Buffer^, Min(Length(Value), FldSize));
  377.         end;
  378.       fldINT16, fldINT32, fldUINT16:
  379.         begin
  380.           if Value = '' then FillChar(Buffer^, FldSize, 0)
  381.           else begin
  382.             Val(Value, L, E);
  383.             if E <> 0 then
  384. {$IFDEF RX_D3}
  385.               DatabaseErrorFmt(SInvalidIntegerValue, [Value, FldName]);
  386. {$ELSE}
  387.               DBErrorFmt(SInvalidIntegerValue, [Value, FldName]);
  388. {$ENDIF}
  389.             Move(L, Buffer^, FldSize);
  390.           end;
  391.         end;
  392.       fldBOOL:
  393.         begin
  394.           L := Length(Value);
  395.           if L = 0 then B := False
  396.           else begin
  397.             if Value[1] in ['Y', 'y', 'T', 't', '1'] then B := True
  398.             else B := False;
  399.           end;
  400.           Move(B, Buffer^, SizeOf(WordBool));
  401.         end;
  402.       fldFLOAT, fldBCD:
  403.         begin
  404.           if Value = '' then FillChar(Buffer^, FldSize, 0)
  405.           else begin
  406.             D := StrToFloat(Value);
  407.             if FldLogicType <> fldBCD then Move(D, Buffer^, SizeOf(Double))
  408.             else begin
  409.               DbiBcdFromFloat(D, 32, FldSize, BCD);
  410.               Move(BCD, Buffer^, SizeOf(BCD));
  411.             end;
  412.           end;
  413.         end;
  414.       fldDATE, fldTIME, fldTIMESTAMP:
  415.         begin
  416.           if Value = '' then Data := Trunc(NullDate)
  417.           else begin
  418.             case FldLogicType of
  419.               fldDATE:
  420.                 begin
  421.                   DateTime := StrToDate(Value);
  422. {$IFDEF WIN32}
  423.                   TimeStamp := DateTimeToTimeStamp(DateTime);
  424.                   Data := TimeStamp.Date;
  425. {$ELSE}
  426.                   Data := Trunc(DateTime);
  427. {$ENDIF}
  428.                 end;
  429.               fldTIME:
  430.                 begin
  431.                   DateTime := StrToTime(Value);
  432. {$IFDEF WIN32}
  433.                   TimeStamp := DateTimeToTimeStamp(DateTime);
  434.                   Data := TimeStamp.Time;
  435. {$ELSE}
  436.                   Data := Round(Frac(DateTime) * MSecsPerDay);
  437. {$ENDIF}
  438.                 end;
  439.               fldTIMESTAMP:
  440.                 begin
  441.                   DateTime := StrToDateTime(Value);
  442. {$IFDEF WIN32}
  443.                   TimeStamp := DateTimeToTimeStamp(DateTime);
  444.                   D := TimeStampToMSecs(DateTimeToTimeStamp(DateTime));
  445. {$ELSE}
  446.                   DtData := DateTime * MSecsPerDay;
  447. {$ENDIF}
  448.                 end;
  449.             end;
  450.           end;
  451.           Move(D, Buffer^, FldSize);
  452.         end;
  453.       else DbiError(DBIERR_INVALIDFLDTYPE);
  454.     end;
  455.   finally
  456.     if Allocate then FreeMem(Buffer, FldSize);
  457.   end;
  458. end;
  459.  
  460. { Execute Query routine }
  461.  
  462. procedure ExecuteQueryEx(const SessName, DbName, QueryText: string);
  463. begin
  464.   with TQuery.Create(Application) do
  465.   try
  466.     DatabaseName := DbName;
  467. {$IFDEF WIN32}
  468.     SessionName := SessName;
  469. {$ENDIF}
  470.     SQL.Add(QueryText);
  471.     ExecSQL;
  472.   finally
  473.     Free;
  474.   end;
  475. end;
  476.  
  477. procedure ExecuteQuery(const DbName, QueryText: string);
  478. begin
  479.   ExecuteQueryEx('', DbName, QueryText);
  480. end;
  481.  
  482. { Database Login routine }
  483.  
  484. function LoginToDatabase(Database: TDatabase; OnLogin: TDatabaseLoginEvent): Boolean;
  485. var
  486.   EndLogin: Boolean;
  487. begin
  488.   Result := Database.Connected;
  489.   if Result then Exit;
  490.   Database.OnLogin := OnLogin;
  491.   EndLogin := True;
  492.   repeat
  493.     try
  494.       Database.Connected := True;
  495.       EndLogin := True;
  496.     except
  497.       on E: EDbEngineError do begin
  498.         EndLogin := (MessageDlg(E.Message + '. ' + LoadStr(SRetryLogin),
  499.           mtConfirmation, [mbYes, mbNo], 0) <> mrYes);
  500.       end;
  501.       on E: EDatabaseError do begin
  502.         { User select "Cancel" in login dialog }
  503.         MessageDlg(E.Message, mtError, [mbOk], 0);
  504.       end;
  505.       else raise;
  506.     end;
  507.   until EndLogin;
  508.   Result := Database.Connected;
  509. end;
  510.  
  511. { ReportSmith runtime initialization routine }
  512.  
  513. procedure InitRSRUN(Database: TDatabase; const ConName: string;
  514.   ConType: Integer; const ConServer: string);
  515. const
  516.   IniFileName = 'RPTSMITH.CON';
  517.   scConNames = 'ConnectNamesSection';
  518.   idConNames = 'ConnectNames';
  519.   idType = 'Type';
  520.   idServer = 'Server';
  521.   idSQLDataFilePath = 'Database';
  522.   idDataFilePath = 'DataFilePath';
  523.   idSQLUserID = 'USERID';
  524. var
  525.   ParamList: TStringList;
  526.   DBPath: string[127];
  527.   TempStr, AppConName: string[127];
  528.   UserName: string[30];
  529.   ExeName: string[12];
  530.   IniFile: TIniFile;
  531. begin
  532.   ParamList := TStringList.Create;
  533.   try
  534. {$IFDEF WIN32}
  535.     Database.Session.GetAliasParams(Database.AliasName, ParamList);
  536. {$ELSE}
  537.     Session.GetAliasParams(Database.AliasName, ParamList);
  538. {$ENDIF}
  539.     if Database.IsSQLBased then DBPath := ParamList.Values['SERVER NAME']
  540.     else DBPath := ParamList.Values['PATH'];
  541.     UserName := ParamList.Values['USER NAME'];
  542.   finally
  543.     ParamList.Free;
  544.   end;
  545.   AppConName := ConName;
  546.   if AppConName = '' then begin
  547.     ExeName := ExtractFileName(Application.ExeName);
  548.     AppConName := Copy(ExeName, 1, Pos('.', ExeName) - 1);
  549.   end;
  550.   IniFile := TIniFile.Create(IniFileName);
  551.   try
  552.     TempStr := IniFile.ReadString(scConNames, idConNames, '');
  553.     if Pos(AppConName, TempStr) = 0 then begin
  554.       if TempStr <> '' then TempStr := TempStr + ',';
  555.       IniFile.WriteString(scConNames, idConNames, TempStr + AppConName);
  556.     end;
  557.     IniFile.WriteInteger(AppConName, idType, ConType);
  558.     IniFile.WriteString(AppConName, idServer, ConServer);
  559.     if Database.IsSQLBased then begin
  560.       IniFile.WriteString(AppConName, idSQLDataFilePath, DBPath);
  561.       IniFile.WriteString(AppConName, idSQLUserID, UserName);
  562.     end
  563.     else IniFile.WriteString(AppConName, idDataFilePath, DBPath);
  564.   finally
  565.     IniFile.Free;
  566.   end;
  567. end;
  568.  
  569. { BDE aliases routines }
  570.  
  571. function IsDirectory(const DatabaseName: string): Boolean;
  572. var
  573.   I: Integer;
  574. begin
  575.   Result := True;
  576.   if (DatabaseName = '') then Exit;
  577.   I := 1;
  578.   while I <= Length(DatabaseName) do begin
  579. {$IFDEF RX_D3}
  580.     if DatabaseName[I] in LeadBytes then Inc(I) else
  581. {$ENDIF RX_D3}
  582.     if DatabaseName[I] in [':','\'] then Exit;
  583.     Inc(I);
  584.   end;
  585.   Result := False;
  586. end;
  587.  
  588. function GetAliasPath(const AliasName: string): string;
  589. var
  590.   SAlias: DBINAME;
  591.   Desc: DBDesc;
  592.   Params: TStrings;
  593. begin
  594.   Result := '';
  595.   StrPLCopy(SAlias, AliasName, SizeOf(SAlias) - 1);
  596.   AnsiToOem(SAlias, SAlias);
  597.   Check(DbiGetDatabaseDesc(SAlias, @Desc));
  598.   if StrIComp(Desc.szDbType, szCFGDBSTANDARD) = 0 then begin
  599.     OemToAnsi(Desc.szPhyName, Desc.szPhyName);
  600.     Result := StrPas(Desc.szPhyName);
  601.   end
  602.   else begin
  603.     Params := TStringList.Create;
  604.     try
  605. {$IFDEF WIN32}
  606.       Session.Active := True;
  607. {$ENDIF}
  608.       Session.GetAliasParams(AliasName, Params);
  609.       Result := Params.Values['SERVER NAME'];
  610.     finally
  611.       Params.Free;
  612.     end;
  613.   end;
  614. end;
  615.  
  616. { TCloneDataset }
  617.  
  618. procedure TCloneDataset.SetSourceHandle(ASourceHandle: HDBICur);
  619. begin
  620.   if ASourceHandle <> FSourceHandle then begin
  621.     Close;
  622.     FSourceHandle := ASourceHandle;
  623.     if FSourceHandle <> nil then Open;
  624.   end;
  625. end;
  626.  
  627. function TCloneDataset.CreateHandle: HDBICur;
  628. begin
  629.   Check(DbiCloneCursor(FSourceHandle, FReadOnly, False, Result));
  630. end;
  631.  
  632. procedure TCloneDataset.SetReadOnly(Value: Boolean);
  633. begin
  634.   CheckInactive;
  635.   FReadOnly := Value;
  636. end;
  637.  
  638. { TCloneDbDataset }
  639.  
  640. procedure TCloneDbDataset.InitFromDataSet(Source: TDBDataSet; Reset: Boolean);
  641. begin
  642.   with Source do begin
  643. {$IFDEF WIN32}
  644.     Self.SessionName := SessionName;
  645. {$ENDIF}
  646.     Self.DatabaseName := DatabaseName;
  647.     SetSourceHandle(Handle);
  648. {$IFDEF WIN32}
  649.     Self.Filter := Filter;
  650.     Self.OnFilterRecord := OnFilterRecord;
  651.     if not Reset then Self.Filtered := Filtered;
  652. {$ENDIF}
  653.   end;
  654.   if Reset then begin
  655. {$IFDEF WIN32}
  656.     Filtered := False;
  657. {$ENDIF}
  658.     First;
  659.   end;
  660. end;
  661.  
  662. procedure TCloneDbDataset.SetSourceHandle(ASourceHandle: HDBICur);
  663. begin
  664.   if ASourceHandle <> FSourceHandle then begin
  665.     Close;
  666.     FSourceHandle := ASourceHandle;
  667.     if FSourceHandle <> nil then Open;
  668.   end;
  669. end;
  670.  
  671. function TCloneDbDataset.CreateHandle: HDBICur;
  672. begin
  673.   Check(DbiCloneCursor(FSourceHandle, FReadOnly, False, Result));
  674. end;
  675.  
  676. procedure TCloneDbDataset.SetReadOnly(Value: Boolean);
  677. begin
  678.   CheckInactive;
  679.   FReadOnly := Value;
  680. end;
  681.  
  682. { TCloneTable }
  683.  
  684. procedure TCloneTable.InitFromTable(SourceTable: TTable; Reset: Boolean);
  685. begin
  686.   with SourceTable do begin
  687.     Self.TableType := TableType;
  688.     Self.TableName := TableName;
  689. {$IFDEF WIN32}
  690.     Self.SessionName := SessionName;
  691. {$ENDIF}
  692.     Self.DatabaseName := DatabaseName;
  693.     if not Reset then begin
  694.       if IndexName <> '' then
  695.         Self.IndexName := IndexName
  696.       else if IndexFieldNames <> '' then
  697.         Self.IndexFieldNames := IndexFieldNames;
  698.     end;
  699.     SetSourceHandle(Handle);
  700. {$IFDEF WIN32}
  701.     Self.Filter := Filter;
  702.     Self.OnFilterRecord := OnFilterRecord;
  703.     if not Reset then Self.Filtered := Filtered;
  704. {$ENDIF}
  705.   end;
  706.   if Reset then begin
  707. {$IFDEF WIN32}
  708.     Filtered := False;
  709. {$ENDIF}
  710.     DbiResetRange(Handle);
  711.     IndexName := '';
  712.     IndexFieldNames := '';
  713.     First;
  714.   end;
  715. end;
  716.  
  717. procedure TCloneTable.SetSourceHandle(ASourceHandle: HDBICur);
  718. begin
  719.   if ASourceHandle <> FSourceHandle then begin
  720.     Close;
  721.     FSourceHandle := ASourceHandle;
  722.     if FSourceHandle <> nil then Open;
  723.   end;
  724. end;
  725.  
  726. procedure TCloneTable.SetReadOnly(Value: Boolean);
  727. begin
  728.   CheckInactive;
  729.   FReadOnly := Value;
  730. end;
  731.  
  732. function TCloneTable.CreateHandle: HDBICur;
  733. begin
  734.   Check(DbiCloneCursor(FSourceHandle, FReadOnly, False, Result));
  735. end;
  736.  
  737. { TDBLocate }
  738.  
  739. function CreateDbLocate: TLocateObject;
  740. begin
  741.   Result := TDBLocate.Create;
  742. end;
  743.  
  744. {$IFNDEF WIN32}
  745. function CallbackFilter(pDBLocate: Longint; RecBuf: Pointer;
  746.   RecNo: Longint): Smallint;
  747.   {$IFDEF WIN32} stdcall; {$ELSE} export; {$ENDIF WIN32}
  748. begin
  749.   Result := TDBLocate(pDBLocate).RecordFilter(RecBuf, RecNo);
  750. end;
  751. {$ENDIF WIN32}
  752.  
  753. destructor TDBLocate.Destroy;
  754. begin
  755. {$IFNDEF WIN32}
  756.   DropFilter;
  757. {$ENDIF}
  758.   inherited Destroy;
  759. end;
  760.  
  761. procedure TDBLocate.CheckFieldType(Field: TField);
  762. var
  763.   Locale: TLocale;
  764. begin
  765.   if not (Field.DataType in [ftDate, ftTime, ftDateTime]) then begin
  766.     if DataSet is TBDEDataSet then Locale := TBDEDataSet(DataSet).Locale
  767.     else Locale := Session.Locale;
  768.     ConvertStringToLogicType(Locale, FieldLogicMap(Field.DataType),
  769.       Field.DataSize, Field.FieldName, LookupValue, nil);
  770.   end;
  771. end;
  772.  
  773. function TDBLocate.UseKey: Boolean;
  774. var
  775.   I: Integer;
  776. begin
  777.   Result := False;
  778.   if DataSet is TTable then
  779.     with DataSet as TTable do begin
  780.       if (not Self.LookupField.IsIndexField) and (not IndexSwitch or
  781.         (not CaseSensitive and Database.IsSQLBased)) then Exit;
  782.       if (not LookupExact) and (Self.LookupField.DataType <> ftString) then Exit;
  783.       IndexDefs.Update;
  784.       for I := 0 to IndexDefs.Count - 1 do
  785.         with IndexDefs[I] do
  786.           if not (ixExpression in Options) and
  787.             ((ixCaseInsensitive in Options) or CaseSensitive) then
  788.             if AnsiCompareText(Fields, Self.LookupField.FieldName) = 0 then
  789.             begin
  790.               Result := True;
  791.               Exit;
  792.             end;
  793.     end;
  794. end;
  795.  
  796. function TDBLocate.LocateKey: Boolean;
  797. var
  798.   Clone: TCloneTable;
  799.  
  800.   function LocateIndex(Table: TTable): Boolean;
  801.   begin
  802.     with Table do begin
  803.       SetKey;
  804.       FieldByName(Self.LookupField.FieldName).AsString := LookupValue;
  805.       if LookupExact then Result := GotoKey
  806.       else begin
  807.         GotoNearest;
  808.         Result := MatchesLookup(FieldByName(Self.LookupField.FieldName));
  809.       end;
  810.     end;
  811.   end;
  812.  
  813. begin
  814.   try
  815.     TTable(DataSet).CheckBrowseMode;
  816.     if TTable(DataSet).IndexFieldNames = LookupField.FieldName then
  817.       Result := LocateIndex(TTable(DataSet))
  818.     else begin
  819.       Clone := TCloneTable.Create(DataSet);
  820.       with Clone do
  821.       try
  822.         ReadOnly := True;
  823.         InitFromTable(TTable(DataSet), True);
  824.         IndexFieldNames := Self.LookupField.FieldName;
  825.         Result := LocateIndex(Clone);
  826.         if Result then begin
  827.           Check(DbiSetToCursor(TTable(DataSet).Handle, Handle));
  828.           DataSet.Resync([rmExact, rmCenter]);
  829.         end;
  830.       finally
  831.         Free;
  832.       end;
  833.     end;
  834.   except
  835.     Result := False;
  836.   end;
  837. end;
  838.  
  839. function TDBLocate.FilterApplicable: Boolean;
  840. begin
  841.   Result := IsFilterApplicable(DataSet);
  842. end;
  843.  
  844. {$IFDEF WIN32}
  845.  
  846. function TDBLocate.LocateCallback: Boolean;
  847. var
  848.   Clone: TCloneDbDataset;
  849. begin
  850.   Result := False;
  851.   try
  852.     TBDEDataSet(DataSet).CheckBrowseMode;
  853.     Clone := TCloneDbDataset.Create(DataSet);
  854.     with Clone do
  855.     try
  856.       ReadOnly := True;
  857.       InitFromDataset(TDBDataSet(DataSet), True);
  858.       OnFilterRecord := RecordFilter;
  859.       Filtered := True;
  860.       if not (BOF and EOF) then begin
  861.         First;
  862.         Result := True;
  863.       end;
  864.       if Result then begin
  865.         Check(DbiSetToCursor(TBDEDataSet(DataSet).Handle, Handle));
  866.         DataSet.Resync([rmExact, rmCenter]);
  867.       end;
  868.     finally
  869.       Free;
  870.     end;
  871.   except
  872.     Result := False;
  873.   end;
  874. end;
  875.  
  876. procedure TDBLocate.RecordFilter(DataSet: TDataSet; var Accept: Boolean);
  877. begin
  878.   Accept := MatchesLookup(DataSet.FieldByName(LookupField.FieldName));
  879. end;
  880.  
  881. function TDBLocate.LocateFilter: Boolean;
  882. var
  883.   SaveCursor: TCursor;
  884. begin
  885.   if LookupExact or (LookupField.DataType = ftString) or
  886.     not (DataSet is TDBDataSet) then
  887.     Result := inherited LocateFilter
  888.   else begin
  889.     SaveCursor := Screen.Cursor;
  890.     Screen.Cursor := crHourGlass;
  891.     try
  892.       Result := LocateCallback;
  893.     finally
  894.       Screen.Cursor := SaveCursor;
  895.     end;
  896.   end;
  897. end;
  898.  
  899. {$ELSE WIN32}
  900.  
  901. type
  902.   TFilterRec = record { the simple filter tree with one condition }
  903.     Header: CANExpr;
  904.     Condition: CANBinary;
  905.     FieldNode: CANField;
  906.     ConstNode: CANConst;
  907.   end;
  908.  
  909. function TDBLocate.LocateFilter: Boolean;
  910. var
  911.   SaveCursor: TCursor;
  912.   Status: DBIResult;
  913. begin
  914.   SaveCursor := Screen.Cursor;
  915.   Screen.Cursor := crHourGlass;
  916.   try
  917.     ActivateFilter;
  918.     try
  919.       Check(DbiSetToBegin(TBDEDataSet(DataSet).Handle));
  920.       Status := DbiGetNextRecord(TBDEDataSet(DataSet).Handle, dbiNoLock,
  921.         nil, nil);
  922.       if Status = DBIERR_NONE then begin
  923.         DataSet.Resync([rmExact, rmCenter]);
  924.         ChangeBookmark;
  925.         Result := True;
  926.       end
  927.       else Result := False;
  928.     finally
  929.       DeactivateFilter;
  930.       if Result then SetToBookmark(DataSet, Bookmark);
  931.     end;
  932.   finally
  933.     Screen.Cursor := SaveCursor;
  934.   end;
  935. end;
  936.  
  937. procedure TDBLocate.BuildFilterHeader(var Rec);
  938. const
  939.   FCondition: array[Boolean] of CANOp = (canGE, canEQ);
  940.   FilterHeaderSize = SizeOf(CANExpr) + SizeOf(CANBinary) +
  941.     SizeOf(CANField) + SizeOf(CANConst);
  942. begin
  943.   with TFilterRec(Rec) do begin
  944.     with Header do begin
  945.       iVer := CANEXPRVERSION;
  946.       iNodes := 3;
  947.       iNodeStart := SizeOf(CANExpr);
  948.       iLiteralStart := FilterHeaderSize;
  949.     end;
  950.     with Condition do begin
  951.       nodeClass := nodeBINARY;
  952.       canOp := FCondition[LookupExact];
  953.       iOperand1 := SizeOf(CANBinary);
  954.       iOperand2 := iOperand1 + SizeOf(CANField);
  955.     end;
  956.     with FieldNode do begin
  957.       nodeClass := nodeFIELD;
  958.       canOp := canFIELD2;
  959.       iFieldNum := LookupField.FieldNo;
  960.       iNameOffset := 0;
  961.     end;
  962.     with ConstNode do begin
  963.       canOp := canCONST2;
  964.       iType := FieldLogicMap(LookupField.DataType);
  965.       iSize := LookupField.DataSize;
  966.       iOffset := Length(LookupField.FieldName) + 1;
  967.     end;
  968.     Header.iTotalSize := FilterHeaderSize + ConstNode.iSize +
  969.       ConstNode.iOffset;
  970.   end;
  971. end;
  972.  
  973. procedure TDBLocate.BuildFilterTree;
  974. var
  975.   Temp: PChar;
  976.   Rec: TFilterRec;
  977. begin
  978.   if FTree <> nil then FreeMem(FTree, FTreeSize);
  979.   FTree := nil;
  980.   BuildFilterHeader(Rec);
  981.   FTreeSize := Rec.Header.iTotalSize;
  982.   FTree := AllocMem(FTreeSize);
  983.   try
  984.     FillChar(FTree^, FTreeSize, 0);
  985.     Temp := FTree;
  986.     Move(Rec, FTree^, SizeOf(TFilterRec));
  987.     Inc(Temp, SizeOf(TFilterRec));
  988.     StrPCopy(PChar(Temp), LookupField.FieldName);
  989.     Inc(Temp, Rec.ConstNode.iOffset);
  990.     ConvertStringToLogicType(DataSet.Locale, FieldLogicMap(LookupField.DataType),
  991.       LookupField.DataSize, LookupField.FieldName, LookupValue, Temp);
  992.   except
  993.     FreeTree;
  994.     raise;
  995.   end;
  996. end;
  997.  
  998. procedure TDBLocate.FreeTree;
  999. begin
  1000.   if FTree <> nil then FreeMem(FTree, FTreeSize);
  1001.   FTree := nil;
  1002.   FTreeSize := 0;
  1003. end;
  1004.  
  1005. procedure TDBLocate.CheckFilterKind;
  1006. var
  1007.   NewKind: TLocateFilter;
  1008. begin
  1009.   if CaseSensitive and LookupExact then NewKind := lfTree
  1010.   else NewKind := lfCallback;
  1011.   if (FFilterKind <> NewKind) or (NewKind = lfTree) then begin
  1012.     DropFilter;
  1013.     FFilterKind := NewKind;
  1014.   end;
  1015. end;
  1016.  
  1017. procedure TDBLocate.ActivateFilter;
  1018. begin
  1019.   CheckFilterKind;
  1020.   if FFilterHandle = nil then begin
  1021.     if FFilterKind = lfCallback then begin
  1022.       Check(DbiAddFilter(DataSet.Handle, Longint(Self), 0, True, nil,
  1023.         CallbackFilter, FFilterHandle));
  1024.     end
  1025.     else { lfTree } begin
  1026.       BuildFilterTree;
  1027.       Check(DbiAddFilter(DataSet.Handle, 0, 1, False,
  1028.         pCANExpr(FTree), nil, FFilterHandle));
  1029.     end;
  1030.   end;
  1031.   DbiActivateFilter(DataSet.Handle, FFilterHandle);
  1032. end;
  1033.  
  1034. procedure TDBLocate.DeactivateFilter;
  1035. begin
  1036.   DbiDeactivateFilter(DataSet.Handle, FFilterHandle);
  1037. end;
  1038.  
  1039. procedure TDBLocate.DropFilter;
  1040. begin
  1041.   if FFilterHandle <> nil then
  1042.     DbiDropFilter(DataSet.Handle, FFilterHandle);
  1043.   FreeTree;
  1044.   FFilterHandle := nil;
  1045. end;
  1046.  
  1047. function TDBLocate.RecordFilter(RecBuf: Pointer; RecNo: Longint): Smallint;
  1048. var
  1049.   Accept: Boolean;
  1050. begin
  1051.   try
  1052.     Move(RecBuf^, DataSet.ActiveBuffer^, DataSet.RecordSize);
  1053.     if LookupField <> nil then Accept := MatchesLookup(LookupField)
  1054.     else Accept := True;
  1055.     Result := Ord(Accept);
  1056.   except
  1057.     Application.HandleException(Self);
  1058.     Result := ABORT;
  1059.   end;
  1060. end;
  1061.  
  1062. procedure TDBLocate.ChangeBookmark;
  1063. begin
  1064.   if Bookmark <> nil then DataSet.FreeBookmark(Bookmark);
  1065.   Bookmark := DataSet.GetBookmark;
  1066. end;
  1067.  
  1068. procedure TDBLocate.ActiveChanged;
  1069. begin
  1070.   DropFilter;
  1071. end;
  1072.  
  1073. {$ENDIF WIN32}
  1074.  
  1075. { DataSet locate routines }
  1076.  
  1077. function IsFilterApplicable(DataSet: TDataSet): Boolean;
  1078. var
  1079.   Status: DBIResult;
  1080.   Filter: hDBIFilter;
  1081. begin
  1082.   if DataSet is TBDEDataSet then begin
  1083.     Status := DbiAddFilter(TBDEDataSet(DataSet).Handle, 0, 0, False, nil,
  1084.       nil, Filter);
  1085.     Result := (Status = DBIERR_NONE) or (Status = DBIERR_INVALIDFILTER);
  1086.     if Result then DbiDropFilter(TBDEDataSet(DataSet).Handle, Filter);
  1087.   end
  1088.   else Result := True;
  1089. end;
  1090.  
  1091. function DataSetFindValue(ADataSet: TBDEDataSet; const Value,
  1092.   FieldName: string): Boolean;
  1093. begin
  1094.   with TDBLocate.Create do
  1095.   try
  1096.     DataSet := ADataSet;
  1097.     if ADataSet is TDBDataSet then
  1098.       IndexSwitch := not TDBDataSet(DataSet).Database.IsSQLBased;
  1099.     Result := Locate(FieldName, Value, True, False);
  1100.   finally
  1101.     Free;
  1102.   end;
  1103. end;
  1104.  
  1105. function DataSetFindLike(ADataSet: TBDEDataSet; const Value,
  1106.   FieldName: string): Boolean;
  1107. begin
  1108.   with TDBLocate.Create do
  1109.   try
  1110.     DataSet := ADataSet;
  1111.     if ADataSet is TDBDataSet then
  1112.       IndexSwitch := not TDBDataSet(DataSet).Database.IsSQLBased;
  1113.     Result := Locate(FieldName, Value, False, False);
  1114.   finally
  1115.     Free;
  1116.   end;
  1117. end;
  1118.  
  1119. const
  1120.   SaveIndexFieldNames: TStrings = nil;
  1121.  
  1122. procedure UsesSaveIndexies;
  1123. begin
  1124.   if SaveIndexFieldNames = nil then
  1125.     SaveIndexFieldNames := TStringList.Create;
  1126. end;
  1127.  
  1128. procedure ReleaseSaveIndexies; far;
  1129. begin
  1130.   if SaveIndexFieldNames <> nil then begin
  1131.     SaveIndexFieldNames.Free;
  1132.     SaveIndexFieldNames := nil;
  1133.   end;
  1134. end;
  1135.  
  1136. procedure SetIndex(Table: TTable; const IndexFieldNames: string);
  1137. var
  1138.   IndexToSave: string;
  1139. begin
  1140.   IndexToSave := Table.IndexFieldNames;
  1141.   Table.IndexFieldNames := IndexFieldNames;
  1142.   UsesSaveIndexies;
  1143.   SaveIndexFieldNames.AddObject(IndexToSave, Table.MasterSource);
  1144. end;
  1145.  
  1146. procedure RestoreIndex(Table: TTable);
  1147. begin
  1148.   if (SaveIndexFieldNames <> nil) and (SaveIndexFieldNames.Count > 0) then
  1149.   begin
  1150.     try
  1151.       Table.IndexFieldNames :=
  1152.         SaveIndexFieldNames[SaveIndexFieldNames.Count - 1];
  1153.       Table.MasterSource :=
  1154.         TDataSource(SaveIndexFieldNames.Objects[SaveIndexFieldNames.Count - 1]);
  1155.     finally
  1156.       SaveIndexFieldNames.Delete(SaveIndexFieldNames.Count - 1);
  1157.       if SaveIndexFieldNames.Count = 0 then
  1158.         ReleaseSaveIndexies;
  1159.     end;
  1160.   end;
  1161. end;
  1162.  
  1163. procedure DeleteRange(Table: TTable; IndexFields: array of const;
  1164.   FieldValues: array of const);
  1165. var
  1166.   I: Integer;
  1167.   NewIndex: string;
  1168. begin
  1169.   NewIndex := '';
  1170.   for I := Low(IndexFields) to High(IndexFields) do begin
  1171.     NewIndex := NewIndex + TVarRec(IndexFields[I]).VString^;
  1172.     if I <> High(IndexFields) then
  1173.       NewIndex := NewIndex + ';';
  1174.   end;
  1175.   SetIndex(Table, NewIndex);
  1176.   try
  1177.     Table.SetRange(FieldValues, FieldValues);
  1178.     try
  1179.       while not Table.EOF do Table.Delete;
  1180.     finally
  1181.       Table.CancelRange;
  1182.     end;
  1183.   finally
  1184.     RestoreIndex(Table);
  1185.   end;
  1186. end;
  1187.  
  1188. procedure ReindexTable(Table: TTable);
  1189. var
  1190.   WasActive: Boolean;
  1191.   WasExclusive: Boolean;
  1192. begin
  1193.   with Table do begin
  1194.     WasActive := Active;
  1195.     WasExclusive := Exclusive;
  1196.     DisableControls;
  1197.     try
  1198.       if not (WasActive and WasExclusive) then Close;
  1199.       try
  1200.         Exclusive := True;
  1201.         Open;
  1202.         Check(dbiRegenIndexes(Handle));
  1203.       finally
  1204.         if not (WasActive and WasExclusive) then begin
  1205.           Close;
  1206.           Exclusive := WasExclusive;
  1207.           Active := WasActive;
  1208.         end;
  1209.       end;
  1210.     finally
  1211.       EnableControls;
  1212.     end;
  1213.   end;
  1214. end;
  1215.  
  1216. procedure PackTable(Table: TTable);
  1217. { This routine copied and modified from demo unit TableEnh.pas
  1218.   from Borland Int. }
  1219. var
  1220.   { FCurProp holds information about the structure of the table }
  1221.   FCurProp: CurProps;
  1222.   { Specific information about the table structure, indexes, etc. }
  1223.   TblDesc: CRTblDesc;
  1224.   { Uses as a handle to the database }
  1225.   hDb: hDbiDB;
  1226.   { Path to the currently opened table }
  1227.   TablePath: array[0..dbiMaxPathLen] of Char;
  1228.   Exclusive: Boolean;
  1229. begin
  1230.   if not Table.Active then _DBError(SDataSetClosed);
  1231.   Check(DbiGetCursorProps(Table.Handle, FCurProp));
  1232.   if StrComp(FCurProp.szTableType, szParadox) = 0 then begin
  1233.     { Call DbiDoRestructure procedure if PARADOX table }
  1234.     hDb := nil;
  1235.     { Initialize the table descriptor }
  1236.     FillChar(TblDesc, SizeOf(CRTblDesc), 0);
  1237.     with TblDesc do begin
  1238.       { Place the table name in descriptor }
  1239.       StrPCopy(szTblName, Table.TableName);
  1240.       { Place the table type in descriptor }
  1241.       StrCopy(szTblType, FCurProp.szTableType);
  1242.       bPack := True;
  1243.       bProtected := FCurProp.bProtected;
  1244.     end;
  1245.     { Get the current table's directory. This is why the table MUST be
  1246.       opened until now }
  1247.     Check(DbiGetDirectory(Table.DBHandle, False, TablePath));
  1248.     { Close the table }
  1249.     Table.Close;
  1250.     try
  1251.       { NOW: since the DbiDoRestructure call needs a valid DB handle BUT the
  1252.         table cannot be opened, call DbiOpenDatabase to get a valid handle.
  1253.         Setting TTable.Active = False does not give you a valid handle }
  1254.       Check(DbiOpenDatabase(nil, szCFGDBSTANDARD, dbiReadWrite, dbiOpenExcl, nil,
  1255.         0, nil, nil, hDb));
  1256.       { Set the table's directory to the old directory }
  1257.       Check(DbiSetDirectory(hDb, TablePath));
  1258.       { Pack the PARADOX table }
  1259.       Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False));
  1260.       { Close the temporary database handle }
  1261.       Check(DbiCloseDatabase(hDb));
  1262.     finally
  1263.       { Re-Open the table }
  1264.       Table.Open;
  1265.     end;
  1266.   end
  1267.   else if StrComp(FCurProp.szTableType, szDBase) = 0 then begin
  1268.     { Call DbiPackTable procedure if dBase table }
  1269.     Exclusive := Table.Exclusive;
  1270.     Table.Close;
  1271.     try
  1272.       Table.Exclusive := True;
  1273.       Table.Open;
  1274.       try
  1275.         Check(DbiPackTable(Table.DBHandle, Table.Handle, nil, nil, True));
  1276.       finally
  1277.         Table.Close;
  1278.       end;
  1279.     finally
  1280.       Table.Exclusive := Exclusive;
  1281.       Table.Open;
  1282.     end;
  1283.   end
  1284.   else DbiError(DBIERR_WRONGDRVTYPE);
  1285. end;
  1286.  
  1287. procedure FetchAllRecords(DataSet: TBDEDataSet);
  1288. begin
  1289.   with DataSet do
  1290.     if not EOF then begin
  1291.       CheckBrowseMode;
  1292.       Check(DbiSetToEnd(Handle));
  1293.       Check(DbiGetPriorRecord(Handle, dbiNoLock, nil, nil));
  1294.       CursorPosChanged;
  1295.       UpdateCursorPos;
  1296.     end;
  1297. end;
  1298.  
  1299. procedure BdeFlushBuffers;
  1300. var
  1301.   I, L: Integer;
  1302. {$IFDEF WIN32}
  1303.   Session: TSession;
  1304.   J: Integer;
  1305. {$ENDIF}
  1306. begin
  1307. {$IFDEF WIN32}
  1308.   for J := 0 to Sessions.Count - 1 do begin
  1309.     Session := Sessions[J];
  1310.     if not Session.Active then Continue;
  1311. {$ENDIF}
  1312.     for I := 0 to Session.DatabaseCount - 1 do begin
  1313.       with Session.Databases[I] do
  1314.         if Connected and not IsSQLBased then begin
  1315.           for L := 0 to DataSetCount - 1 do begin
  1316.             if DataSets[L].Active then
  1317.               DbiSaveChanges(DataSets[L].Handle);
  1318.           end;
  1319.         end;
  1320.     end;
  1321. {$IFDEF WIN32}
  1322.   end;
  1323. {$ENDIF}
  1324. end;
  1325.  
  1326. {$IFNDEF WIN32}
  1327. type
  1328.   TDbiGetExactRecordCount = function (hCursor: hDBICur;
  1329.     var iRecCount: Longint): DbiResult;
  1330.  
  1331. const
  1332.   DbiGetExactRecCnt: TDbiGetExactRecordCount = nil;
  1333.  
  1334. function DbiGetExactRecordCount(hCursor: hDBICur;
  1335.   var iRecCount: Longint): DbiResult;
  1336. var
  1337.   HModule: THandle;
  1338.   ErrMode: Cardinal;
  1339. begin
  1340.   if not Assigned(DbiGetExactRecCnt) then begin
  1341.     ErrMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
  1342.     HModule := LoadLibrary('IDAPI01.DLL');
  1343.     SetErrorMode(ErrMode);
  1344.     if HModule >= HINSTANCE_ERROR then begin
  1345.       @DbiGetExactRecCnt := GetProcAddress(HModule, 'DBIGETEXACTRECORDCOUNT');
  1346.       FreeLibrary(HModule);
  1347.     end;
  1348.   end;
  1349.   if Assigned(DbiGetExactRecCnt) then
  1350.     Result := DbiGetExactRecCnt(hCursor, iRecCount)
  1351.   else Result := DbiGetRecordCount(hCursor, iRecCount);
  1352. end;
  1353. {$ENDIF}
  1354.  
  1355. function DataSetRecordCount(DataSet: TDataSet): Longint;
  1356. var
  1357.   IsCount: Boolean;
  1358. begin
  1359. {$IFDEF RX_D3}
  1360.   if DataSet is TBDEDataSet then begin
  1361. {$ENDIF}
  1362.     IsCount := (DbiGetExactRecordCount(TBDEDataSet(DataSet).Handle,
  1363.       Result) = DBIERR_NONE) or (DbiGetRecordCount(TBDEDataSet(DataSet).Handle,
  1364.       Result) = DBIERR_NONE);
  1365. {$IFDEF RX_D3}
  1366.   end
  1367.   else
  1368.     try
  1369.       Result := DataSet.RecordCount;
  1370.       IsCount := True;
  1371.     except
  1372.       IsCount := False;
  1373.     end;
  1374. {$ENDIF}
  1375.   if not IsCount then Result := -1;
  1376. end;
  1377.  
  1378. function DataSetRecNo(DataSet: TDataSet): Longint;
  1379. var
  1380.   FCurProp: CURProps;
  1381.   FRecProp: RECProps;
  1382. begin
  1383.   Result := -1;
  1384.   if (DataSet <> nil) and DataSet.Active and (DataSet.State in [dsBrowse,
  1385.     dsEdit]) then
  1386.   begin
  1387. {$IFDEF RX_D3}
  1388.     if not (DataSet is TBDEDataSet) then begin
  1389.       Result := DataSet.RecNo;
  1390.       Exit;
  1391.     end;
  1392. {$ENDIF}
  1393.     if DbiGetCursorProps(TBDEDataSet(DataSet).Handle, FCurProp) <> DBIERR_NONE then
  1394.       Exit;
  1395.     if (StrComp(FCurProp.szTableType, szParadox) = 0) or
  1396.       (FCurProp.iSeqNums = 1) then
  1397.     begin
  1398.       DataSet.GetCurrentRecord(nil);
  1399.       if DbiGetSeqNo(TBDEDataSet(DataSet).Handle, Result) <> DBIERR_NONE then
  1400.         Result := -1;
  1401.     end
  1402.     else if StrComp(FCurProp.szTableType, szDBase) = 0 then begin
  1403.       DataSet.GetCurrentRecord(nil);
  1404.       if DbiGetRecord(TBDEDataSet(DataSet).Handle, dbiNOLOCK, nil, @FRecProp) = DBIERR_NONE
  1405.         then Result := FRecProp.iPhyRecNum;
  1406.     end;
  1407.   end;
  1408. end;
  1409.  
  1410. function DataSetPositionStr(DataSet: TDataSet): string;
  1411. var
  1412.   RecNo, RecCount: Longint;
  1413. begin
  1414.   try
  1415.     RecNo := DataSetRecNo(DataSet);
  1416.   except
  1417.     RecNo := -1;
  1418.   end;
  1419.   if RecNo >= 0 then begin
  1420.     RecCount := DataSetRecordCount(DataSet);
  1421.     if RecCount >= 0 then Result := Format('%d:%d', [RecNo, RecCount])
  1422.     else Result := IntToStr(RecNo);
  1423.   end
  1424.   else Result := '';
  1425. end;
  1426.  
  1427. function TransActive(Database: TDatabase): Boolean;
  1428. var
  1429.   Info: XInfo;
  1430. {$IFDEF WIN32}
  1431.   S: hDBISes;
  1432. {$ENDIF}
  1433. begin
  1434. {$IFDEF WIN32}
  1435.   Result := False;
  1436.   if DbiGetCurrSession(S) <> DBIERR_NONE then Exit;
  1437. {$ENDIF}
  1438.   Result := (Database.Handle <> nil) and
  1439.     (DbiGetTranInfo(Database.Handle, nil, @Info) = DBIERR_NONE) and
  1440.     (Info.exState = xsActive);
  1441. {$IFDEF WIN32}
  1442.   DbiSetCurrSession(S);
  1443. {$ENDIF}
  1444. end;
  1445.  
  1446. function GetBdeDirectory: string;
  1447. const
  1448.   Ident = 'DLLPATH';
  1449. var
  1450. {$IFDEF WIN32}
  1451.   Ini: TRegistry;
  1452. const
  1453.   BdeKey = 'SOFTWARE\Borland\Database Engine';
  1454. {$ELSE}
  1455.   Ini: TIniFile;
  1456. {$ENDIF}
  1457. begin
  1458.   Result := '';
  1459. {$IFDEF WIN32}
  1460.   Ini := TRegistry.Create;
  1461.   try
  1462.     Ini.RootKey := HKEY_LOCAL_MACHINE;
  1463.     if Ini.OpenKey(BdeKey, False) then
  1464.       if Ini.ValueExists(Ident) then Result := Ini.ReadString(Ident);
  1465. {$ELSE}
  1466.   Ini := TIniFile.Create('WIN.INI');
  1467.   try
  1468.     Result := Ini.ReadString('IDAPI', Ident, '');
  1469. {$ENDIF}
  1470.   { Check for multiple directories, use only the first one }
  1471.   if Pos(';', Result) > 0 then Delete(Result, Pos(';', Result), MaxInt);
  1472.   if (Length(Result) > 2) and (Result[Length(Result)] <> '\') then
  1473.     Result := Result + '\';
  1474.   finally
  1475.     Ini.Free;
  1476.   end;
  1477. end;
  1478.  
  1479. procedure ExportDataSetEx(Source: TBDEDataSet; DestTable: TTable;
  1480.   TableType: TTableType; const AsciiCharSet: string;
  1481.   AsciiDelimited: Boolean; AsciiDelimiter, AsciiSeparator: Char;
  1482.   MaxRecordCount: Longint);
  1483.  
  1484.   function ExportAsciiField(Field: TField): Boolean;
  1485.   begin
  1486.     Result := Field.Visible and not (Field.Calculated
  1487.       {$IFDEF WIN32} or Field.Lookup {$ENDIF}) and not (Field.DataType in
  1488.       ftNonTextTypes + [ftUnknown]);
  1489.   end;
  1490.  
  1491. const
  1492.   TextExt = '.TXT';
  1493.   SchemaExt = '.SCH';
  1494. var
  1495.   I: Integer;
  1496.   S, Path: string;
  1497.   BatchMove: TBatchMove;
  1498.   TablePath: array[0..dbiMaxPathLen] of Char;
  1499. begin
  1500.   if Source = nil then _DBError(SDataSetEmpty);
  1501.   if DestTable.Active then DestTable.Close;
  1502. {$IFDEF WIN32}
  1503.   if Source is TDBDataSet then
  1504.     DestTable.SessionName := TDBDataSet(Source).SessionName;
  1505. {$ENDIF}
  1506.   if (TableType = ttDefault) then begin
  1507.     if DestTable.TableType <> ttDefault then
  1508.       TableType := DestTable.TableType
  1509.     else if (CompareText(ExtractFileExt(DestTable.TableName), TextExt) = 0) then
  1510.       TableType := ttASCII;
  1511.   end;
  1512.   BatchMove := TBatchMove.Create(Application);
  1513.   try
  1514.     StartWait;
  1515.     try
  1516.       BatchMove.Mode := batCopy;
  1517.       BatchMove.Source := Source;
  1518.       BatchMove.Destination := DestTable;
  1519.       DestTable.TableType := TableType;
  1520.       BatchMove.Mappings.Clear;
  1521.       if (DestTable.TableType = ttASCII) then begin
  1522.         if CompareText(ExtractFileExt(DestTable.TableName), SchemaExt) = 0 then
  1523.           DestTable.TableName := ChangeFileExt(DestTable.TableName, TextExt);
  1524.         with Source do
  1525.           for I := 0 to FieldCount - 1 do begin
  1526.             if ExportAsciiField(Fields[I]) then
  1527.               BatchMove.Mappings.Add(Format('%s=%0:s',
  1528.                 [Fields[I].FieldName]));
  1529.           end;
  1530.         BatchMove.RecordCount := 1;
  1531.       end
  1532.       else BatchMove.RecordCount := MaxRecordCount;
  1533.       BatchMove.Execute;
  1534.       if (DestTable.TableType = ttASCII) then begin
  1535.         { ASCII table always created in "fixed" format with "ascii"
  1536.           character set }
  1537.         with BatchMove do begin
  1538.           Mode := batAppend;
  1539.           RecordCount := MaxRecordCount;
  1540.         end;
  1541.         S := ChangeFileExt(ExtractFileName(DestTable.TableName), '');
  1542.         Path := NormalDir(ExtractFilePath(DestTable.TableName));
  1543.         if Path = '' then begin
  1544.           DestTable.Open;
  1545.           try
  1546.             Check(DbiGetDirectory(DestTable.DBHandle, False, TablePath));
  1547.             Path := NormalDir(OemToAnsiStr(StrPas(TablePath)));
  1548.           finally
  1549.             DestTable.Close;
  1550.           end;
  1551.         end;
  1552.         with TIniFile.Create(ChangeFileExt(Path + S, SchemaExt)) do
  1553.         try
  1554.           if AsciiCharSet <> '' then
  1555.             WriteString(S, 'CharSet', AsciiCharSet)
  1556.           else WriteString(S, 'CharSet', 'ascii');
  1557.           if AsciiDelimited then begin { change ASCII-file format to CSV }
  1558.             WriteString(S, 'Filetype', 'VARYING');
  1559.             WriteString(S, 'Delimiter', AsciiDelimiter);
  1560.             WriteString(S, 'Separator', AsciiSeparator);
  1561.           end;
  1562.         finally
  1563.           Free;
  1564.         end;
  1565.         { clear previous output - overwrite existing file }
  1566.         S := Path + ExtractFileName(DestTable.TableName);
  1567.         if Length(ExtractFileExt(S)) < 2 then
  1568.           S := ChangeFileExt(S, TextExt);
  1569.         I := FileCreate(S);
  1570.         if I < 0 then
  1571.           raise EFCreateError.CreateFmt(ResStr(SFCreateError), [S]);
  1572.         FileClose(I);
  1573.         BatchMove.Execute;
  1574.       end;
  1575.     finally
  1576.       StopWait;
  1577.     end;
  1578.   finally
  1579.     BatchMove.Free;
  1580.   end;
  1581. end;
  1582.  
  1583. procedure ExportDataSet(Source: TBDEDataSet; DestTable: TTable;
  1584.   TableType: TTableType; const AsciiCharSet: string;
  1585.   AsciiDelimited: Boolean; MaxRecordCount: Longint);
  1586. begin
  1587.   ExportDataSetEx(Source, DestTable, TableType, AsciiCharSet,
  1588.     AsciiDelimited, '"', ',', MaxRecordCount);
  1589. end;
  1590.  
  1591. procedure ImportDataSet(Source: TBDEDataSet; DestTable: TTable;
  1592.   MaxRecordCount: Longint; Mappings: TStrings; Mode: TBatchMode);
  1593. var
  1594.   BatchMove: TBatchMove;
  1595. begin
  1596.   if Source = nil then _DBError(SDataSetEmpty);
  1597. {$IFDEF WIN32}
  1598.   if (Source is TDBDataSet) and not Source.Active then
  1599.     TDBDataSet(Source).SessionName := DestTable.SessionName;
  1600. {$ENDIF}
  1601.   BatchMove := TBatchMove.Create(Application);
  1602.   try
  1603.     StartWait;
  1604.     try
  1605.       BatchMove.Mode := Mode;
  1606.       BatchMove.Source := Source;
  1607.       BatchMove.Destination := DestTable;
  1608.       if Mappings.Count > 0 then
  1609.         BatchMove.Mappings.AddStrings(Mappings);
  1610.       BatchMove.RecordCount := MaxRecordCount;
  1611.       BatchMove.Execute;
  1612.     finally
  1613.       StopWait;
  1614.     end;
  1615.   finally
  1616.     BatchMove.Free;
  1617.   end;
  1618. end;
  1619.  
  1620. function GetNativeHandle(Database: TDatabase; Buffer: Pointer;
  1621.   BufSize: Integer): Pointer;
  1622. var
  1623.   Len: Word;
  1624. begin
  1625.   Result := nil;
  1626.   if Assigned(Database) and Database.Connected then begin
  1627.     if Database.IsSQLBased then begin
  1628.       Check(DbiGetProp(HDBIOBJ(Database.Handle), dbNATIVEHNDL,
  1629.         Buffer, BufSize, Len));
  1630.       Result := Buffer;
  1631.     end
  1632.     else DBError(SLocalDatabase);
  1633.   end
  1634.   else _DBError(SDatabaseClosed);
  1635. end;
  1636.  
  1637. procedure BdeTranslate(Locale: TLocale; Source, Dest: PChar; ToOem: Boolean);
  1638. var
  1639.   Len: Cardinal;
  1640. begin
  1641.   Len := StrLen(Source);
  1642.   if ToOem then AnsiToNativeBuf(Locale, Source, Dest, Len)
  1643.   else NativeToAnsiBuf(Locale, Source, Dest, Len);
  1644.   if Source <> Dest then Dest[Len] := #0;
  1645. end;
  1646.  
  1647. function TrimMessage(Msg: PChar): PChar;
  1648. var
  1649.   Blank: Boolean;
  1650.   Source, Dest: PChar;
  1651. begin
  1652.   Source := Msg;
  1653.   Dest := Msg;
  1654.   Blank := False;
  1655.   while Source^ <> #0 do begin
  1656.     if Source^ <= ' ' then Blank := True
  1657.     else begin
  1658.       if Blank then begin
  1659.         Dest^ := ' ';
  1660.         Inc(Dest);
  1661.         Blank := False;
  1662.       end;
  1663.       Dest^ := Source^;
  1664.       Inc(Dest);
  1665.     end;
  1666.     Inc(Source);
  1667.   end;
  1668.   if (Dest > Msg) and ((Dest - 1)^ = '.') then Dec(Dest);
  1669.   Dest^ := #0;
  1670.   Result := Msg;
  1671. end;
  1672.  
  1673. function BdeErrorMsg(ErrorCode: DBIResult): string;
  1674. var
  1675.   I: Integer;
  1676.   NativeError: Longint;
  1677.   Msg, LastMsg: DBIMSG;
  1678. begin
  1679.   I := 1;
  1680.   DbiGetErrorString(ErrorCode, Msg);
  1681.   TrimMessage(Msg);
  1682.   if Msg[0] = #0 then Result := Format(ResStr(SBDEError), [ErrorCode])
  1683.   else Result := StrPas(Msg);
  1684.   while True do begin
  1685.     StrCopy(LastMsg, Msg);
  1686.     ErrorCode := DbiGetErrorEntry(I, NativeError, Msg);
  1687.     if (ErrorCode = DBIERR_NONE) or
  1688.       (ErrorCode = DBIERR_NOTINITIALIZED) then Break;
  1689.     TrimMessage(Msg);
  1690.     if (Msg[0] <> #0) and (StrComp(Msg, LastMsg) <> 0) then
  1691.       Result := Format('%s. %s', [Result, Msg]);
  1692.     Inc(I);
  1693.   end;
  1694.   for I := 1 to Length(Result) do
  1695.     if Result[I] < ' ' then Result[I] := ' ';
  1696. end;
  1697.  
  1698. procedure DataSetShowDeleted(DataSet: TBDEDataSet; Show: Boolean);
  1699. begin
  1700.   with DataSet do begin
  1701.     CheckBrowseMode;
  1702.     Check(DbiValidateProp(hDBIObj(Handle), curSOFTDELETEON, True));
  1703.     DisableControls;
  1704.     try
  1705.       Check(DbiSetProp(hDBIObj(Handle), curSOFTDELETEON, Ord(Show)));
  1706.     finally
  1707.       EnableControls;
  1708.     end;
  1709.     if DataSet is TTable then TTable(DataSet).Refresh
  1710.     else begin
  1711.       CursorPosChanged;
  1712.       First;
  1713.     end;
  1714.   end;
  1715. end;
  1716.  
  1717. function CurrentRecordDeleted(DataSet: TBDEDataSet): Boolean;
  1718. var
  1719.   FRecProp: RECProps;
  1720. begin
  1721.   Result := False;
  1722.   if (DataSet <> nil) and DataSet.Active then begin
  1723.     DataSet.GetCurrentRecord(nil);
  1724.     if DbiGetRecord(DataSet.Handle, dbiNOLOCK, nil, @FRecProp) = DBIERR_NONE
  1725.       then Result := FRecProp.bDeleteFlag;
  1726.   end;
  1727. end;
  1728.  
  1729. procedure DbNotSupported;
  1730. begin
  1731.   DbiError(DBIERR_NOTSUPPORTED);
  1732. end;
  1733.  
  1734. procedure ToggleDebugLayer(Active: Boolean; const DebugFile: string);
  1735. const
  1736.   Options: array[Boolean] of Longint = (0, DEBUGON or OUTPUTTOFILE or
  1737.     APPENDTOLOG);
  1738. var
  1739.   FileName: DBIPATH;
  1740. begin
  1741.   Check(DbiDebugLayerOptions(Options[Active], StrPLCopy(FileName,
  1742.     DebugFile, SizeOf(DBIPATH) - 1)));
  1743. end;
  1744.  
  1745. initialization
  1746.   DbUtils.CreateLocateObject := CreateDbLocate;
  1747. {$IFDEF WIN32}
  1748. finalization
  1749.   ReleaseSaveIndexies;
  1750. {$ELSE}
  1751.   AddExitProc(ReleaseSaveIndexies);
  1752. {$ENDIF}
  1753. end.