
{*******************************************************}
{                                                       }
{       Delphi Visual Component Library                 }
{                                                       }
{       Copyright (c) 1995 Borland International        }
{                                                       }
{*******************************************************}

unit DB;

{$N+,P+,S-}

interface

uses SysUtils, WinTypes, WinProcs, DbiTypes, DbiProcs, DbiErrs, Classes;

const

{ TDataSet maximum number of record buffers }

  dsMaxBufferCount = 1024;

{ TDBDataSet flags }

  dbfOpened     = 0;
  dbfPrepared   = 1;
  dbfExecSQL    = 2;
  dbfTable      = 3;
  dbfFieldList  = 4;
  dbfIndexList  = 5;
  dbfStoredProc = 6;
  dbfExecProc   = 7;

type

{ Forward declarations }

  TDBError = class;
  TSession = class;
  TDatabase = class;
  TFieldDefs = class;
  TDataset = class;
  TDBDataset = class;
  TField = class;
  TDataSource = class;
  TDataLink = class;

{ Generic types }

  TSymbolStr = string[DBIMAXNAMELEN];
  TMessageStr = string[DBIMAXMSGLEN];

  PFieldDescList = ^TFieldDescList;
  TFieldDescList = array[0..1023] of FLDDesc;

  PIndexDescList = ^TIndexDescList;
  TIndexDescList = array[0..63] of IDXDesc;

{ Exception classes }

  EDatabaseError = class(Exception);

  EDBEngineError = class(EDatabaseError)
  private
    FErrors: TList;
    function GetError(Index: Integer): TDBError;
    function GetErrorCount: Integer;
  public
    constructor Create(ErrorCode: DBIResult);
    destructor Destroy; override;
    property ErrorCount: Integer read GetErrorCount;
    property Errors[Index: Integer]: TDBError read GetError;
  end;

{ BDE error information type }

  TDBError = class
  private
    FErrorCode: DBIResult;
    FNativeError: Longint;
    FMessage: TMessageStr;
    function GetCategory: Byte;
    function GetSubCode: Byte;
  public
    constructor Create(Owner: EDBEngineError; ErrorCode: DBIResult;
      NativeError: Longint; Message: PChar);
    property Category: Byte read GetCategory;
    property ErrorCode: DBIResult read FErrorCode;
    property SubCode: Byte read GetSubCode;
    property Message: TMessageStr read FMessage;
    property NativeError: Longint read FNativeError;
  end;

{ TLocale }

  TLocale = Pointer;

{ TSession }

  TPasswordEvent = procedure(Sender: TObject; var Continue: Boolean);

  TCallBack = record
    Data: Longint;
    BufLen: Word;
    Buffer: Pointer;
    ChainedFunc: Pointer;
  end;

  TSession = class(TComponent)
  private
    FDatabases: TList;
    FLocale: TLocale;
    FKeepConnections: Boolean;
    FDoExit: Boolean;
    FServerData: Pointer;
    FOldCallBack: TCallBack;
    FOnPassword: TPasswordEvent;
    procedure GetConfigParams(Path, Section: PChar; List: TStrings);
    function GetDatabase(Index: Integer): TDatabase;
    function GetDatabaseCount: Integer;
    function GetHandle: HDBISES;
    function GetNetFileDir: string;
    function GetPrivateDir: string;
    procedure SetNetFileDir(const Value: string);
    procedure SetPrivateDir(const Value: string);
  public
    constructor Create(AOwner: TComponent);
    destructor Destroy; override;
    procedure AddPassword(const Password: string);
    procedure CloseDatabase(Database: TDatabase);
    procedure DropConnections;
    function FindDatabase(const DatabaseName: string): TDatabase;
    procedure GetAliasNames(List: TStrings);
    procedure GetAliasParams(const AliasName: string; List: TStrings);
    procedure GetDatabaseNames(List: TStrings);
    procedure GetDriverNames(List: TStrings);
    procedure GetDriverParams(const DriverName: string; List: TStrings);
    function GetPassword: Boolean;
    procedure GetTableNames(const DatabaseName, Pattern: string;
      Extensions, SystemTables: Boolean; List: TStrings);
    procedure GetStoredProcNames(const DatabaseName: string; List: TStrings);
    function OpenDatabase(const DatabaseName: string): TDatabase;
    procedure RemoveAllPasswords;
    procedure RemovePassword(const Password: string);
    property DatabaseCount: Integer read GetDatabaseCount;
    property Databases[Index: Integer]: TDatabase read GetDatabase;
    property Handle: HDBISES read GetHandle;
    property KeepConnections: Boolean read FKeepConnections write FKeepConnections default True;
    property Locale: TLocale read FLocale;
    property NetFileDir: string read GetNetFileDir write SetNetFileDir;
    property PrivateDir: string read GetPrivateDir write SetPrivateDir;
    property OnPassword: TPasswordEvent read FOnPassword write FOnPassword;
  end;

{ TParamList }

  TParamList = class(TObject)
  private
    FFieldCount: Integer;
    FBufSize: Word;
    FFieldDescs: PFieldDescList;
    FBuffer: PChar;
  public
    constructor Create(Params: TStrings);
    destructor Destroy; override;
    property Buffer: PChar read FBuffer;
    property FieldCount: Integer read FFieldCount;
    property FieldDescs: PFieldDescList read FFieldDescs;
  end;

{ TDatabase }

  TTransIsolation = (tiDirtyRead, tiReadCommitted, tiRepeatableRead);

  TLoginEvent = procedure(Database: TDatabase;
    LoginParams: TStrings) of object;

  TDatabase = class(TComponent)
  private
    FDatasets: TList;
    FTransIsolation: TTransIsolation;
    FLoginPrompt: Boolean;
    FKeepConnection: Boolean;
    FTemporary: Boolean;
    FStreamedConnected: Boolean;
    FLocaleLoaded: Boolean;
    FAliased: Boolean;
    FReserved: Byte;
    FRefCount: Integer;
    FHandle: HDBIDB;
    FTransHandle: HDBIXAct;
    FLocale: TLocale;
    FParams: TStrings;
    FDatabaseName: TFileName;
    FDatabaseType: TSymbolStr;
    FOnLogin: TLoginEvent;
    procedure CheckActive;
    procedure CheckInactive;
    procedure EndTransaction(TransEnd: EXEnd);
    function GetAliasName: TSymbolStr;
    function GetConnected: Boolean;
    function GetDataset(Index: Integer): TDBDataset;
    function GetDatasetCount: Integer;
    function GetDriverName: TSymbolStr;
    function GetIsSQLBased: Boolean;
    procedure Login(LoginParams: TStrings);
    procedure ParamsChanging(Sender: TObject);
    procedure SetAliasName(const Value: TSymbolStr);
    procedure SetConnected(Value: Boolean);
    procedure SetDatabaseName(const Value: TFileName);
    procedure SetDatabaseType(const Value: TSymbolStr; Aliased: Boolean);
    procedure SetDriverName(const Value: TSymbolStr);
    procedure SetKeepConnection(Value: Boolean);
    procedure SetParams(Value: TStrings);
  protected
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Close;
    procedure CloseDatasets;
    procedure Commit;
    procedure Open;
    procedure Rollback;
    procedure StartTransaction;
    procedure ValidateName(const Name: string);
    property DatasetCount: Integer read GetDatasetCount;
    property Datasets[Index: Integer]: TDBDataset read GetDataset;
    property Handle: HDBIDB read FHandle;
    property IsSQLBased: Boolean read GetIsSQLBased;
    property Locale: TLocale read FLocale;
    property Temporary: Boolean read FTemporary write FTemporary;
  published
    property AliasName: TSymbolStr read GetAliasName write SetAliasName;
    property Connected: Boolean read GetConnected write SetConnected default False;
    property DatabaseName: TFileName read FDatabaseName write SetDatabaseName;
    property DriverName: TSymbolStr read GetDriverName write SetDriverName;
    property KeepConnection: Boolean read FKeepConnection write SetKeepConnection default True;
    property LoginPrompt: Boolean read FLoginPrompt write FLoginPrompt default True;
    property Params: TStrings read FParams write SetParams;
    property TransIsolation: TTransIsolation read FTransIsolation write FTransIsolation default tiReadCommitted;
    property OnLogin: TLoginEvent read FOnLogin write FOnLogin;
  end;

{ TDataSetDesigner }

  TDataEvent = (deFieldChange, deRecordChange, deDataSetChange,
    deDataSetScroll, deLayoutChange, deUpdateRecord, deUpdateState,
    deCheckBrowseMode, dePropertyChange, deFieldListChange,
    deFocusControl);

  TDataSetDesigner = class(TObject)
  private
    FDataSet: TDataSet;
    FSaveActive: Boolean;
    FReserved: Byte;
  public
    constructor Create(DataSet: TDataSet);
    destructor Destroy; override;
    procedure BeginDesign;
    procedure DataEvent(Event: TDataEvent; Info: Longint); virtual;
    procedure EndDesign;
    property DataSet: TDataSet read FDataSet;
  end;

{ TFieldDef }

  TFieldClass = class of TField;

  TFieldType = (ftUnknown, ftString, ftSmallint, ftInteger, ftWord,
    ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime,
    ftBytes, ftVarBytes, ftBlob, ftMemo, ftGraphic);

  TFieldDef = class
  private
    FOwner: TFieldDefs;
    FName: PString;
    FDataType: TFieldType;
    FRequired: Boolean;
    FSize: Word;
    FFieldNo: Integer;
    function GetFieldClass: TFieldClass;
    function GetName: string;
  public
    constructor Create(Owner: TFieldDefs; const Name: string;
      DataType: TFieldType; Size: Word; Required: Boolean; FieldNo: Integer);
    destructor Destroy; override;
    function CreateField(Owner: TComponent): TField;
    property DataType: TFieldType read FDataType;
    property FieldClass: TFieldClass read GetFieldClass;
    property FieldNo: Integer read FFieldNo;
    property Name: string read GetName;
    property Required: Boolean read FRequired;
    property Size: Word read FSize;
  end;

{ TFieldDefs }

  TFieldDefs = class
  private
    FDataSet: TDataSet;
    FItems: TList;
    FUpdated: Boolean;
    FReserved: Byte;
    function GetCount: Integer;
    function GetItem(Index: Integer): TFieldDef;
  public
    constructor Create(DataSet: TDataSet);
    destructor Destroy; override;
    procedure Add(const Name: string; DataType: TFieldType; Size: Word;
      Required: Boolean);
    procedure AddFieldDesc(FieldDesc: FLDDesc; Required: Boolean;
      FieldNo: Word);
    procedure Assign(FieldDefs: TFieldDefs);
    procedure Clear;
    function Find(const Name: string): TFieldDef;
    function IndexOf(const Name: string): Integer;
    procedure Update;
    property Count: Integer read GetCount;
    property Items[Index: Integer]: TFieldDef read GetItem; default;
  end;

{ TDataSet }

  TBookmark = Pointer;

  PBufferList = ^TBufferList;
  TBufferList = array[0..dsMaxBufferCount - 1] of PChar;

  TDataSetState = (dsInactive, dsBrowse, dsEdit, dsInsert,
    dsSetKey, dsCalcFields);

  TGetMode = (gmCurrent, gmNext, gmPrior);

  TResyncMode = set of (rmExact, rmCenter);

  TKeyIndex = (kiLookup, kiRangeStart, kiRangeEnd, kiCurRangeStart,
    kiCurRangeEnd, kiSave);

  PKeyBuffer = ^TKeyBuffer;
  TKeyBuffer = record
    Modified: Boolean;
    Exclusive: Boolean;
    FieldCount: Integer;
    Data: record end;
  end;

  TDataSetNotifyEvent = procedure(DataSet: TDataSet) of object;

  TDataSet = class(TComponent)
  private
    FFields: TList;
    FDataSources: TList;
    FFieldDefs: TFieldDefs;
    FBuffers: PBufferList;
    FBufListSize: Integer;
    FBufferCount: Integer;
    FRecordCount: Integer;
    FActiveRecord: Integer;
    FCurrentRecord: Integer;
    FHandle: HDBICur;
    FBOF: Boolean;
    FEOF: Boolean;
    FState: TDataSetState;
    FAutoCalcFields: Boolean;
    FDefaultFields: Boolean;
    FCanModify: Boolean;
    FModified: Boolean;
    FStreamedActive: Boolean;
    FInfoQueryMode: Boolean;
    FDisableState: TDataSetState;
    FEnableEvent: TDataEvent;
    FReserved: Byte;
    FRawFieldCount: Integer;
    FRecordSize: Word;
    FBookmarkSize: Word;
    FBookmarkOfs: Word;
    FCalcFieldsSize: Word;
    FRecBufSize: Word;
    FDisableCount: Integer;
    FFirstDataLink: TDataLink;
    FLocale: TLocale;
    FDesigner: TDataSetDesigner;
    FKeyBuffers: array[TKeyIndex] of PKeyBuffer;
    FKeyBuffer: PKeyBuffer;
    FCalcBuffer: PChar;
    FIndexFieldCount: Integer;
    FIndexFieldMap: DBIKey;
    FBeforeOpen: TDataSetNotifyEvent;
    FAfterOpen: TDataSetNotifyEvent;
    FBeforeClose: TDataSetNotifyEvent;
    FAfterClose: TDataSetNotifyEvent;
    FBeforeInsert: TDataSetNotifyEvent;
    FAfterInsert: TDataSetNotifyEvent;
    FBeforeEdit: TDataSetNotifyEvent;
    FAfterEdit: TDataSetNotifyEvent;
    FBeforePost: TDataSetNotifyEvent;
    FAfterPost: TDataSetNotifyEvent;
    FBeforeCancel: TDataSetNotifyEvent;
    FAfterCancel: TDataSetNotifyEvent;
    FBeforeDelete: TDataSetNotifyEvent;
    FAfterDelete: TDataSetNotifyEvent;
    FOnNewRecord: TDataSetNotifyEvent;
    FOnCalcFields: TDataSetNotifyEvent;
    procedure ActivateBuffers;
    procedure AddDataSource(DataSource: TDataSource);
    procedure AddField(Field: TField);
    procedure AddRecord(const Values: array of const; Append: Boolean);
    procedure BeginInsertAppend;
    procedure BindFields(Binding: Boolean);
    procedure CheckCanModify;
    procedure CheckFieldName(const FieldName: string);
    procedure CheckRequiredFields;
    procedure CheckSetKeyMode;
    procedure CopyBuffer(SourceIndex, DestIndex: Integer);
    procedure CreateFields;
    procedure DestroyFields;
    procedure EndInsertAppend;
    function FieldByNumber(FieldNo: Integer): TField;
    procedure FreeFieldBuffers;
    function GetActive: Boolean;
    procedure GetCalcFields(Index: Integer);
    function GetField(Index: Integer): TField;
    function GetFieldCount: Integer;
    procedure GetIndexInfo;
    function GetNextRecord: Boolean;
    function GetNextRecords: Integer;
    function GetPriorRecord: Boolean;
    function GetPriorRecords: Integer;
    function GetRecord(Index: Integer; GetMode: TGetMode): DBIResult;
    function GetRecordCount: Longint;
    function InitKeyBuffer(Buffer: PKeyBuffer): PKeyBuffer;
    procedure InitRecord(Buffer: PChar);
    procedure InternalClose;
    procedure InternalOpen;
    procedure MoveBuffer(CurIndex, NewIndex: Integer);
    procedure PostKeyBuffer(Commit: Boolean);
    procedure RemoveDataSource(DataSource: TDataSource);
    procedure RemoveField(Field: TField);
    procedure SetActive(Value: Boolean);
    procedure SetBufferCount(Value: Integer);
    procedure SetBufListSize(Value: Integer);
    procedure SetCurrentRecord(Index: Integer);
    procedure SetField(Index: Integer; Value: TField);
    procedure SetFieldDefs(Value: TFieldDefs);
    procedure SetState(Value: TDataSetState);
    procedure UpdateBufferCount;
    procedure UpdateFieldDefs;
  protected
    procedure CheckInactive;
    procedure ClearBuffers;
    procedure CloseCursor; virtual;
    function CreateHandle: HDBICur; virtual;
    procedure DataEvent(Event: TDataEvent; Info: Longint); virtual;
    procedure DoAfterCancel; virtual;
    procedure DoAfterClose; virtual;
    procedure DoAfterDelete; virtual;
    procedure DoAfterEdit; virtual;
    procedure DoAfterInsert; virtual;
    procedure DoAfterOpen; virtual;
    procedure DoAfterPost; virtual;
    procedure DoBeforeCancel; virtual;
    procedure DoBeforeClose; virtual;
    procedure DoBeforeDelete; virtual;
    procedure DoBeforeEdit; virtual;
    procedure DoBeforeInsert; virtual;
    procedure DoBeforeOpen; virtual;
    procedure DoBeforePost; virtual;
    procedure DoOnCalcFields; virtual;
    procedure DoOnNewRecord; virtual;
    function GetDataSource: TDataSource; virtual;
    function GetIndexField(Index: Integer): TField;
    function GetIndexFieldCount: Integer;
    function GetKeyBuffer(KeyIndex: TKeyIndex): PKeyBuffer;
    function GetKeyExclusive: Boolean;
    function GetKeyFieldCount: Integer;
    procedure InitFieldDefs; virtual;
    procedure Loaded; override;
    procedure OpenCursor; virtual;
    procedure PrepareCursor; virtual;
    function ResetCursorRange: Boolean;
    function SetCursorRange: Boolean;
    procedure SetIndexField(Index: Integer; Value: TField);
    procedure SetKeyBuffer(KeyIndex: TKeyIndex; Clear: Boolean);
    procedure SetKeyExclusive(Value: Boolean);
    procedure SetKeyFieldCount(Value: Integer);
    procedure SetKeyFields(KeyIndex: TKeyIndex;
      const Values: array of const);
    procedure SetLinkRanges(MasterFields: TList);
    procedure SetName(const Value: TComponentName); override;
    procedure SwitchToIndex(IndexName, TagName: PChar);
    procedure WriteComponents(Writer: TWriter); override;
    property InfoQueryMode: Boolean read FInfoQueryMode;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ActiveBuffer: PChar;
    procedure Append;
    procedure AppendRecord(const Values: array of const);
    procedure Cancel;
    procedure CheckBrowseMode;
    procedure ClearFields;
    procedure Close;
    procedure CursorPosChanged;
    procedure Delete;
    procedure DisableControls;
    procedure Edit;
    procedure EnableControls;
    function FieldByName(const FieldName: string): TField;
    function FindField(const FieldName: string): TField;
    procedure First;
    procedure FreeBookmark(Bookmark: TBookmark);
    function GetBookmark: TBookmark;
    function GetCurrentRecord(Buffer: PChar): Boolean;
    procedure GetFieldNames(List: TStrings);
    procedure GotoBookmark(Bookmark: TBookmark);
    procedure Insert;
    procedure InsertRecord(const Values: array of const);
    function IsLinkedTo(DataSource: TDataSource): Boolean;
    procedure Last;
    procedure MoveBy(Distance: Integer);
    procedure Next;
    procedure Open;
    procedure Post;
    procedure Prior;
    procedure Refresh;
    procedure Resync(Mode: TResyncMode);
    procedure SetFields(const Values: array of const);
    procedure UpdateCursorPos;
    procedure UpdateRecord;
    property BOF: Boolean read FBOF;
    property CanModify: Boolean read FCanModify;
    property DataSource: TDataSource read GetDataSource;
    property DefaultFields: Boolean read FDefaultFields;
    property Designer: TDataSetDesigner read FDesigner;
    property EOF: Boolean read FEOF;
    property FieldCount: Integer read GetFieldCount;
    property FieldDefs: TFieldDefs read FFieldDefs write SetFieldDefs;
    property Fields[Index: Integer]: TField read GetField write SetField;
    property Handle: HDBICur read FHandle;
    property Modified: Boolean read FModified;
    property RecordCount: Longint read GetRecordCount;
    property RecordSize: Word read FRecordSize;
    property State: TDataSetState read FState;
    property Locale: TLocale read FLocale;
  published
    property Active: Boolean read GetActive write SetActive default False;
    property AutoCalcFields: Boolean read FAutoCalcFields write FAutoCalcFields default True;
    property BeforeOpen: TDataSetNotifyEvent read FBeforeOpen write FBeforeOpen;
    property AfterOpen: TDataSetNotifyEvent read FAfterOpen write FAfterOpen;
    property BeforeClose: TDataSetNotifyEvent read FBeforeClose write FBeforeClose;
    property AfterClose: TDataSetNotifyEvent read FAfterClose write FAfterClose;
    property BeforeInsert: TDataSetNotifyEvent read FBeforeInsert write FBeforeInsert;
    property AfterInsert: TDataSetNotifyEvent read FAfterInsert write FAfterInsert;
    property BeforeEdit: TDataSetNotifyEvent read FBeforeEdit write FBeforeEdit;
    property AfterEdit: TDataSetNotifyEvent read FAfterEdit write FAfterEdit;
    property BeforePost: TDataSetNotifyEvent read FBeforePost write FBeforePost;
    property AfterPost: TDataSetNotifyEvent read FAfterPost write FAfterPost;
    property BeforeCancel: TDataSetNotifyEvent read FBeforeCancel write FBeforeCancel;
    property AfterCancel: TDataSetNotifyEvent read FAfterCancel write FAfterCancel;
    property BeforeDelete: TDataSetNotifyEvent read FBeforeDelete write FBeforeDelete;
    property AfterDelete: TDataSetNotifyEvent read FAfterDelete write FAfterDelete;
    property OnNewRecord: TDataSetNotifyEvent read FOnNewRecord write FOnNewRecord;
    property OnCalcFields: TDataSetNotifyEvent read FOnCalcFields write FOnCalcFields;
  end;

{ TDBDataSet }

  TUpdateMode = (upWhereAll, upWhereChanged, upWhereKeyOnly);
  TDBFlags = set of 0..15;

  TDBDataSet = class(TDataSet)
  private
    FDBFlags: TDBFlags;
    FUpdateMode: TUpdateMode;
    FReserved: Byte;
    FDatabase: TDatabase;
    FDatabaseName: TFileName;
    function GetDBFlag(Flag: Integer): Boolean;
    function GetDBHandle: HDBIDB;
    function GetDBLocale: TLocale;
    procedure SetDatabaseName(const Value: TFileName);
  protected
    procedure CloseCursor; override;
    procedure Disconnect; virtual;
    procedure OpenCursor; override;
    procedure SetDBFlag(Flag: Integer; Value: Boolean); virtual;
    property DBFlags: TDBFlags read FDBFlags;
    property UpdateMode: TUpdateMode read FUpdateMode write FUpdateMode default upWhereAll;
  public
    property Database: TDatabase read FDatabase;
    property DBHandle: HDBIDB read GetDBHandle;
    property DBLocale: TLocale read GetDBLocale;
  published
    property DatabaseName: TFileName read FDatabaseName write SetDatabaseName;
  end;

{ TDataSource }

  TDataChangeEvent = procedure(Sender: TObject; Field: TField) of object;

  TDataSource = class(TComponent)
  private
    FDataSet: TDataSet;
    FDataLinks: TList;
    FEnabled: Boolean;
    FAutoEdit: Boolean;
    FState: TDataSetState;
    FReserved: Byte;
    FOnStateChange: TNotifyEvent;
    FOnDataChange: TDataChangeEvent;
    FOnUpdateData: TNotifyEvent;
    procedure AddDataLink(DataLink: TDataLink);
    procedure DataEvent(Event: TDataEvent; Info: Longint);
    procedure NotifyDataLinks(Event: TDataEvent; Info: Longint);
    procedure RemoveDataLink(DataLink: TDataLink);
    procedure SetDataSet(ADataSet: TDataSet);
    procedure SetEnabled(Value: Boolean);
    procedure SetState(Value: TDataSetState);
    procedure UpdateState;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Edit;
    function IsLinkedTo(DataSet: TDataSet): Boolean;
    property State: TDataSetState read FState;
  published
    property AutoEdit: Boolean read FAutoEdit write FAutoEdit default True;
    property DataSet: TDataSet read FDataSet write SetDataSet;
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property OnStateChange: TNotifyEvent read FOnStateChange write FOnStateChange;
    property OnDataChange: TDataChangeEvent read FOnDataChange write FOnDataChange;
    property OnUpdateData: TNotifyEvent read FOnUpdateData write FOnUpdateData;
  end;

{ TField }

  TFieldNotifyEvent = procedure(Sender: TField) of object;
  TFieldGetTextEvent = procedure(Sender: TField; var Text: string;
    DisplayText: Boolean) of object;
  TFieldSetTextEvent = procedure(Sender: TField; const Text: string) of object;
  TFieldRef = ^TField;

  TField = class(TComponent)
  private
    FDataSet: TDataSet;
    FFieldName: PString;
    FDataType: TFieldType;
    FReadOnly: Boolean;
    FCalculated: Boolean;
    FAlignment: TAlignment;
    FVisible: Boolean;
    FRequired: Boolean;
    FValidating: Boolean;
    FReserved: Byte;
    FSize: Word;
    FDataSize: Word;
    FFieldNo: Integer;
    FOffset: Word;
    FDisplayWidth: Integer;
    FDisplayLabel: PString;
    FEditMask: PString;
    FValueBuffer: Pointer;
    FOnChange: TFieldNotifyEvent;
    FOnValidate: TFieldNotifyEvent;
    FOnGetText: TFieldGetTextEvent;
    FOnSetText: TFieldSetTextEvent;
    function GetDisplayLabel: string;
    function GetDisplayName: PString;
    function GetDisplayText: string;
    function GetDisplayWidth: Integer;
    function GetEditMask: string;
    function GetEditText: string;
    function GetFieldName: string;
    function GetIndex: Integer;
    function GetIsIndexField: Boolean;
    function GetIsNull: Boolean;
    function IsDisplayLabelStored: Boolean;
    function IsDisplayWidthStored: Boolean;
    procedure SetAlignment(Value: TAlignment);
    procedure SetCalculated(Value: Boolean);
    procedure SetDataSet(ADataSet: TDataSet);
    procedure SetDisplayLabel(Value: string);
    procedure SetDisplayWidth(Value: Integer);
    procedure SetEditMask(const Value: string);
    procedure SetEditText(const Value: string);
    procedure SetFieldName(const Value: string);
    procedure SetIndex(Value: Integer);
    procedure SetVisible(Value: Boolean);
    procedure UpdateDataSize;
  protected
    procedure AccessError(const TypeName: string);
    procedure CheckInactive;
    procedure Change; virtual;
    procedure DataChanged;
    procedure FreeBuffers; virtual;
    function GetAsBoolean: Boolean; virtual;
    function GetAsDateTime: TDateTime; virtual;
    function GetAsFloat: Double; virtual;
    function GetAsInteger: Longint; virtual;
    function GetAsString: string; virtual;
    function GetCanModify: Boolean;
    function GetDefaultWidth: Integer; virtual;
    procedure GetText(var Text: string; DisplayText: Boolean); virtual;
    function HasParent: Boolean; override;
    procedure PropertyChanged(LayoutAffected: Boolean);
    procedure ReadState(Reader: TReader); override;
    procedure SetAsBoolean(Value: Boolean); virtual;
    procedure SetAsDateTime(Value: TDateTime); virtual;
    procedure SetAsFloat(Value: Double); virtual;
    procedure SetAsInteger(Value: Longint); virtual;
    procedure SetAsString(const Value: string); virtual;
    procedure SetDataType(Value: TFieldType);
    procedure SetSize(Value: Word);
    procedure SetText(const Value: string); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure AssignValue(const Value: TVarRec);
    procedure Clear; virtual;
    procedure FocusControl;
    function GetData(Buffer: Pointer): Boolean;
    procedure SetData(Buffer: Pointer);
    function IsValidChar(InputChar: Char): Boolean; virtual;
    property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;
    property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
    property AsFloat: Double read GetAsFloat write SetAsFloat;
    property AsInteger: Longint read GetAsInteger write SetAsInteger;
    property AsString: string read GetAsString write SetAsString;
    property CanModify: Boolean read GetCanModify;
    property DataSet: TDataSet read FDataSet write SetDataSet stored False;
    property DataSize: Word read FDataSize;
    property DataType: TFieldType read FDataType;
    property DisplayName: PString read GetDisplayName;
    property DisplayText: string read GetDisplayText;
    property EditMask: string read GetEditMask write SetEditMask;
    property EditMaskPtr: PString read FEditMask;
    property FieldNo: Integer read FFieldNo;
    property IsIndexField: Boolean read GetIsIndexField;
    property IsNull: Boolean read GetIsNull;
    property Size: Word read FSize write SetSize;
    property Text: string read GetEditText write SetEditText;
  published
    property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
    property Calculated: Boolean read FCalculated write SetCalculated default False;
    property DisplayLabel: string read GetDisplayLabel write SetDisplayLabel
      stored IsDisplayLabelStored;
    property DisplayWidth: Integer read GetDisplayWidth write SetDisplayWidth
      stored IsDisplayWidthStored;
    property FieldName: string read GetFieldName write SetFieldName;
    property Index: Integer read GetIndex write SetIndex stored False;
    property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
    property Required: Boolean read FRequired write FRequired default False;
    property Visible: Boolean read FVisible write SetVisible default True;
    property OnChange: TFieldNotifyEvent read FOnChange write FOnChange;
    property OnGetText: TFieldGetTextEvent read FOnGetText write FOnGetText;
    property OnSetText: TFieldSetTextEvent read FOnSetText write FOnSetText;
    property OnValidate: TFieldNotifyEvent read FOnValidate write FOnValidate;
  end;

{ TDataLink }

  TDataLink = class(TPersistent)
  private
    FDataSource: TDataSource;
    FNext: TDataLink;
    FBufferCount: Integer;
    FFirstRecord: Integer;
    FReadOnly: Boolean;
    FActive: Boolean;
    FEditing: Boolean;
    FUpdating: Boolean;
    procedure DataEvent(Event: TDataEvent; Info: Longint);
    function GetActiveRecord: Integer;
    function GetDataSet: TDataSet;
    function GetRecordCount: Integer;
    procedure SetActive(Value: Boolean);
    procedure SetActiveRecord(Value: Integer);
    procedure SetBufferCount(Value: Integer);
    procedure SetDataSource(ADataSource: TDataSource);
    procedure SetEditing(Value: Boolean);
    procedure SetReadOnly(Value: Boolean);
    procedure UpdateRange;
    procedure UpdateState;
  protected
    procedure ActiveChanged; virtual;
    procedure CheckBrowseMode; virtual;
    procedure DataSetChanged; virtual;
    procedure DataSetScrolled(Distance: Integer); virtual;
    procedure FocusControl(Field: TFieldRef); virtual;
    procedure EditingChanged; virtual;
    procedure LayoutChanged; virtual;
    procedure RecordChanged(Field: TField); virtual;
    procedure UpdateData; virtual;
  public
    constructor Create;
    destructor Destroy; override;
    function Edit: Boolean;
    procedure UpdateRecord;
    property Active: Boolean read FActive;
    property ActiveRecord: Integer read GetActiveRecord write SetActiveRecord;
    property BufferCount: Integer read FBufferCount write SetBufferCount;
    property DataSet: TDataSet read GetDataSet;
    property DataSource: TDataSource read FDataSource write SetDataSource;
    property Editing: Boolean read FEditing;
    property ReadOnly: Boolean read FReadOnly write SetReadOnly;
    property RecordCount: Integer read GetRecordCount;
  end;

const
  dsEditModes = [dsEdit, dsInsert, dsSetKey];

const
  Null = TField(nil);

function AnsiToNative(Locale: TLocale; const AnsiStr: string;
  NativeStr: PChar; MaxLen: Word): PChar;
procedure NativeToAnsi(Locale: TLocale; NativeStr: PChar;
  var AnsiStr: string);
procedure AnsiToNativeBuf(Locale: TLocale; Source, Dest: PChar; Len: Word);
procedure NativeToAnsiBuf(Locale: TLocale; Source, Dest: PChar; Len: Word);
function ExtractFieldName(const Fields: string; var Pos: Integer): string;

procedure RegisterFields(const FieldClasses: array of TFieldClass);

procedure DatabaseError(const Message: string);
procedure DBError(Ident: Word);
procedure DBErrorFmt(Ident: Word; const Args: array of const);
procedure DbiError(ErrorCode: DBIResult);
procedure Check(Status: DBIResult);

var
  Session: TSession;

const
  RegisterFieldsProc: procedure(const FieldClassess: array of TFieldClass) = nil;

implementation

uses Controls, Forms, DBConsts, DBPWDlg, DBLogDlg, DBTables;

const
  StartTime: LongInt = 0;
  ServerTimer: Word = 0;

{ Timer callback function }

procedure TimerCallBack(hWnd: HWND; Message: Word; TimerID: Word;
  SysTime: LongInt); export;
begin
  KillTimer(0, TimerID);
  ServerTimer := 0;
  Screen.Cursor := crDefault;
  StartTime := 0;
end;

{ Server callback function }

function ServerCallBack(CallType: CBType; Data: Longint;
  var Info: Pointer): CBRType; export;
const
  MinWait = 500;
var
  CallInfo: CBSCType;
begin
  Result := cbrUSEDEF;
  if CallType = cbSERVERCALL then
  begin
    CallInfo := CBSCType(Info);
    if CallInfo = cbscSQL then
    begin
      if StartTime = 0 then
      begin
        ServerTimer := SetTimer(0, 0, 1000, @TimerCallBack);
        StartTime := GetTickCount;
      end
      else if (ServerTimer <> 0) and (GetTickCount - StartTime > MinWait) then
        Screen.Cursor := crSQLWait;
    end;
    with Session.FOldCallBack do
      if ChainedFunc <> nil then Result := pfDBICallBack(ChainedFunc)(cbSERVERCALL, Data, Buffer)
  end;
end;

{ Utility routines }

procedure DisposeMem(var Buffer; Size: Word);
begin
  if Pointer(Buffer) <> nil then
  begin
    FreeMem(Pointer(Buffer), Size);
    Pointer(Buffer) := nil;
  end;
end;

function BuffersEqual(Buf1, Buf2: Pointer; Size: Cardinal): Boolean;
  assembler;
asm
        PUSH    DS
        LDS     SI,Buf1
        LES     DI,Buf2
        MOV     CX,Size
        XOR     AX,AX
        CLD
        REPE    CMPSB
        JNE     @@1
        INC     AX
@@1:    POP     DS
end;

function AnsiToNative(Locale: TLocale; const AnsiStr: string;
  NativeStr: PChar; MaxLen: Word): PChar;
var
  Len: Word;
begin
  Len := Length(AnsiStr);
  if Len > MaxLen then Len := MaxLen;
  AnsiToNativeBuf(Locale, @AnsiStr[1], NativeStr, Len);
  NativeStr[Len] := #0;
  Result := NativeStr;
end;

procedure NativeToAnsi(Locale: TLocale; NativeStr: PChar;
  var AnsiStr: string);
var
  Len: Word;
begin
  Len := StrLen(NativeStr);
  if Len > High(AnsiStr) then Len := High(AnsiStr);
  NativeToAnsiBuf(Locale, NativeStr, @AnsiStr[1], Len);
  AnsiStr[0] := Chr(Len);
end;

procedure AnsiToNativeBuf(Locale: TLocale; Source, Dest: PChar; Len: Word);
var
  DataLoss: WordBool;
begin
  if Len <> 0 then
    if Locale <> nil then
      DbiAnsiToNative(Locale, Dest, Source, Len, DataLoss) else
      AnsiToOemBuff(Source, Dest, Len);
end;

procedure NativeToAnsiBuf(Locale: TLocale; Source, Dest: PChar; Len: Word);
var
  DataLoss: WordBool;
begin
  if Len <> 0 then
    if Locale <> nil then
      DbiNativeToAnsi(Locale, Dest, Source, Len, DataLoss) else
      OemToAnsiBuff(Source, Dest, Len);
end;

function ExtractFieldName(const Fields: string; var Pos: Integer): string;
var
  I: Integer;
begin
  I := Pos;
  while (I <= Length(Fields)) and (Fields[I] <> ';') do Inc(I);
  Result := Copy(Fields, Pos, I - Pos);
  if (I <= Length(Fields)) and (Fields[I] = ';') then Inc(I);
  Pos := I;
end;

function IsDirectory(const DatabaseName: string): Boolean;
begin
  Result := (DatabaseName = '') or (Pos(':', DatabaseName) <> 0) or
    (Pos('\', DatabaseName) <> 0);
end;

procedure MergeStrings(Dest, Source: TStrings);
var
  I, P: Integer;
  S: string;
begin
  for I := 0 to Source.Count - 1 do
  begin
    S := Source[I];
    P := Pos('=', S);
    if P > 1 then Dest.Values[Copy(S, 1, P - 1)] := Copy(S, P + 1, 255);
  end;
end;

procedure CheckTypeSize(DataType: TFieldType; Size: Word);
begin
  case DataType of
    ftString: if (Size >= 1) and (Size <= 255) then Exit;
    ftBCD: if Size <= 32 then Exit;
    ftBytes, ftVarBytes: if Size > 0 then Exit;
    ftBlob, ftMemo, ftGraphic: if Size >= 0 then Exit;
  else
    if Size = 0 then Exit;
  end;
  DBError(SInvalidFieldSize);
end;

procedure RegisterFields(const FieldClasses: array of TFieldClass);
begin
  if Assigned(RegisterFieldsProc) then
    RegisterFieldsProc(FieldClasses) else
    DBError(SInvalidFieldRegistration);
end;

{ Error and exception handling routines }

procedure DatabaseError(const Message: string);
begin
  raise EDatabaseError.Create(Message);
end;

procedure DBError(Ident: Word);
begin
  DatabaseError(LoadStr(Ident));
end;

procedure DBErrorFmt(Ident: Word; const Args: array of const);
begin
  DatabaseError(FmtLoadStr(Ident, Args));
end;

procedure DbiError(ErrorCode: DBIResult);
begin
  raise EDBEngineError.Create(ErrorCode);
end;

procedure Check(Status: DBIResult);
begin
  if Status <> 0 then DbiError(Status);
end;

{ TDBError }

constructor TDBError.Create(Owner: EDBEngineError; ErrorCode: DBIResult;
  NativeError: Longint; Message: PChar);
begin
  Owner.FErrors.Add(Self);
  FErrorCode := ErrorCode;
  FNativeError := NativeError;
  FMessage := StrPas(Message);
end;

function TDBError.GetCategory: Byte;
begin
  Result := Hi(FErrorCode);
end;

function TDBError.GetSubCode: Byte;
begin
  Result := Lo(FErrorCode);
end;

{ EDBEngineError }

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[Word(-1)] = '.') then Dec(Dest);
  Dest^ := #0;
  Result := Msg;
end;

constructor EDBEngineError.Create(ErrorCode: DBIResult);
var
  ErrorIndex: Integer;
  NativeError: Longint;
  Msg, LastMsg: DBIMSG;
begin
  inherited Create('');
  FErrors := TList.Create;
  DbiGetErrorString(ErrorCode, Msg);
  TDBError.Create(Self, ErrorCode, 0, Msg);
  TrimMessage(Msg);
  if Msg[0] = #0 then
    Message := FmtLoadStr(SBDEError, [ErrorCode]) else
    Message := StrPas(Msg);
  ErrorIndex := 1;
  while True do
  begin
    StrCopy(LastMsg, Msg);
    ErrorCode := DbiGetErrorEntry(ErrorIndex, NativeError, Msg);
    if ErrorCode = DBIERR_NONE then Break;
    TDBError.Create(Self, ErrorCode, NativeError, Msg);
    TrimMessage(Msg);
    if (Msg[0] <> #0) and (StrComp(Msg, LastMsg) <> 0) then
      Message := Format('%s. %s', [MessagePtr^, Msg]);
    Inc(ErrorIndex);
  end;
end;

destructor EDBEngineError.Destroy;
var
  I: Integer;
begin
  if FErrors <> nil then
  begin
    for I := FErrors.Count - 1 downto 0 do TDBError(FErrors[I]).Free;
    FErrors.Free;
  end;
  inherited Destroy;
end;

function EDBEngineError.GetError(Index: Integer): TDBError;
begin
  Result := FErrors[Index];
end;

function EDBEngineError.GetErrorCount: Integer;
begin
  Result := FErrors.Count;
end;

{ TSession }

constructor TSession.Create(AOwner: TComponent);
var
  Status: DBIResult;
  Env: DbiEnv;
begin
  inherited Create(AOwner);
  FDatabases := TList.Create;
  FKeepConnections := True;
  FillChar(Env, SizeOf(Env), 0);
  StrPLCopy(Env.szLang, LoadStr(SIDAPILangID), SizeOf(Env.szLang) - 1);
  Status := DbiInit(@Env);
  if Status = 0 then
  begin
    FServerData := AllocMem(SizeOf(CBSCType));
    FDoExit := True;
    with FOldCallBack do
      DbiGetCallBack(nil, cbSERVERCALL, Data, BufLen, Buffer, @ChainedFunc);
    DbiRegisterCallBack(nil, cbSERVERCALL, 0,
      SizeOf(CBSCType), FServerData, ServerCallBack);
  end else
    if Status <> DBIERR_MULTIPLEINIT then DBErrorFmt(SInitError, [Status]);
  Check(DbiGetLdObj(nil, FLocale));
end;

destructor TSession.Destroy;
var
  I: Integer;
begin
  for I := FDatabases.Count - 1 downto 0 do
    with TDatabase(FDatabases[I]) do Free;
  if FDoExit then
  begin
    DbiRegisterCallBack(nil, cbSERVERCALL, 0,
      SizeOf(CBSCType), FServerData, nil);
    DbiExit;
    if (ServerTimer <> 0) then
    begin
      KillTimer(0, ServerTimer);
      ServerTimer := 0;
    end;
    FreeMem(FServerData, SizeOf(CBSCType));
  end;
  inherited Destroy;
end;

procedure TSession.AddPassword(const Password: string);
var
  Buffer: array[0..255] of Char;
begin
  if Password <> '' then
    Check(DbiAddPassword(AnsiToNative(Locale, Password, Buffer,
      SizeOf(Buffer) - 1)));
end;

procedure TSession.CloseDatabase(Database: TDatabase);
begin
  if Database.FRefCount <> 0 then Dec(Database.FRefCount);
  if (Database.FRefCount = 0) and not Database.KeepConnection then
    if Database.Temporary then Database.Free else Database.Close;
end;

procedure TSession.DropConnections;
var
  I: Integer;
begin
  for I := FDatabases.Count - 1 downto 0 do
    with TDatabase(FDatabases[I]) do
      if Temporary and (FRefCount = 0) then Free;
end;

function TSession.FindDatabase(const DatabaseName: string): TDatabase;
var
  I: Integer;
begin
  for I := 0 to FDatabases.Count - 1 do
  begin
    Result := FDatabases[I];
    if ((Result.DatabaseName <> '') or Result.Temporary) and
      (AnsiCompareText(Result.DatabaseName, DatabaseName) = 0) then Exit;
  end;
  Result := nil;
end;

procedure TSession.GetAliasNames(List: TStrings);
var
  Cursor: HDBICur;
  Name: TSymbolStr;
  Desc: DBDesc;
begin
  List.BeginUpdate;
  try
    List.Clear;
    Check(DbiOpenDatabaseList(Cursor));
    try
      while DbiGetNextRecord(Cursor, dbiNOLOCK, @Desc, nil) = 0 do
      begin
        OemToAnsi(Desc.szName, Desc.szName);
        List.Add(StrPas(Desc.szName));
      end;
    finally
      DbiCloseCursor(Cursor);
    end;
  finally
    List.EndUpdate;
  end;
end;

procedure TSession.GetAliasParams(const AliasName: string; List: TStrings);
var
  SAlias: array[0..31] of Char;
  Desc: DBDesc;
begin
  List.BeginUpdate;
  try
    List.Clear;
    StrPLCopy(SAlias, AliasName, SizeOf(SAlias) - 1);
    AnsiToOem(SAlias, SAlias);
    Check(DbiGetDatabaseDesc(SAlias, @Desc));
    if StrIComp(Desc.szDbType, 'STANDARD') = 0 then
    begin
      OemToAnsi(Desc.szPhyName, Desc.szPhyName);
      List.Add(Format('PATH=%s', [Desc.szPhyName]))
    end else
      GetConfigParams('\DATABASES\%s\DB OPEN', SAlias, List);
  finally
    List.EndUpdate;
  end;
end;

procedure TSession.GetConfigParams(Path, Section: PChar; List: TStrings);
var
  Cursor: HDBICur;
  SPath: array[0..63] of Char;
  ConfigDesc: CFGDesc;
begin
  Check(DbiOpenCfgInfoList(nil, dbiREADONLY, cfgPERSISTENT,
    StrLFmt(SPath, SizeOf(SPath) - 1, Path, [Section]), Cursor));
  try
    while DbiGetNextRecord(Cursor, dbiNOLOCK, @ConfigDesc, nil) = 0 do
      with ConfigDesc do
      begin
        OemToAnsi(szValue, szValue);
        List.Add(Format('%s=%s', [szNodeName, szValue]));
      end;
    List.Add('PASSWORD=');
  finally
    DbiCloseCursor(Cursor);
  end;
end;

function TSession.GetDatabase(Index: Integer): TDatabase;
begin
  Result := FDatabases[Index];
end;

function TSession.GetDatabaseCount: Integer;
begin
  Result := FDatabases.Count;
end;

procedure TSession.GetDatabaseNames(List: TStrings);
var
  I: Integer;
  Names: TStringList;
begin
  Names := TStringList.Create;
  try
    Names.Sorted := True;
    GetAliasNames(Names);
    for I := 0 to FDatabases.Count - 1 do
      with TDatabase(FDatabases[I]) do
        if not IsDirectory(DatabaseName) then Names.Add(DatabaseName);
    List.Assign(Names);
  finally
    Names.Free;
  end;
end;

procedure TSession.GetDriverNames(List: TStrings);
var
  Cursor: HDBICur;
  Name: array[0..255] of Char;
begin
  List.BeginUpdate;
  try
    List.Clear;
    List.Add('STANDARD');
    Check(DbiOpenDriverList(Cursor));
    try
      while DbiGetNextRecord(Cursor, dbiNOLOCK, @Name, nil) = 0 do
        if (StrIComp(Name, 'PARADOX') <> 0) and
          (StrIComp(Name, 'DBASE') <> 0) then
          List.Add(StrPas(Name));
    finally
      DbiCloseCursor(Cursor);
    end;
  finally
    List.EndUpdate;
  end;
end;

procedure TSession.GetDriverParams(const DriverName: string;
  List: TStrings);
var
  SDriver: array[0..31] of Char;
begin
  List.BeginUpdate;
  try
    List.Clear;
    if CompareText(DriverName, 'STANDARD') = 0 then
      List.Add('PATH=')
    else
      GetConfigParams('\DRIVERS\%s\DB OPEN', StrPLCopy(SDriver, DriverName,
        SizeOf(SDriver) - 1), List);
  finally
    List.EndUpdate;
  end;
end;

function TSession.GetHandle: HDBISES;
begin
  DbiGetCurrSession(Result);
end;

function TSession.GetNetFileDir: string;
var
  Length: Word;
  Buffer: array[0..255] of Char;
begin
  Check(DbiGetProp(HDBIOBJ(Handle), sesNETFILE, @Buffer, SizeOf(Buffer),
    Length));
  NativeToAnsi(nil, Buffer, Result);
end;

function TSession.GetPrivateDir: string;
var
  SessionInfo: SESInfo;
begin
  Check(DbiGetSesInfo(SessionInfo));
  NativeToAnsi(nil, SessionInfo.szPrivDir, Result);
end;

function TSession.GetPassword: Boolean;
begin
  if Assigned(FOnPassword) then
  begin
    Result := False;
    FOnPassword(Self, Result)
  end else
    Result := PasswordDialog;
end;

procedure TSession.GetTableNames(const DatabaseName, Pattern: string;
  Extensions, SystemTables: Boolean; List: TStrings);
var
  Database: TDatabase;
  Cursor: HDBICur;
  WildCard: PChar;
  Name: TFileName;
  SPattern: array[0..127] of Char;
  Desc: TBLBaseDesc;
begin
  List.BeginUpdate;
  try
    List.Clear;
    Database := OpenDatabase(DatabaseName);
    try
      WildCard := nil;
      if Pattern <> '' then
        WildCard := AnsiToNative(Database.Locale, Pattern, SPattern,
          SizeOf(SPattern) - 1);
      Check(DbiOpenTableList(Database.Handle, False, SystemTables,
        WildCard, Cursor));
      try
        while DbiGetNextRecord(Cursor, dbiNOLOCK, @Desc, nil) = 0 do
          with Desc do
          begin
            if Extensions and (szExt[0] <> #0) then
              StrCat(StrCat(szName, '.'), szExt);
            NativeToAnsi(Database.Locale, szName, Name);
            List.Add(Name);
          end;
      finally
        DbiCloseCursor(Cursor);
      end;
    finally
      CloseDatabase(Database);
    end;
  finally
    List.EndUpdate;
  end;
end;

procedure TSession.GetStoredProcNames(const DatabaseName: string; List: TStrings);
var
  Database: TDatabase;
  Cursor: HDBICur;
  Name: TFileName;
  Desc: SPDesc;
begin
  List.BeginUpdate;
  try
    List.Clear;
    Database := OpenDatabase(DatabaseName);
    try
      Check(DbiOpenSPList(Database.Handle, False, True, nil, Cursor));
      try
        while DbiGetNextRecord(Cursor, dbiNOLOCK, @Desc, nil) = 0 do
          with Desc do
          begin
            NativeToAnsi(Database.Locale, szName, Name);
            List.Add(Name);
          end;
      finally
        DbiCloseCursor(Cursor);
      end;
    finally
      CloseDatabase(Database);
    end;
  finally
    List.EndUpdate;
  end;
end;

function TSession.OpenDatabase(const DatabaseName: string): TDatabase;
var
  TempDatabase: TDatabase;
begin
  TempDatabase := nil;
  try
    Result := FindDatabase(DatabaseName);
    if Result = nil then
    begin
      TempDatabase := TDatabase.Create(Self);
      TempDatabase.DatabaseName := DatabaseName;
      TempDatabase.KeepConnection := FKeepConnections;
      TempDatabase.Temporary := True;
      Result := TempDatabase;
    end;
    Result.Open;
    Inc(Result.FRefCount);
  except
    TempDatabase.Free;
    raise;
  end;
end;

procedure TSession.RemoveAllPasswords;
begin
  DbiDropPassword(nil);
end;

procedure TSession.RemovePassword(const Password: string);
var
  Buffer: array[0..255] of Char;
begin
  if Password <> '' then
    DbiDropPassword(AnsiToNative(Locale, Password, Buffer,
      SizeOf(Buffer) - 1));
end;

procedure TSession.SetNetFileDir(const Value: string);
var
  Buffer: array[0..255] of Char;
begin
  Check(DbiSetProp(HDBIOBJ(Handle), sesNETFILE, Longint(AnsiToNative(nil,
    Value, Buffer, SizeOf(Buffer) - 1))));
end;

procedure TSession.SetPrivateDir(const Value: string);
var
  Buffer: array[0..255] of Char;
begin
  Check(DbiSetPrivateDir(AnsiToNative(nil, Value, Buffer,
    SizeOf(Buffer) - 1)));
end;

{ TParamList }

constructor TParamList.Create(Params: TStrings);
var
  I, P, FieldNo: Integer;
  BufPtr: PChar;
  S: string;
begin
  for I := 0 to Params.Count - 1 do
  begin
    S := Params[I];
    P := Pos('=', S);
    if P <> 0 then
    begin
      Inc(FFieldCount);
      Inc(FBufSize, Length(S) - P + 1);
    end;
  end;
  if FFieldCount > 0 then
  begin
    FFieldDescs := AllocMem(FFieldCount * SizeOf(FLDDesc));
    FBuffer := AllocMem(FBufSize);
    FieldNo := 0;
    BufPtr := FBuffer;
    for I := 0 to Params.Count - 1 do
    begin
      S := Params[I];
      P := Pos('=', S);
      if P <> 0 then
        with FFieldDescs^[FieldNo] do
        begin
          Inc(FieldNo);
          iFldNum := FieldNo;
          StrPLCopy(szName, Copy(S, 1, P - 1), SizeOf(szName) - 1);
          iFldType := fldZSTRING;
          iOffset := BufPtr - FBuffer;
          iLen := Length(S) - P + 1;
          StrPCopy(BufPtr, Copy(S, P + 1, 255));
          AnsiToOem(BufPtr, BufPtr);
          Inc(BufPtr, iLen);
        end;
    end;
  end;
end;

destructor TParamList.Destroy;
begin
  DisposeMem(FBuffer, FBufSize);
  DisposeMem(FFieldDescs, FFieldCount * SizeOf(FLDDesc));
end;

{ TDatabase }

constructor TDatabase.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Session.FDatabases.Add(Self);
  FDatasets := TList.Create;
  FParams := TStringList.Create;
  TStringList(FParams).OnChanging := ParamsChanging;
  FLoginPrompt := True;
  FKeepConnection := True;
  FLocale := Session.Locale;
  FTransIsolation := tiReadCommitted;
end;

destructor TDatabase.Destroy;
begin
  Close;
  FParams.Free;
  FDatasets.Free;
  Session.FDatabases.Remove(Self);
  inherited Destroy;
end;

procedure TDatabase.CheckActive;
begin
  if FHandle = nil then DBError(SDatabaseClosed);
end;

procedure TDatabase.CheckInactive;
begin
  if FHandle <> nil then DBError(SDatabaseOpen);
end;

procedure TDatabase.Close;
begin
  if FHandle <> nil then
  begin
    CloseDatasets;
    if FLocaleLoaded then OsLdUnloadObj(FLocale);
    FLocaleLoaded := False;
    FLocale := Session.Locale;
    DbiCloseDatabase(FHandle);
    FHandle := nil;
    FRefCount := 0;
  end;
end;

procedure TDatabase.CloseDatasets;
begin
  while FDataSets.Count <> 0 do TDBDataSet(FDataSets.Last).Disconnect;
end;

procedure TDatabase.Commit;
begin
  CheckActive;
  EndTransaction(xendCOMMIT);
end;

procedure TDatabase.EndTransaction(TransEnd: EXEnd);
begin
  if FTransHandle = nil then DBErrorFmt(SEndTransError, [FDatabaseName]);
  Check(DbiEndTran(FHandle, FTransHandle, TransEnd));
  FTransHandle := nil;
end;

function TDatabase.GetAliasName: TSymbolStr;
begin
  if FAliased then Result := FDatabaseType else Result := '';
end;

function TDatabase.GetConnected: Boolean;
begin
  Result := FHandle <> nil;
end;

function TDatabase.GetDataset(Index: Integer): TDBDataset;
begin
  Result := FDatasets[Index];
end;

function TDatabase.GetDatasetCount: Integer;
begin
  Result := FDatasets.Count;
end;

function TDatabase.GetDriverName: TSymbolStr;
begin
  if FAliased then Result := '' else Result := FDatabaseType;
end;

function TDatabase.GetIsSQLBased: Boolean;
var
  Length: Word;
  Buffer: array[0..63] of Char;
begin
  Result := False;
  if FHandle <> nil then
  begin
    Check(DbiGetProp(HDBIOBJ(FHandle), dbDATABASETYPE, @Buffer,
      SizeOf(Buffer), Length));
    Result := StrIComp(Buffer, 'STANDARD') <> 0;
  end;
end;

procedure TDatabase.Loaded;
begin
  inherited Loaded;
  try
    if FStreamedConnected then Open;
  except
    if csDesigning in ComponentState then
      Application.HandleException(Self)
    else
      raise;
  end;
end;

procedure TDatabase.Login(LoginParams: TStrings);
var
  UserName, Password: string[31];
begin
  if Assigned(FOnLogin) then FOnLogin(Self, LoginParams) else
  begin
    UserName := LoginParams.Values['USER NAME'];
    if not LoginDialog(DatabaseName, UserName, Password) then
      DBErrorFmt(SLoginError, [DatabaseName]);
    LoginParams.Values['USER NAME'] := UserName;
    LoginParams.Values['PASSWORD'] := Password;
  end;
end;

procedure TDatabase.Open;
var
  Aliased, RequiresLogin: Boolean;
  DBName, DBType: PChar;
  LoginParams: TStringList;
  ParamList: TParamList;
  DBLocale: TLocale;
  NamePtr: PString;
  SPassword: array[0..SizeOf(TSymbolStr) - 1] of Char;
  SName: array[0..SizeOf(TSymbolStr) - 1] of Char;
  Desc: DBDesc;
begin
  if FHandle = nil then
  begin
    if (FDatabaseName = '') and not Temporary then
      DBError(SDatabaseNameMissing);
    DBName := nil;
    DBType := nil;
    ParamList := nil;
    LoginParams := TStringList.Create;
    try
      if (FDatabaseType = '') and IsDirectory(FDatabaseName) then
        LoginParams.Add(Format('PATH=%s', [FDatabaseName]))
      else
      begin
        if FDatabaseType <> '' then
        begin
          NamePtr := @FDatabaseType;
          Aliased := FAliased;
        end else
        begin
          NamePtr := @FDatabaseName;
          Aliased := True;
        end;
        StrPLCopy(SName, NamePtr^, SizeOf(SName) - 1);
        AnsiToOem(SName, SName);
        if Aliased then
        begin
          DBName := SName;
          RequiresLogin := (DbiGetDatabaseDesc(DBName, @Desc) = 0) and
            (StrIComp(Desc.szDbType, 'STANDARD') <> 0);
        end else
        begin
          DBType := SName;
          RequiresLogin := StrIComp(DBType, 'STANDARD') <> 0;
        end;
        if RequiresLogin and LoginPrompt then
        begin
          if Aliased then
            Session.GetAliasParams(NamePtr^, LoginParams) else
            Session.GetDriverParams(NamePtr^, LoginParams);
          MergeStrings(LoginParams, FParams);
          Login(LoginParams);
        end else
          LoginParams.Assign(FParams);
      end;
      StrPLCopy(SPassword, LoginParams.Values['PASSWORD'],
        SizeOf(SPassword) - 1);
      AnsiToOem(SPassword, SPassword);
      ParamList := TParamList.Create(LoginParams);
      Check(DbiOpenDatabase(DBName, DBType, dbiREADWRITE, dbiOPENSHARED,
        SPassword, ParamList.FieldCount, PFLDDesc(ParamList.FieldDescs),
        ParamList.Buffer, FHandle));
      DbiSetProp(HDBIOBJ(FHandle), dbUSESCHEMAFILE, Longint(True));
      DbiSetProp(HDBIOBJ(FHandle), dbPARAMFMTQMARK, Longint(True));
    finally
      ParamList.Free;
      LoginParams.Free;
    end;
    if DbiGetLdNameFromDB(FHandle, nil, SName) = 0 then
      if OsLdLoadBySymbName(SName, DBLocale) = 0 then
      begin
        FLocale := DBLocale;
        FLocaleLoaded := True;
      end;
  end;
end;

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

procedure TDatabase.Rollback;
begin
  CheckActive;
  EndTransaction(xendABORT);
end;

procedure TDatabase.SetAliasName(const Value: TSymbolStr);
begin
  SetDatabaseType(Value, True);
end;

procedure TDatabase.SetConnected(Value: Boolean);
begin
  if csReading in ComponentState then
    FStreamedConnected := Value
  else
    if Value then Open else Close;
end;

procedure TDatabase.SetDatabaseName(const Value: TFileName);
begin
  CheckInactive;
  if FDatabaseName <> Value then
  begin
    ValidateName(Value);
    FDatabaseName := Value;
  end;
end;

procedure TDatabase.SetDatabaseType(const Value: TSymbolStr;
  Aliased: Boolean);
begin
  CheckInactive;
  FDatabaseType := Value;
  FAliased := Aliased;
end;

procedure TDatabase.SetDriverName(const Value: TSymbolStr);
begin
  SetDatabaseType(Value, False);
end;

procedure TDatabase.SetKeepConnection(Value: Boolean);
begin
  if FKeepConnection <> Value then
  begin
    FKeepConnection := Value;
    if not Value and (FRefCount = 0) then Close;
  end;
end;

procedure TDatabase.SetParams(Value: TStrings);
begin
  FParams.Assign(Value);
end;

procedure TDatabase.StartTransaction;
begin
  CheckActive;
  if not IsSQLBased then DBError(SNoTransactions);
  if FTransHandle <> nil then DBErrorFmt(SBeginTransError, [FDatabaseName]);
  Check(DbiBeginTran(FHandle, EXILType(FTransIsolation), FTransHandle));
end;

procedure TDatabase.ValidateName(const Name: string);
var
  Database: TDatabase;
begin
  if Name <> '' then
  begin
    Database := Session.FindDatabase(Name);
    if (Database <> nil) and (Database <> Self) then
    begin
      if not Database.Temporary or (Database.FRefCount <> 0) then
        DBErrorFmt(SDuplicateDatabaseName, [Name]);
      Database.Free;
    end;
  end;
end;

{ TDataSetDesigner }

constructor TDataSetDesigner.Create(DataSet: TDataSet);
begin
  FDataSet := DataSet;
  FDataSet.FDesigner := Self;
end;

destructor TDataSetDesigner.Destroy;
begin
  FDataSet.FDesigner := nil;
end;

procedure TDataSetDesigner.BeginDesign;
begin
  FSaveActive := FDataSet.Active;
  if FSaveActive then
  begin
    FDataSet.InternalClose;
    FDataSet.SetState(dsInactive);
  end;
  FDataSet.DisableControls;
end;

procedure TDataSetDesigner.DataEvent(Event: TDataEvent; Info: Longint);
begin
end;

procedure TDataSetDesigner.EndDesign;
begin
  FDataSet.EnableControls;
  if FSaveActive then
  begin
    try
      FDataSet.InternalOpen;
      FDataSet.SetState(dsBrowse);
    except
      FDataSet.SetState(dsInactive);
      FDataSet.CloseCursor;
      raise;
    end;
  end;
end;

{ TFieldDef }

constructor TFieldDef.Create(Owner: TFieldDefs; const Name: string;
  DataType: TFieldType; Size: Word; Required: Boolean; FieldNo: Integer);
begin
  CheckTypeSize(DataType, Size);
  if Owner <> nil then
  begin
    Owner.FItems.Add(Self);
    Owner.FUpdated := False;
    FOwner := Owner;
  end;
  FName := NewStr(Name);
  FDataType := DataType;
  FSize := Size;
  FRequired := Required;
  FFieldNo := FieldNo;
end;

destructor TFieldDef.Destroy;
begin
  DisposeStr(FName);
  if FOwner <> nil then
  begin
    FOwner.FItems.Remove(Self);
    FOwner.FUpdated := False;
  end;
end;

function TFieldDef.CreateField(Owner: TComponent): TField;
var
  FieldClass: TFieldClass;
begin
  FieldClass := GetFieldClass;
  if FieldClass = nil then DBErrorFmt(SUnknownFieldType, [FName^]);
  Result := FieldClass.Create(Owner);
  try
    Result.FieldName := FName^;
    Result.Size := FSize;
    Result.Required := FRequired;
    if FOwner <> nil then Result.DataSet := FOwner.FDataSet;
  except
    Result.Free;
    raise;
  end;
end;

function TFieldDef.GetFieldClass: TFieldClass;
const
  FieldClasses: array[TFieldType] of TFieldClass = (
    nil,                { ftUnknown }
    TStringField,       { ftString }
    TSmallintField,     { ftSmallint }
    TIntegerField,      { ftInteger }
    TWordField,         { ftWord }
    TBooleanField,      { ftBoolean }
    TFloatField,        { ftFloat }
    TCurrencyField,     { ftCurrency }
    TBCDField,          { ftBCD }
    TDateField,         { ftDate }
    TTimeField,         { ftTime }
    TDateTimeField,     { ftDateTime }
    TBytesField,        { ftBytes }
    TVarBytesField,     { ftVarBytes }
    TBlobField,         { ftBlob }
    TMemoField,         { ftMemo }
    TGraphicField);     { ftGraphic }
begin
  Result := FieldClasses[FDataType];
end;

function TFieldDef.GetName: string;
begin
  Result := FName^;
end;

{ TFieldDefs }

constructor TFieldDefs.Create(DataSet: TDataSet);
begin
  FDataSet := DataSet;
  FItems := TList.Create;
end;

destructor TFieldDefs.Destroy;
begin
  if FItems <> nil then Clear;
  FItems.Free;
end;

procedure TFieldDefs.Add(const Name: string; DataType: TFieldType;
  Size: Word; Required: Boolean);
begin
  if Name = '' then DBError(SFieldNameMissing);
  if IndexOf(Name) >= 0 then DBErrorFmt(SDuplicateFieldName, [Name]);
  TFieldDef.Create(Self, Name, DataType, Size, Required, FItems.Count + 1);
end;

procedure TFieldDefs.AddFieldDesc(FieldDesc: FLDDesc; Required: Boolean;
  FieldNo: Word);
const
  TypeMap: array[0..MAXLOGFLDTYPES - 1] of TFieldType = (
    ftUnknown, ftString, ftDate, ftBlob, ftBoolean, ftSmallint,
    ftInteger, ftFloat, ftBCD, ftBytes, ftTime, ftDateTime,
    ftWord, ftUnknown, ftUnknown, ftVarBytes, ftUnknown);
var
  DataType: TFieldType;
  Size: Word;
  I: Integer;
  FieldName: TSymbolStr;
  Name: string[DBIMAXNAMELEN + 4];
begin
  with FieldDesc do
  begin
    NativeToAnsi(FDataSet.Locale, szName, FieldName);
    I := 0;
    Name := FieldName;
    while IndexOf(Name) >= 0 do
    begin
      Inc(I);
      Name := Format('%s_%d', [FieldName, I]);
    end;
    if iFldType < MAXLOGFLDTYPES then
      DataType := TypeMap[iFldType] else
      DataType := ftUnknown;
    Size := 0;
    case iFldType of
      fldZSTRING, fldBYTES, fldVARBYTES:
        Size := iUnits1;
      fldINT16, fldUINT16:
        if iLen <> 2 then DataType := ftUnknown;
      fldFLOAT:
        if iSubType = fldstMONEY then DataType := ftCurrency;
      fldBCD:
        if iUnits1 = 32 then Size := iUnits2 else DataType := ftUnknown;
      fldBLOB:
        begin
          Size := iUnits1;
          case iSubType of
            fldstMEMO:
              DataType := ftMemo;
            fldstGRAPHIC:
              DataType := ftGraphic;
          end;
        end;
    end;
    if DataType <> ftUnknown then
      TFieldDef.Create(Self, Name, DataType, Size, Required, FieldNo);
  end;
end;

procedure TFieldDefs.Assign(FieldDefs: TFieldDefs);
var
  I: Integer;
begin
  Clear;
  for I := 0 to FieldDefs.Count - 1 do
    with FieldDefs[I] do Add(Name, DataType, Size, Required);
end;

procedure TFieldDefs.Clear;
begin
  while FItems.Count > 0 do TFieldDef(FItems.Last).Free;
end;

function TFieldDefs.Find(const Name: string): TFieldDef;
var
  I: Integer;
begin
  I := IndexOf(Name);
  if I < 0 then DBErrorFmt(SFieldNotFound, [Name]);
  Result := FItems[I];
end;

function TFieldDefs.GetCount: Integer;
begin
  Result := FItems.Count;
end;

function TFieldDefs.GetItem(Index: Integer): TFieldDef;
begin
  Result := FItems[Index];
end;

function TFieldDefs.IndexOf(const Name: string): Integer;
begin
  for Result := 0 to FItems.Count - 1 do
    if AnsiCompareText(TFieldDef(FItems[Result]).FName^, Name) = 0 then Exit;
  Result := -1;
end;

procedure TFieldDefs.Update;
begin
  FDataSet.UpdateFieldDefs;
end;

{ TDataSet }

constructor TDataSet.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FFieldDefs := TFieldDefs.Create(Self);
  FFields := TList.Create;
  FDataSources := TList.Create;
  FAutoCalcFields := True;
  ClearBuffers;
  FLocale := Session.Locale;
end;

destructor TDataSet.Destroy;
begin
  Destroying;
  Close;
  FDesigner.Free;
  while FDataSources.Count > 0 do RemoveDataSource(FDataSources.Last);
  FDataSources.Free;
  DestroyFields;
  FFields.Free;
  FFieldDefs.Free;
  inherited Destroy;
end;

procedure TDataSet.SetName(const Value: TComponentName);
var
  I: Integer;
  OldName, FieldName, NamePrefix: TComponentName;
  Field: TField;
begin
  OldName := Name;
  inherited SetName(Value);
  if (csDesigning in ComponentState) and (Name <> OldName) then
    { In design mode the name of the fields should track the data set name }
    for I := 0 to FFields.Count - 1 do
    begin
      Field := FFields[I];
      if Field.Owner = Owner then
      begin
        FieldName := Field.Name;
        NamePrefix := FieldName;
        if Length(NamePrefix) > Length(OldName) then
        begin
          NamePrefix[0] := Char(Length(OldName));
          if CompareText(OldName, NamePrefix) = 0 then
          begin
            System.Delete(FieldName, 1, Length(OldName));
            System.Insert(Value, FieldName, 1);
            try
              Field.Name := FieldName;
            except
              on EComponentError do {Ignore rename errors };
            end;
          end;
        end;
      end;
    end;
end;

procedure TDataSet.WriteComponents(Writer: TWriter);
var
  I: Integer;
  Field: TField;
begin
  for I := 0 to FFields.Count - 1 do
  begin
    Field := FFields[I];
    if Field.Owner = Writer.Root then Writer.WriteComponent(Field);
  end;
end;

procedure TDataSet.Loaded;
begin
  inherited Loaded;
  try
    if FStreamedActive then Active := True;
  except
    if csDesigning in ComponentState then
      Application.HandleException(Self)
    else
      raise;
  end;
end;

procedure TDataSet.SetState(Value: TDataSetState);
begin
  if FState <> Value then
  begin
    FState := Value;
    FModified := False;
    DataEvent(deUpdateState, 0);
  end;
end;

procedure TDataSet.Open;
begin
  Active := True;
end;

procedure TDataSet.Close;
begin
  Active := False;
end;

procedure TDataSet.CheckInactive;
begin
  if Active then DBError(SDataSetOpen);
end;

function TDataSet.GetActive: Boolean;
begin
  Result := State <> dsInactive;
end;

procedure TDataSet.SetActive(Value: Boolean);
var
  I: Integer;
begin
  if (csReading in ComponentState) then
  begin
    if Value then FStreamedActive := Value;
  end
  else
    if Active <> Value then
    begin
      if Value then
      begin
        DoBeforeOpen;
        try
          OpenCursor;
          SetState(dsBrowse);
        except
          SetState(dsInactive);
          CloseCursor;
          raise;
        end;
        DoAfterOpen;
      end else
      begin
        if not (csDestroying in ComponentState) then DoBeforeClose;
        SetState(dsInactive);
        CloseCursor;
        if not (csDestroying in ComponentState) then DoAfterClose;
      end;
    end;
end;

procedure TDataSet.OpenCursor;
var
  CursorLocale: TLocale;
begin
  FHandle := CreateHandle;
  if FHandle = nil then DBError(SHandleError);
  if DbiGetLdObj(FHandle, CursorLocale) = 0 then FLocale := CursorLocale;
  InternalOpen;
end;

procedure TDataSet.CloseCursor;
begin
  InternalClose;
  FLocale := Session.Locale;
  if FHandle <> nil then
  begin
    DbiCloseCursor(FHandle);
    FHandle := nil;
  end;
end;

function TDataSet.CreateHandle: HDBICur;
begin
  Result := nil;
end;

procedure TDataSet.InternalOpen;
var
  KeyIndex: TKeyIndex;
  I: Integer;
  FieldDescs: PFieldDescList;
  RequiredFields: set of 0..255;
  CursorProps: CurProps;
  ValCheckDesc: VCHKDesc;
begin
  DbiGetCursorProps(FHandle, CursorProps);
  FRecordSize := CursorProps.iRecBufSize;
  FBookmarkSize := CursorProps.iBookmarkSize;
  FCanModify := (CursorProps.eOpenMode = dbiReadWrite) and
    not CursorProps.bTempTable;
  RequiredFields := [];
  for I := 1 to CursorProps.iValChecks do
  begin
    DbiGetVChkDesc(FHandle, I, @ValCheckDesc);
    if ValCheckDesc.bRequired and not ValCheckDesc.bHasDefVal then
      Include(RequiredFields, ValCheckDesc.iFldNum - 1);
  end;
  FieldDescs := AllocMem(CursorProps.iFields * SizeOf(FLDDesc));
  try
    DbiGetFieldDescs(FHandle, PFLDDesc(FieldDescs));
    FieldDefs.Clear;
    for I := 0 to CursorProps.iFields - 1 do
      FieldDefs.AddFieldDesc(FieldDescs^[I], I in RequiredFields, I + 1);
  finally
    FreeMem(FieldDescs, CursorProps.iFields * SizeOf(FLDDesc));
  end;
  if not InfoQueryMode then
  begin
    GetIndexInfo;
    FDefaultFields := FFields.Count = 0;
    if FDefaultFields then CreateFields;
    BindFields(True);
    FBookmarkOfs := FRecordSize + FCalcFieldsSize;
    FRecBufSize := FBookmarkOfs + 1 + FBookmarkSize;
    for KeyIndex := Low(TKeyIndex) to High(TKeyIndex) do
      FKeyBuffers[KeyIndex] := InitKeyBuffer(
        AllocMem(SizeOf(TKeyBuffer) + FRecordSize));
    DbiSetToBegin(FHandle);
    PrepareCursor;
    UpdateBufferCount;
    FBOF := True;
  end;
end;

procedure TDataSet.InternalClose;
var
  KeyIndex: TKeyIndex;
begin
  if not InfoQueryMode then
  begin
    FreeFieldBuffers;
    SetBufListSize(0);
    FBufferCount := 0;
    ClearBuffers;
    for KeyIndex := Low(TKeyIndex) to High(TKeyIndex) do
      DisposeMem(FKeyBuffers[KeyIndex], SizeOf(TKeyBuffer) + FRecordSize);
    BindFields(False);
    if FDefaultFields then DestroyFields;
    FDefaultFields := False;
    FIndexFieldCount := 0;
  end;
  FCanModify := False;
end;

procedure TDataSet.GetIndexInfo;
var
  IndexDesc: IDXDesc;
begin
  if DbiGetIndexDesc(FHandle, 0, IndexDesc) = 0 then
    if not IndexDesc.bExpIdx then
    begin
      FIndexFieldCount := IndexDesc.iFldsInKey;
      FIndexFieldMap := IndexDesc.aiKeyFld;
    end;
end;

procedure TDataSet.PrepareCursor;
begin
end;

procedure TDataSet.CreateFields;
var
  I: Integer;
begin
  for I := 0 to FFieldDefs.Count - 1 do
    with FFieldDefs[I] do
      if DataType <> ftUnknown then CreateField(Self);
end;

procedure TDataSet.DestroyFields;
var
  Field: TField;
begin
  while FFields.Count > 0 do
  begin
    Field := FFields.Last;
    RemoveField(Field);
    Field.Free;
  end;
end;

procedure TDataSet.BindFields(Binding: Boolean);
const
  CalcFieldTypes = [ftString, ftSmallint, ftInteger, ftWord, ftBoolean,
    ftFloat, ftCurrency, ftDate, ftTime, ftDateTime];
  BaseTypes: array[TFieldType] of TFieldType = (
    ftUnknown, ftString, ftSmallint, ftInteger, ftWord,
    ftBoolean, ftFloat, ftFloat, ftBCD, ftDate, ftTime, ftDateTime,
    ftBytes, ftVarBytes, ftBlob, ftBlob, ftBlob);
var
  I: Integer;
  FieldDef: TFieldDef;
begin
  FCalcFieldsSize := 0;
  for I := 0 to FFields.Count - 1 do
    with TField(FFields[I]) do
      if Binding then
        if Calculated then
        begin
          if not (DataType in CalcFieldTypes) then
            DBErrorFmt(SInvalidCalcType, [DisplayName^]);
          FFieldNo := -1;
          FOffset := FCalcFieldsSize;
          Inc(FCalcFieldsSize, DataSize + 1);
        end else
        begin
          FieldDef := FieldDefs.Find(FFieldName^);
          if (BaseTypes[DataType] <> BaseTypes[FieldDef.DataType]) or
            (Size <> FieldDef.Size) then
            DBErrorFmt(SFieldTypeMismatch, [DisplayName^]);
          FFieldNo := FieldDef.FieldNo;
        end
      else
        FFieldNo := 0;
end;

procedure TDataSet.SwitchToIndex(IndexName, TagName: PChar);
var
  Status: DBIResult;
  CursorProps: CurProps;
begin
  UpdateCursorPos;
  Status := DbiSwitchToIndex(FHandle, IndexName, TagName, 0, True);
  if Status = DBIERR_NOCURRREC then
    Status := DbiSwitchToIndex(FHandle, IndexName, TagName, 0, False);
  Check(Status);
  SetBufListSize(0);
  FIndexFieldCount := 0;
  DbiGetCursorProps(FHandle, CursorProps);
  FBookmarkSize := CursorProps.iBookmarkSize;
  FRecBufSize := FBookmarkOfs + 1 + FBookmarkSize;
  try
    SetBufListSize(FBufferCount + 1);
  except
    SetState(dsInactive);
    CloseCursor;
    raise;
  end;
  GetIndexInfo;
end;

procedure TDataSet.FreeFieldBuffers;
var
  I: Integer;
begin
  for I := 0 to FFields.Count - 1 do TField(FFields[I]).FreeBuffers;
end;

procedure TDataSet.SetFieldDefs(Value: TFieldDefs);
begin
  FFieldDefs.Assign(Value);
end;

procedure TDataSet.UpdateFieldDefs;
begin
  if not FFieldDefs.FUpdated then
  begin
    InitFieldDefs;
    FFieldDefs.FUpdated := True;
  end;
end;

procedure TDataSet.InitFieldDefs;
begin
  if not Active then
    try
      FInfoQueryMode := True;
      OpenCursor;
    finally
      CloseCursor;
      FInfoQueryMode := False;
    end;
end;

procedure TDataSet.AddField(Field: TField);
begin
  FFields.Add(Field);
  Field.FDataSet := Self;
end;

procedure TDataSet.RemoveField(Field: TField);
begin
  Field.FDataSet := nil;
  FFields.Remove(Field);
end;

function TDataSet.GetFieldCount: Integer;
begin
  Result := FFields.Count;
end;

function TDataSet.GetField(Index: Integer): TField;
begin
  Result := FFields[Index];
end;

procedure TDataSet.SetField(Index: Integer; Value: TField);
begin
  TField(FFields[Index]).Assign(Value);
end;

function TDataSet.FieldByName(const FieldName: string): TField;
begin
  Result := FindField(FieldName);
  if Result = nil then DBErrorFmt(SFieldNotFound, [FieldName]);
end;

function TDataSet.FieldByNumber(FieldNo: Integer): TField;
var
  I: Integer;
begin
  for I := 0 to FFields.Count - 1 do
  begin
    Result := Fields[I];
    if Result.FieldNo = FieldNo then Exit;
  end;
  Result := nil;
end;

function TDataSet.FindField(const FieldName: string): TField;
var
  I: Integer;
begin
  for I := 0 to FFields.Count - 1 do
  begin
    Result := FFields[I];
    if AnsiCompareText(Result.FFieldName^, FieldName) = 0 then Exit;
  end;
  Result := nil;
end;

procedure TDataSet.CheckFieldName(const FieldName: string);
begin
  if FieldName = '' then DBError(SFieldNameMissing);
  if FindField(FieldName) <> nil then
    DBErrorFmt(SDuplicateFieldName, [FieldName]);
end;

function TDataSet.GetIndexField(Index: Integer): TField;
var
  FieldNo: Integer;
begin
  if (Index < 0) or (Index >= FIndexFieldCount) then
    DBError(SFieldIndexError);
  FieldNo := FIndexFieldMap[Index];
  Result := FieldByNumber(FieldNo);
  if Result = nil then
    DBErrorFmt(SIndexFieldMissing, [FFieldDefs[FieldNo - 1].FName^]);
end;

procedure TDataSet.SetIndexField(Index: Integer; Value: TField);
begin
  GetIndexField(Index).Assign(Value);
end;

function TDataSet.GetIndexFieldCount: Integer;
begin
  Result := FIndexFieldCount;
end;

procedure TDataSet.GetFieldNames(List: TStrings);
var
  I: Integer;
begin
  List.BeginUpdate;
  try
    List.Clear;
    if FFields.Count > 0 then
      for I := 0 to FFields.Count - 1 do
        List.Add(TField(FFields[I]).FFieldName^)
    else
    begin
      UpdateFieldDefs;
      for I := 0 to FFieldDefs.Count - 1 do
        List.Add(FFieldDefs[I].FName^);
    end;
  finally
    List.EndUpdate;
  end;
end;

function TDataSet.GetDataSource: TDataSource;
begin
  Result := nil;
end;

function TDataSet.IsLinkedTo(DataSource: TDataSource): Boolean;
var
  DataSet: TDataSet;
begin
  Result := True;
  while DataSource <> nil do
  begin
    DataSet := DataSource.DataSet;
    if DataSet = nil then Break;
    if DataSet = Self then Exit;
    DataSource := DataSet.DataSource;
  end;
  Result := False;
end;

procedure TDataSet.AddDataSource(DataSource: TDataSource);
begin
  FDataSources.Add(DataSource);
  DataSource.FDataSet := Self;
  UpdateBufferCount;
  DataSource.UpdateState;
end;

procedure TDataSet.RemoveDataSource(DataSource: TDataSource);
begin
  DataSource.FDataSet := nil;
  FDataSources.Remove(DataSource);
  DataSource.UpdateState;
  UpdateBufferCount;
end;

procedure TDataSet.SetBufListSize(Value: Integer);
var
  I: Integer;
  NewList: PBufferList;
begin
  if FBufListSize <> Value then
  begin
    GetMem(NewList, Value * SizeOf(Pointer));
    if FBufListSize > Value then
    begin
      if Value <> 0 then
        Move(FBuffers^, NewList^, Value * SizeOf(Pointer));
      for I := Value to FBufListSize - 1 do
        FreeMem(FBuffers^[I], FRecBufSize);
    end else
    begin
      if FBufListSize <> 0 then
        Move(FBuffers^, NewList^, FBufListSize * SizeOf(Pointer));
      try
        for I := FBufListSize to Value - 1 do
          GetMem(NewList^[I], FRecBufSize);
      except
        for I := FBufListSize to I - 1 do
          FreeMem(NewList^[I], FRecBufSize);
        FreeMem(NewList, Value * SizeOf(Pointer));
        raise;
      end;
    end;
    FreeMem(FBuffers, FBufListSize * SizeOf(Pointer));
    FBuffers := NewList;
    FBufListSize := Value;
  end;
end;

procedure TDataSet.SetBufferCount(Value: Integer);
var
  I, Delta: Integer;
  DataLink: TDataLink;

  procedure AdjustFirstRecord(Delta: Integer);
  var
    DataLink: TDataLink;
  begin
    if Delta <> 0 then
    begin
      DataLink := FFirstDataLink;
      while DataLink <> nil do
      begin
        Inc(DataLink.FFirstRecord, Delta);
        DataLink := DataLink.FNext;
      end;
    end;
  end;

begin
  if FBufferCount <> Value then
  begin
    if (FBufferCount > Value) and (FRecordCount > 0) then
    begin
      Delta := FActiveRecord;
      DataLink := FFirstDataLink;
      while DataLink <> nil do
      begin
        if DataLink.FFirstRecord < Delta then Delta := DataLink.FFirstRecord;
        DataLink := DataLink.FNext;
      end;
      for I := 0 to Value - 1 do MoveBuffer(I + Delta, I);
      Dec(FActiveRecord, Delta);
      if FCurrentRecord <> -1 then Dec(FCurrentRecord, Delta);
      if FRecordCount > Value then FRecordCount := Value;
      AdjustFirstRecord(-Delta);
    end;
    SetBufListSize(Value + 1);
    FBufferCount := Value;
    GetNextRecords;
    AdjustFirstRecord(GetPriorRecords);
  end;
end;

procedure TDataSet.UpdateBufferCount;
var
  I, J, MaxBufferCount: Integer;
  DataLink: TDataLink;
begin
  if FHandle <> nil then
  begin
    MaxBufferCount := 1;
    FFirstDataLink := nil;
    for I := FDataSources.Count - 1 downto 0 do
      with TDataSource(FDataSources[I]) do
        for J := FDataLinks.Count - 1 downto 0 do
        begin
          DataLink := FDataLinks[J];
          DataLink.FNext := FFirstDataLink;
          FFirstDataLink := DataLink;
          if DataLink.FBufferCount > MaxBufferCount then
            MaxBufferCount := DataLink.FBufferCount;
        end;
    SetBufferCount(MaxBufferCount);
  end;
end;

procedure TDataSet.InitRecord(Buffer: PChar);
begin
  DbiInitRecord(FHandle, Buffer);
  FillChar(Buffer[FRecordSize], FCalcFieldsSize, 0);
end;

function TDataSet.InitKeyBuffer(Buffer: PKeyBuffer): PKeyBuffer;
begin
  FillChar(Buffer^, SizeOf(TKeyBuffer) + FRecordSize, 0);
  DbiInitRecord(FHandle, PChar(Buffer) + SizeOf(TKeyBuffer));
  Result := Buffer;
end;

procedure TDataSet.DataEvent(Event: TDataEvent; Info: Longint);
var
  I: Integer;
begin
  case Event of
    deFieldChange:
      begin
        if not TField(Info).Calculated then FModified := True;
        if State <> dsSetKey then
        begin
          if (FCalcFieldsSize <> 0) and FAutoCalcFields and
            not TField(Info).Calculated then
          begin
            FillChar(ActiveBuffer[FRecordSize], FCalcFieldsSize, 0);
            DoOnCalcFields;
          end;
          TField(Info).Change;
        end;
      end;
    dePropertyChange:
      FFieldDefs.FUpdated := False;
  end;
  if FDisableCount = 0 then
  begin
    for I := 0 to FDataSources.Count - 1 do
      TDataSource(FDataSources[I]).DataEvent(Event, Info);
    if FDesigner <> nil then FDesigner.DataEvent(Event, Info);
  end else
    if (Event = deUpdateState) and (State = dsInactive) or
      (Event = deLayoutChange) then FEnableEvent := deLayoutChange;
end;

procedure TDataSet.DisableControls;
begin
  if FDisableCount = 0 then
  begin
    FDisableState := FState;
    FEnableEvent := deDataSetChange;
  end;
  Inc(FDisableCount);
end;

procedure TDataSet.EnableControls;
begin
  if FDisableCount <> 0 then
  begin
    Dec(FDisableCount);
    if FDisableCount = 0 then
    begin
      if FDisableState <> FState then DataEvent(deUpdateState, 0);
      if (FDisableState <> dsInactive) and (FState <> dsInactive) then
        DataEvent(FEnableEvent, 0);
    end;
  end;
end;

procedure TDataSet.UpdateRecord;
begin
  if not (State in dsEditModes) then DBError(SNotEditing);
  DataEvent(deUpdateRecord, 0);
end;

procedure TDataSet.MoveBuffer(CurIndex, NewIndex: Integer);
var
  Buffer: PChar;
begin
  if CurIndex <> NewIndex then
  begin
    Buffer := FBuffers^[CurIndex];
    if CurIndex < NewIndex then
      Move(FBuffers^[CurIndex + 1], FBuffers^[CurIndex],
        (NewIndex - CurIndex) * SizeOf(Pointer))
    else
      Move(FBuffers^[NewIndex], FBuffers^[NewIndex + 1],
        (CurIndex - NewIndex) * SizeOf(Pointer));
    FBuffers^[NewIndex] := Buffer;
  end;
end;

procedure TDataSet.CopyBuffer(SourceIndex, DestIndex: Integer);
begin
  Move(FBuffers^[SourceIndex]^, FBuffers^[DestIndex]^, FRecBufSize);
end;

function TDataSet.ActiveBuffer: PChar;
begin
  Result := FBuffers^[FActiveRecord];
end;

procedure TDataSet.ClearBuffers;
begin
  FRecordCount := 0;
  FActiveRecord := 0;
  FCurrentRecord := -1;
  FBOF := True;
  FEOF := True;
end;

procedure TDataSet.ActivateBuffers;
begin
  FRecordCount := 1;
  FActiveRecord := 0;
  FCurrentRecord := 0;
  FBOF := False;
  FEOF := False;
end;

procedure TDataSet.GetCalcFields(Index: Integer);
var
  SaveState: TDataSetState;
begin
  if FCalcFieldsSize <> 0 then
  try
    SaveState := FState;
    FState := dsCalcFields;
    FCalcBuffer := FBuffers^[Index];
    FillChar(FCalcBuffer[FRecordSize], FCalcFieldsSize, 0);
    DoOnCalcFields;
  finally
    FState := SaveState;
  end;
end;

function TDataSet.GetRecord(Index: Integer; GetMode: TGetMode): DBIResult;
var
  Buffer: PChar;
begin
  Buffer := FBuffers^[Index];
  case GetMode of
    gmCurrent:
      Result := DbiGetRecord(FHandle, dbiNoLock, Buffer, nil);
    gmNext:
      Result := DbiGetNextRecord(FHandle, dbiNoLock, Buffer, nil);
    gmPrior:
      Result := DbiGetPriorRecord(FHandle, dbiNoLock, Buffer, nil);
  else
    Result := 0;
  end;
  if Result = 0 then
  begin
    GetCalcFields(Index);
    Buffer[FBookmarkOfs] := #0;
    Check(DbiGetBookmark(FHandle, Buffer + FBookmarkOfs + 1));
  end;
end;

procedure TDataSet.SetCurrentRecord(Index: Integer);
var
  Buffer: PChar;
begin
  if FCurrentRecord <> Index then
  begin
    Buffer := FBuffers^[Index];
    case Buffer[FBookmarkOfs] of
      #0: Check(DbiSetToBookmark(FHandle, Buffer + FBookmarkOfs + 1));
      #1: Check(DbiSetToBegin(FHandle));
      #2: Check(DbiSetToEnd(FHandle));
    end;
    FCurrentRecord := Index;
  end;
end;

procedure TDataSet.UpdateCursorPos;
begin
  if FRecordCount > 0 then SetCurrentRecord(FActiveRecord);
end;

procedure TDataSet.CursorPosChanged;
begin
  FCurrentRecord := -1;
end;

function TDataSet.GetCurrentRecord(Buffer: PChar): Boolean;
begin
  Result := False;
  if (State in [dsBrowse, dsEdit]) and (FActiveRecord < FRecordCount) then
  begin
    if FCurrentRecord <> FActiveRecord then
    begin
      if DbiSetToBookmark(FHandle, FBuffers^[FActiveRecord] +
        FBookmarkOfs + 1) <> 0 then Exit;
      FCurrentRecord := FActiveRecord;
    end;
    if DbiGetRecord(FHandle, dbiNoLock, Buffer, nil) = 0 then Result := True;
  end;
end;

function TDataSet.GetNextRecord: Boolean;
var
  GetMode: TGetMode;
  Status: DBIResult;
begin
  GetMode := gmNext;
  if FRecordCount > 0 then
  begin
    SetCurrentRecord(FRecordCount - 1);
    if (State = dsInsert) and (FCurrentRecord = FActiveRecord) and
      (ActiveBuffer[FBookmarkOfs] = #0) then GetMode := gmCurrent;
  end;
  Status := GetRecord(FRecordCount, GetMode);
  case Status of
    DBIERR_NONE:
      begin
        if FRecordCount = 0 then
          ActivateBuffers
        else
          if FRecordCount < FBufferCount then
            Inc(FRecordCount)
          else
            MoveBuffer(0, FRecordCount);
        FCurrentRecord := FRecordCount - 1;
        Result := True;
      end;
    DBIERR_EOF:
      begin
        FCurrentRecord := -1;
        Result := False;
      end;
  else
    DbiError(Status);
  end;
end;

function TDataSet.GetPriorRecord: Boolean;
var
  Status: DBIResult;
  Buffer: PChar;
begin
  if FRecordCount > 0 then SetCurrentRecord(0);
  Status := GetRecord(FRecordCount, gmPrior);
  case Status of
    DBIERR_NONE:
      begin
        if FRecordCount = 0 then
          ActivateBuffers
        else
        begin
          MoveBuffer(FRecordCount, 0);
          if FRecordCount < FBufferCount then
          begin
            Inc(FRecordCount);
            Inc(FActiveRecord);
          end;
        end;
        FCurrentRecord := 0;
        Result := True;
      end;
    DBIERR_BOF:
      begin
        FCurrentRecord := -1;
        Result := False;
      end;
  else
    DbiError(Status);
  end;
end;

function TDataSet.GetNextRecords: Integer;
begin
  Result := 0;
  try
    while (FRecordCount < FBufferCount) and GetNextRecord do Inc(Result);
  except
  end;
end;

function TDataSet.GetPriorRecords: Integer;
begin
  Result := 0;
  try
    while (FRecordCount < FBufferCount) and GetPriorRecord do Inc(Result);
  except
  end;
end;

procedure TDataSet.Resync(Mode: TResyncMode);
var
  Count: Integer;
begin
  if rmExact in Mode then
  begin
    FCurrentRecord := -1;
    Check(GetRecord(FRecordCount, gmCurrent));
  end else
    if (GetRecord(FRecordCount, gmCurrent) <> 0) and
      (GetRecord(FRecordCount, gmNext) <> 0) and
      (GetRecord(FRecordCount, gmPrior) <> 0) then
    begin
      ClearBuffers;
      DataEvent(deDataSetChange, 0);
      Exit;
    end;
  if rmCenter in Mode then
    Count := (FBufferCount - 1) div 2 else
    Count := FActiveRecord;
  MoveBuffer(FRecordCount, 0);
  ActivateBuffers;
  try
    while (Count > 0) and GetPriorRecord do Dec(Count);
    GetNextRecords;
    GetPriorRecords;
  except
  end;
  DataEvent(deDataSetChange, 0);
end;

procedure TDataSet.CheckBrowseMode;
begin
  if State = dsInactive then DBError(SDataSetClosed);
  DataEvent(deCheckBrowseMode, 0);
  case State of
    dsEdit, dsInsert:
      begin
        UpdateRecord;
        if Modified then Post else Cancel;
      end;
    dsSetKey:
      Post;
  end;
end;

procedure TDataSet.CheckSetKeyMode;
begin
  if State <> dsSetKey then DBError(SNotEditing);
end;

procedure TDataSet.CheckCanModify;
begin
  if not CanModify then DBError(SDataSetReadOnly);
end;

procedure TDataSet.First;
begin
  CheckBrowseMode;
  ClearBuffers;
  try
    Check(DbiSetToBegin(FHandle));
    GetNextRecord;
    GetNextRecords;
  finally
    FBOF := True;
    DataEvent(deDataSetChange, 0);
  end;
end;

procedure TDataSet.Last;
begin
  CheckBrowseMode;
  ClearBuffers;
  try
    Check(DbiSetToEnd(FHandle));
    GetPriorRecord;
    GetPriorRecords;
  finally
    FEOF := True;
    DataEvent(deDataSetChange, 0);
  end;
end;

procedure TDataSet.MoveBy(Distance: Integer);
var
  I, ScrollCount: Integer;
begin
  CheckBrowseMode;
  if ((Distance > 0) and not FEOF) or ((Distance < 0) and not FBOF) then
  begin
    FBOF := False;
    FEOF := False;
    ScrollCount := 0;
    try
      while Distance > 0 do
      begin
        if FActiveRecord < FRecordCount - 1 then Inc(FActiveRecord) else
        begin
          if FRecordCount < FBufferCount then I := 0 else I := 1;
          if GetNextRecord then Dec(ScrollCount, I) else
          begin
            FEOF := True;
            Break;
          end;
        end;
        Dec(Distance);
      end;
      while Distance < 0 do
      begin
        if FActiveRecord > 0 then Dec(FActiveRecord) else
        begin
          if FRecordCount < FBufferCount then I := 0 else I := 1;
          if GetPriorRecord then Inc(ScrollCount, I) else
          begin
            FBOF := True;
            Break;
          end;
        end;
        Inc(Distance);
      end;
    finally
      DataEvent(deDataSetScroll, ScrollCount);
    end;
  end;
end;

procedure TDataSet.Next;
begin
  MoveBy(1);
end;

procedure TDataSet.Prior;
begin
  MoveBy(-1);
end;

procedure TDataSet.Refresh;
begin
  CheckBrowseMode;
  UpdateCursorPos;
  Check(DbiForceReread(FHandle));
  Resync([]);
end;

procedure TDataSet.SetFields(const Values: array of const);
var
  I: Integer;
begin
  for I := 0 to High(Values) do Fields[I].AssignValue(Values[I]);
end;

procedure TDataSet.Insert;
var
  Buffer: PChar;
begin
  BeginInsertAppend;
  MoveBuffer(FRecordCount, FActiveRecord);
  Buffer := ActiveBuffer;
  InitRecord(Buffer);
  if FRecordCount = 0 then
    Buffer[FBookmarkOfs] := #1
  else
    Move(FBuffers^[FActiveRecord + 1][FBookmarkOfs], Buffer[FBookmarkOfs],
      FBookmarkSize + 1);
  if FRecordCount < FBufferCount then Inc(FRecordCount);
  EndInsertAppend;
end;

procedure TDataSet.Append;
var
  Buffer: PChar;
begin
  BeginInsertAppend;
  ClearBuffers;
  Buffer := FBuffers^[0];
  InitRecord(Buffer);
  Buffer[FBookmarkOfs] := #2;
  FRecordCount := 1;
  FBOF := False;
  GetPriorRecords;
  EndInsertAppend;
end;

procedure TDataSet.BeginInsertAppend;
begin
  CheckBrowseMode;
  CheckCanModify;
  DoBeforeInsert;
end;

procedure TDataSet.EndInsertAppend;
begin
  SetState(dsInsert);
  try
    DoOnNewRecord;
  except
    UpdateCursorPos;
    FreeFieldBuffers;
    SetState(dsBrowse);
    Resync([]);
    raise;
  end;
  FModified := False;
  DataEvent(deDataSetChange, 0);
  DoAfterInsert;
end;

procedure TDataSet.AddRecord(const Values: array of const; Append: Boolean);
var
  Buffer: PChar;
begin
  BeginInsertAppend;
  if not Append then UpdateCursorPos;
  DisableControls;
  try
    MoveBuffer(FRecordCount, FActiveRecord);
    try
      Buffer := ActiveBuffer;
      InitRecord(Buffer);
      FState := dsInsert;
      try
        DoOnNewRecord;
        DoAfterInsert;
        SetFields(Values);
        DoBeforePost;
        if Append then
          Check(DbiAppendRecord(FHandle, Buffer)) else
          Check(DbiInsertRecord(FHandle, dbiNoLock, Buffer));
      finally
        FreeFieldBuffers;
        FState := dsBrowse;
      end;
    except
      MoveBuffer(FActiveRecord, FRecordCount);
      raise;
    end;
    Resync([]);
    DoAfterPost;
  finally
    EnableControls;
  end;
end;

procedure TDataSet.InsertRecord(const Values: array of const);
begin
  AddRecord(Values, False);
end;

procedure TDataSet.AppendRecord(const Values: array of const);
begin
  AddRecord(Values, True);
end;

procedure TDataSet.Edit;
begin
  if not (State in [dsEdit, dsInsert]) then
    if FRecordCount = 0 then Insert else
    begin
      CheckBrowseMode;
      CheckCanModify;
      DoBeforeEdit;
      UpdateCursorPos;
      Check(DbiGetRecord(FHandle, dbiWriteLock, ActiveBuffer, nil));
      GetCalcFields(FActiveRecord);
      SetState(dsEdit);
      DataEvent(deRecordChange, 0);
      DoAfterEdit;
    end;
end;

procedure TDataSet.ClearFields;
begin
  if not (State in dsEditModes) then DBError(SNotEditing);
  DataEvent(deCheckBrowseMode, 0);
  DbiInitRecord(FHandle, ActiveBuffer);
  if State <> dsSetKey then GetCalcFields(FActiveRecord);
  DataEvent(deRecordChange, 0);
end;

procedure TDataSet.CheckRequiredFields;
const
  CheckTypes = [ftString, ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat,
  ftCurrency, ftBCD, ftDate, ftTime, ftDateTime, ftBytes, ftVarBytes];
var
  I: Integer;
begin
  for I := 0 to FFields.Count - 1 do
    with TField(FFields[I]) do
      if Required and not ReadOnly and not Calculated and
        (DataType in CheckTypes) and IsNull then
      begin
        FocusControl;
        DBErrorFmt(SFieldRequired, [DisplayName^]);
      end;
end;

procedure TDataSet.Post;
var
  Buffer: PChar;
begin
  UpdateRecord;
  case State of
    dsEdit, dsInsert:
      begin
        DataEvent(deCheckBrowseMode, 0);
        CheckRequiredFields;
        DoBeforePost;
        Buffer := ActiveBuffer;
        UpdateCursorPos;
        if State = dsEdit then
          Check(DbiModifyRecord(FHandle, Buffer, True)) else
          Check(DbiInsertRecord(FHandle, dbiNoLock, Buffer));
        FreeFieldBuffers;
        SetState(dsBrowse);
        Resync([]);
        DoAfterPost;
      end;
    dsSetKey:
      PostKeyBuffer(True);
  end;
end;

procedure TDataSet.Cancel;
begin
  case State of
    dsEdit, dsInsert:
      begin
        DataEvent(deCheckBrowseMode, 0);
        DoBeforeCancel;
        UpdateCursorPos;
        if State = dsEdit then DbiRelRecordLock(FHandle, False);
        FreeFieldBuffers;
        SetState(dsBrowse);
        Resync([]);
        DoAfterCancel;
      end;
    dsSetKey:
      PostKeyBuffer(False);
  end;
end;

procedure TDataSet.Delete;
var
  Status: DBIResult;
begin
  if State = dsInactive then DBError(SDataSetClosed);
  if State in [dsInsert, dsSetKey] then Cancel else
  begin
    if FRecordCount = 0 then DBError(SDataSetEmpty);
    DataEvent(deCheckBrowseMode, 0);
    DoBeforeDelete;
    UpdateCursorPos;
    Status := DbiDeleteRecord(FHandle, nil);
    if (Status <> 0) and (Hi(Status) <> ERRCAT_NOTFOUND) then DbiError(Status);
    FreeFieldBuffers;
    SetState(dsBrowse);
    Resync([]);
    DoAfterDelete;
  end;
end;

function TDataSet.GetBookmark: TBookmark;
begin
  Result := nil;
  if (State = dsBrowse) and (FRecordCount > 0) then
  begin
    Result := StrAlloc(FBookmarkSize);
    Move(ActiveBuffer[FBookmarkOfs + 1], Result^, FBookmarkSize);
  end;
end;

procedure TDataSet.GotoBookmark(Bookmark: TBookmark);
begin
  if Bookmark <> nil then
  begin
    CheckBrowseMode;
    Check(DbiSetToBookmark(FHandle, Bookmark));
    Resync([rmExact, rmCenter]);
  end;
end;

procedure TDataSet.FreeBookmark(Bookmark: TBookmark);
begin
  StrDispose(Bookmark);
end;

function TDataSet.GetKeyBuffer(KeyIndex: TKeyIndex): PKeyBuffer;
begin
  Result := FKeyBuffers[KeyIndex];
end;

procedure TDataSet.SetKeyBuffer(KeyIndex: TKeyIndex; Clear: Boolean);
begin
  CheckBrowseMode;
  FKeyBuffer := FKeyBuffers[KeyIndex];
  Move(FKeyBuffer^, FKeyBuffers[kiSave]^, SizeOf(TKeyBuffer) + FRecordSize);
  if Clear then InitKeyBuffer(FKeyBuffer);
  SetState(dsSetKey);
  DataEvent(deDataSetChange, 0);
end;

procedure TDataSet.PostKeyBuffer(Commit: Boolean);
begin
  DataEvent(deCheckBrowseMode, 0);
  if Commit then
    FKeyBuffer^.Modified := FModified
  else
    Move(FKeyBuffers[kiSave]^, FKeyBuffer^, SizeOf(TKeyBuffer) + FRecordSize);
  SetState(dsBrowse);
  DataEvent(deDataSetChange, 0);
end;

function TDataSet.GetKeyExclusive: Boolean;
begin
  CheckSetKeyMode;
  Result := FKeyBuffer^.Exclusive;
end;

procedure TDataSet.SetKeyExclusive(Value: Boolean);
begin
  CheckSetKeyMode;
  FKeyBuffer^.Exclusive := Value;
end;

function TDataSet.GetKeyFieldCount: Integer;
begin
  CheckSetKeyMode;
  Result := FKeyBuffer^.FieldCount;
end;

procedure TDataSet.SetKeyFieldCount(Value: Integer);
begin
  CheckSetKeyMode;
  FKeyBuffer^.FieldCount := Value;
end;

procedure TDataSet.SetKeyFields(KeyIndex: TKeyIndex;
  const Values: array of const);
var
  I: Integer;
begin
  Inc(FDisableCount);
  FState := dsSetKey;
  FModified := False;
  FKeyBuffer := InitKeyBuffer(FKeyBuffers[KeyIndex]);
  try
    for I := 0 to High(Values) do GetIndexField(I).AssignValue(Values[I]);
    FKeyBuffer^.FieldCount := High(Values) + 1;
    FKeyBuffer^.Modified := FModified;
  finally
    FState := dsBrowse;
    Dec(FDisableCount);
  end;
end;

function TDataSet.SetCursorRange: Boolean;
var
  RangeStart, RangeEnd: PKeyBuffer;
  StartKey, EndKey: PChar;
begin
  Result := False;
  if not (
    BuffersEqual(FKeyBuffers[kiRangeStart], FKeyBuffers[kiCurRangeStart],
    SizeOf(TKeyBuffer) + FRecordSize) and
    BuffersEqual(FKeyBuffers[kiRangeEnd], FKeyBuffers[kiCurRangeEnd],
    SizeOf(TKeyBuffer) + FRecordSize)) then
  begin
    RangeStart := FKeyBuffers[kiRangeStart];
    if RangeStart^.Modified then
      StartKey := PChar(RangeStart) + SizeOf(TKeyBuffer) else
      StartKey := nil;
    RangeEnd := FKeyBuffers[kiRangeEnd];
    if RangeEnd^.Modified then
      EndKey := PChar(RangeEnd) + SizeOf(TKeyBuffer) else
      EndKey := nil;
    Check(DbiSetRange(FHandle, False,
      RangeStart^.FieldCount, 0, StartKey, not RangeStart^.Exclusive,
      RangeEnd^.FieldCount, 0, EndKey, not RangeEnd^.Exclusive));
    Move(FKeyBuffers[kiRangeStart]^, FKeyBuffers[kiCurRangeStart]^,
      SizeOf(TKeyBuffer) + FRecordSize);
    Move(FKeyBuffers[kiRangeEnd]^, FKeyBuffers[kiCurRangeEnd]^,
      SizeOf(TKeyBuffer) + FRecordSize);
    Result := True;
  end;
end;

function TDataSet.ResetCursorRange: Boolean;
begin
  Result := False;
  if FKeyBuffers[kiCurRangeStart]^.Modified or
    FKeyBuffers[kiCurRangeEnd]^.Modified then
  begin
    Check(DbiResetRange(FHandle));
    InitKeyBuffer(FKeyBuffers[kiCurRangeStart]);
    InitKeyBuffer(FKeyBuffers[kiCurRangeEnd]);
    Result := True;
  end;
end;

procedure TDataSet.SetLinkRanges(MasterFields: TList);
var
  SaveState: TDataSetState;
  I: Integer;
begin
  Inc(FDisableCount);
  SaveState := FState;
  FState := dsSetKey;
  try
    FKeyBuffer := InitKeyBuffer(FKeyBuffers[kiRangeStart]);
    FKeyBuffer^.Modified := True;
    for I := 0 to MasterFields.Count - 1 do
      GetIndexField(I).Assign(TField(MasterFields[I]));
    FKeyBuffer^.FieldCount := MasterFields.Count;
  finally
    FState := SaveState;
    Dec(FDisableCount);
  end;
  Move(FKeyBuffers[kiRangeStart]^, FKeyBuffers[kiRangeEnd]^,
    SizeOf(TKeyBuffer) + FRecordSize);
end;

function TDataSet.GetRecordCount: Longint;
begin
  if State = dsInactive then DBError(SDataSetClosed);
  Check(DbiGetRecordCount(FHandle, Result));
end;

procedure TDataSet.DoAfterCancel;
begin
  if Assigned(FAfterCancel) then FAfterCancel(Self);
end;

procedure TDataSet.DoAfterClose;
begin
  if Assigned(FAfterClose) then FAfterClose(Self);
end;

procedure TDataSet.DoAfterDelete;
begin
  if Assigned(FAfterDelete) then FAfterDelete(Self);
end;

procedure TDataSet.DoAfterEdit;
begin
  if Assigned(FAfterEdit) then FAfterEdit(Self);
end;

procedure TDataSet.DoAfterInsert;
begin
  if Assigned(FAfterInsert) then FAfterInsert(Self);
end;

procedure TDataSet.DoAfterOpen;
begin
  if Assigned(FAfterOpen) then FAfterOpen(Self);
end;

procedure TDataSet.DoAfterPost;
begin
  if Assigned(FAfterPost) then FAfterPost(Self);
end;

procedure TDataSet.DoBeforeCancel;
begin
  if Assigned(FBeforeCancel) then FBeforeCancel(Self);
end;

procedure TDataSet.DoBeforeClose;
begin
  if Assigned(FBeforeClose) then FBeforeClose(Self);
end;

procedure TDataSet.DoBeforeDelete;
begin
  if Assigned(FBeforeDelete) then FBeforeDelete(Self);
end;

procedure TDataSet.DoBeforeEdit;
begin
  if Assigned(FBeforeEdit) then FBeforeEdit(Self);
end;

procedure TDataSet.DoBeforeInsert;
begin
  if Assigned(FBeforeInsert) then FBeforeInsert(Self);
end;

procedure TDataSet.DoBeforeOpen;
begin
  if Assigned(FBeforeOpen) then FBeforeOpen(Self);
end;

procedure TDataSet.DoBeforePost;
begin
  if Assigned(FBeforePost) then FBeforePost(Self);
end;

procedure TDataSet.DoOnCalcFields;
begin
  if Assigned(FOnCalcFields) then FOnCalcFields(Self);
end;

procedure TDataSet.DoOnNewRecord;
begin
  if Assigned(FOnNewRecord) then FOnNewRecord(Self);
end;

{ TDBDataSet }

procedure TDBDataSet.OpenCursor;
begin
  SetDBFlag(dbfOpened, True);
  inherited OpenCursor;
  if FDataBase.IsSQLBased and CanModify then
    Check(DbiSetProp(hDbiObj(FHandle), curUPDLOCKMODE, LongInt(FUpdateMode)));
end;

procedure TDBDataSet.CloseCursor;
begin
  inherited CloseCursor;
  SetDBFlag(dbfOpened, False);
end;

procedure TDBDataSet.Disconnect;
begin
  Close;
end;

function TDBDataSet.GetDBFlag(Flag: Integer): Boolean;
begin
  Result := Flag in FDBFlags;
end;

procedure TDBDataSet.SetDBFlag(Flag: Integer; Value: Boolean);
begin
  if Value then
  begin
    if not (Flag in FDBFlags) then
    begin
      if FDBFlags = [] then
      begin
        FDatabase := Session.OpenDatabase(FDatabaseName);
        FDatabase.FDatasets.Add(Self);
        FLocale := FDatabase.Locale;
      end;
      Include(FDBFlags, Flag);
    end;
  end else
  begin
    if Flag in FDBFlags then
    begin
      Exclude(FDBFlags, Flag);
      if FDBFlags = [] then
      begin
        FLocale := Session.Locale;
        FDatabase.FDatasets.Remove(Self);
        Session.CloseDatabase(FDatabase);
        FDatabase := nil;
      end;
    end;
  end;
end;

function TDBDataSet.GetDBHandle: HDBIDB;
begin
  if FDatabase <> nil then
    Result := FDatabase.Handle else
    Result := nil;
end;

function TDBDataSet.GetDBLocale: TLocale;
begin
  if FDatabase <> nil then
    Result := FDatabase.Locale else
    Result := Session.Locale;
end;

procedure TDBDataSet.SetDatabaseName(const Value: TFileName);
begin
  if FDatabase <> nil then DBError(SDatabaseOpen);
  FDatabaseName := Value;
  DataEvent(dePropertyChange, 0);
end;

{ TField }

constructor TField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FVisible := True;
  FFieldName := NullStr;
  FDisplayLabel := NullStr;
  FEditMask := NullStr;
end;

destructor TField.Destroy;
begin
  if FDataSet <> nil then
  begin
    FDataSet.Close;
    FDataSet.RemoveField(Self);
  end;
  DisposeStr(FEditMask);
  DisposeStr(FDisplayLabel);
  DisposeStr(FFieldName);
  inherited Destroy;
end;

procedure TField.AccessError(const TypeName: string);
begin
  DBErrorFmt(SFieldAccessError, [DisplayName^, TypeName]);
end;

procedure TField.Assign(Source: TPersistent);
var
  Buffer: array[0..255] of Char;
begin
  if Source = nil then
  begin
    Clear;
    Exit;
  end;
  if Source is TField then
  begin
    if (FieldNo = 0) or (TField(Source).FieldNo = 0) or
      (DataType <> TField(Source).DataType) or
      (Size <> TField(Source).Size) or
      (DataType = ftBlob) or (DataSize > 256) then
      DBErrorFmt(SFieldAssignError, [DisplayName^,
        TField(Source).DisplayName^]);
    if TField(Source).GetData(@Buffer) then
      SetData(@Buffer) else
      SetData(nil);
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TField.AssignValue(const Value: TVarRec);

  procedure Error;
  begin
    DBErrorFmt(SFieldValueError, [DisplayName^]);
  end;

begin
  with Value do
    case VType of
      vtInteger:
        AsInteger := VInteger;
      vtBoolean:
        AsBoolean := VBoolean;
      vtChar:
        AsString := VChar;
      vtExtended:
        AsFloat := VExtended^;
      vtString:
        AsString := VString^;
      vtPointer:
        if VPointer <> nil then Error;
      vtPChar:
        AsString := StrPas(VPChar);
      vtObject:
        if (VObject = nil) or (VObject is TPersistent) then
          Assign(TPersistent(VObject))
        else
          Error;
    else
      Error;
    end;
end;

procedure TField.Change;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TField.CheckInactive;
begin
  if (FDataSet <> nil) and FDataSet.Active then DBError(SDataSetOpen);
end;

procedure TField.Clear;
begin
  SetData(nil);
end;

procedure TField.DataChanged;
begin
  FDataSet.DataEvent(deFieldChange, Longint(Self));
end;

procedure TField.FocusControl;
var
  Field: TField;
begin
  if (FDataSet <> nil) and FDataSet.Active then
  begin
    Field := Self;
    FDataSet.DataEvent(deFocusControl, Longint(@Field));
  end;
end;

procedure TField.FreeBuffers;
begin
end;

function TField.GetAsBoolean: Boolean;
begin
  AccessError('Boolean');
end;

function TField.GetAsDateTime: TDateTime;
begin
  AccessError('DateTime');
end;

function TField.GetAsFloat: Double;
begin
  AccessError('Float');
end;

function TField.GetAsInteger: Longint;
begin
  AccessError('Integer');
end;

function TField.GetAsString: string;
var
  I, L: Integer;
  S: string[63];
begin
  S := ClassName;
  I := 1;
  L := Length(S);
  if S[1] = 'T' then I := 2;
  if (L >= 5) and (CompareText(Copy(S, L - 4, 5), 'FIELD') = 0) then Dec(L, 5);
  FmtStr(Result, '(%s)', [Copy(S, I, L + 1 - I)]);
end;

function TField.GetCanModify: Boolean;
begin
  if FieldNo > 0 then
    if DataSet.State <> dsSetKey then
      Result := not ReadOnly and DataSet.CanModify
    else
      Result := (DataSet.FIndexFieldCount = 0) or IsIndexField
  else
    Result := False;
end;

function TField.GetData(Buffer: Pointer): Boolean;
var
  IsBlank: WordBool;
  RecBuf: PChar;
begin
  if FDataSet = nil then DBErrorFmt(SDataSetMissing, [DisplayName^]);
  Result := False;
  with FDataSet do
  begin
    case State of
      dsSetKey: RecBuf := PChar(FKeyBuffer) + SizeOf(TKeyBuffer);
      dsCalcFields: RecBuf := FCalcBuffer;
    else
      if FActiveRecord >= FRecordCount then Exit;
      RecBuf := FBuffers^[FActiveRecord];
    end;
    if FieldNo > 0 then
      if FValidating then
      begin
        Result := LongBool(FValueBuffer);
        if Result and (Buffer <> nil) then
          Move(FValueBuffer^, Buffer^, DataSize);
      end else
      begin
        Check(DbiGetField(FHandle, FieldNo, RecBuf, Buffer, IsBlank));
        Result := not IsBlank;
      end
    else
      if (FieldNo < 0) and (State <> dsSetKey) then
      begin
        Inc(RecBuf, FRecordSize + FOffset);
        Result := Boolean(RecBuf[0]);
        if Result and (Buffer <> nil) then
          Move(RecBuf[1], Buffer^, DataSize);
      end;
  end;
end;

function TField.GetDefaultWidth: Integer;
begin
  Result := 10;
end;

function TField.GetDisplayLabel: string;
begin
  Result := GetDisplayName^;
end;

function TField.GetDisplayName: PString;
begin
  if FDisplayLabel^ <> '' then
    Result := FDisplayLabel else
    Result := FFieldName;
end;

function TField.GetDisplayText: string;
begin
  Result := '';
  if Assigned(FOnGetText) then
    FOnGetText(Self, Result, True) else
    GetText(Result, True);
end;

function TField.GetDisplayWidth: Integer;
begin
  if FDisplayWidth > 0 then
    Result := FDisplayWidth else
    Result := GetDefaultWidth;
end;

function TField.GetEditMask: string;
begin
  Result := FEditMask^;
end;

function TField.GetEditText: string;
begin
  Result := '';
  if Assigned(FOnGetText) then
    FOnGetText(Self, Result, False) else
    GetText(Result, False);
end;

function TField.GetFieldName: string;
begin
  Result := FFieldName^;
end;

function TField.GetIndex: Integer;
begin
  if FDataSet <> nil then
    Result := FDataSet.FFields.IndexOf(Self) else
    Result := -1;
end;

function TField.GetIsIndexField: Boolean;
var
  I: Integer;
begin
  Result := False;
  if FFieldNo > 0 then
    for I := 0 to FDataSet.FIndexFieldCount - 1 do
      if FDataSet.FIndexFieldMap[I] = FFieldNo then
      begin
        Result := True;
        Exit;
      end;
end;

function TField.GetIsNull: Boolean;
begin
  Result := not GetData(nil);
end;

procedure TField.GetText(var Text: string; DisplayText: Boolean);
begin
  Text := GetAsString;
end;

function TField.HasParent: Boolean;
begin
  HasParent := True;
end;

function TField.IsValidChar(InputChar: Char): Boolean;
begin
  Result := True;
end;

function TField.IsDisplayLabelStored: Boolean;
begin
  Result := FDisplayLabel^ <> '';
end;

function TField.IsDisplayWidthStored: Boolean;
begin
  Result := FDisplayWidth > 0;
end;

procedure TField.PropertyChanged(LayoutAffected: Boolean);
const
  Events: array[Boolean] of TDataEvent = (deDataSetChange, deLayoutChange);
begin
  if (FDataSet <> nil) and FDataSet.Active then
    FDataSet.DataEvent(Events[LayoutAffected], 0);
end;

procedure TField.ReadState(Reader: TReader);
begin
  inherited ReadState(Reader);
  if Reader.Parent is TDataSet then DataSet := TDataSet(Reader.Parent);
end;

procedure TField.SetAsBoolean(Value: Boolean);
begin
  AccessError('Boolean');
end;

procedure TField.SetAsDateTime(Value: TDateTime);
begin
  AccessError('DateTime');
end;

procedure TField.SetAsFloat(Value: Double);
begin
  AccessError('Float');
end;

procedure TField.SetAsInteger(Value: Longint);
begin
  AccessError('Integer');
end;

procedure TField.SetAsString(const Value: string);
begin
  AccessError('String');
end;

procedure TField.SetAlignment(Value: TAlignment);
begin
  if FAlignment <> Value then
  begin
    FAlignment := Value;
    PropertyChanged(False);
  end;
end;

procedure TField.SetCalculated(Value: Boolean);
begin
  CheckInactive;
  FCalculated := Value;
end;

procedure TField.SetData(Buffer: Pointer);
var
  RecBuf: PChar;
begin
  if FDataSet = nil then DBErrorFmt(SDataSetMissing, [DisplayName^]);
  with FDataSet do
  begin
    if State = dsSetKey then
    begin
      RecBuf := PChar(FKeyBuffer) + SizeOf(TKeyBuffer);
      if (FieldNo < 0) or (FIndexFieldCount > 0) and not IsIndexField then
        DBErrorFmt(SNotIndexField, [DisplayName^]);
    end else
    begin
      case State of
        dsCalcFields: RecBuf := FCalcBuffer;
        dsEdit, dsInsert: RecBuf := FBuffers^[FActiveRecord];
      else
        DBError(SNotEditing);
      end;
      if ReadOnly then DBErrorFmt(SFieldReadOnly, [DisplayName^]);
    end;
    if FieldNo > 0 then
    begin
      if State = dsCalcFields then DBError(SNotEditing);
      if Assigned(FOnValidate) then
      begin
        FValueBuffer := Buffer;
        FValidating := True;
        try
          FOnValidate(Self);
        finally
          FValidating := False;
        end;
      end;
      Check(DbiPutField(FHandle, FieldNo, RecBuf, Buffer));
    end else
    begin
      Inc(RecBuf, FRecordSize + FOffset);
      Boolean(RecBuf[0]) := LongBool(Buffer);
      if Boolean(RecBuf[0]) then Move(Buffer^, RecBuf[1], DataSize);
    end;
    if State <> dsCalcFields then DataEvent(deFieldChange, Longint(Self));
  end;
end;

procedure TField.SetDataSet(ADataSet: TDataSet);
begin
  if FDataSet <> nil then FDataSet.CheckInactive;
  if ADataSet <> nil then
  begin
    ADataSet.CheckInactive;
    ADataSet.CheckFieldName(FFieldName^);
  end;
  if FDataSet <> nil then FDataSet.RemoveField(Self);
  if ADataSet <> nil then ADataSet.AddField(Self);
end;

procedure TField.SetDataType(Value: TFieldType);
begin
  FDataType := Value;
  UpdateDataSize;
end;

procedure TField.SetDisplayLabel(Value: string);
begin
  if Value = FFieldName^ then Value := '';
  if FDisplayLabel^ <> Value then
  begin
    AssignStr(FDisplayLabel, Value);
    PropertyChanged(True);
  end;
end;

procedure TField.SetDisplayWidth(Value: Integer);
begin
  if FDisplayWidth <> Value then
  begin
    FDisplayWidth := Value;
    PropertyChanged(True);
  end;
end;

procedure TField.SetEditMask(const Value: string);
begin
  AssignStr(FEditMask, Value);
  PropertyChanged(False);
end;

procedure TField.SetEditText(const Value: string);
begin
  if Assigned(FOnSetText) then FOnSetText(Self, Value) else SetText(Value);
end;

procedure TField.SetFieldName(const Value: string);
begin
  CheckInactive;
  if FDataSet <> nil then FDataSet.CheckFieldName(Value);
  AssignStr(FFieldName, Value);
  if FDisplayLabel^ = Value then AssignStr(FDisplayLabel, '');
  if FDataSet <> nil then FDataSet.DataEvent(deFieldListChange, 0);
end;

procedure TField.SetIndex(Value: Integer);
var
  CurIndex, Count: Integer;
begin
  CurIndex := GetIndex;
  if CurIndex >= 0 then
  begin
    Count := FDataSet.FFields.Count;
    if Value < 0 then Value := 0;
    if Value >= Count then Value := Count - 1;
    if Value <> CurIndex then
    begin
      FDataSet.FFields.Delete(CurIndex);
      FDataSet.FFields.Insert(Value, Self);
      PropertyChanged(True);
      FDataSet.DataEvent(deFieldListChange, 0);
    end;
  end;
end;

procedure TField.SetSize(Value: Word);
begin
  CheckInactive;
  CheckTypeSize(DataType, Value);
  FSize := Value;
  UpdateDataSize;
end;

procedure TField.SetText(const Value: string);
begin
  SetAsString(Value);
end;

procedure TField.SetVisible(Value: Boolean);
begin
  if FVisible <> Value then
  begin
    FVisible := Value;
    PropertyChanged(True);
  end;
end;

procedure TField.UpdateDataSize;
begin
  case FDataType of
    ftSmallint, ftWord, ftBoolean:
      FDataSize := 2;
    ftInteger, ftDate, ftTime:
      FDataSize := 4;
    ftFloat, ftCurrency, ftDateTime:
      FDataSize := 8;
    ftBCD:
      FDataSize := 18;
    ftBytes, ftVarBytes:
      FDataSize := Size;
    ftString:
      FDataSize := Size + 1;
  else
    FDataSize := 0;
  end;
end;

{ TDataSource }

constructor TDataSource.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDataLinks := TList.Create;
  FEnabled := True;
  FAutoEdit := True;
end;

destructor TDataSource.Destroy;
begin
  FOnStateChange := nil;
  SetDataSet(nil);
  while FDataLinks.Count > 0 do RemoveDataLink(FDataLinks.Last);
  FDataLinks.Free;
  inherited Destroy;
end;

procedure TDataSource.Edit;
begin
  if AutoEdit and (State = dsBrowse) then DataSet.Edit;
end;

procedure TDataSource.SetState(Value: TDataSetState);
var
  PriorState: TDataSetState;
begin
  if FState <> Value then
  begin
    PriorState := FState;
    FState := Value;
    NotifyDataLinks(deUpdateState, 0);
    if not (csDestroying in ComponentState) then
    begin
      if Assigned(FOnStateChange) then FOnStateChange(Self);
      if PriorState = dsInactive then
        if Assigned(FOnDataChange) then FOnDataChange(Self, nil);
    end;
  end;
end;

procedure TDataSource.UpdateState;
begin
  if Enabled and (DataSet <> nil) then
    SetState(DataSet.State) else
    SetState(dsInactive);
end;

function TDataSource.IsLinkedTo(DataSet: TDataSet): Boolean;
var
  DataSource: TDataSource;
begin
  Result := True;
  while DataSet <> nil do
  begin
    DataSource := DataSet.GetDataSource;
    if DataSource = nil then Break;
    if DataSource = Self then Exit;
    DataSet := DataSource.DataSet;
  end;
  Result := False;
end;

procedure TDataSource.SetDataSet(ADataSet: TDataSet);
begin
  if IsLinkedTo(ADataSet) then DBError(SCircularDataLink);
  if FDataSet <> nil then FDataSet.RemoveDataSource(Self);
  if ADataSet <> nil then ADataSet.AddDataSource(Self);
end;

procedure TDataSource.SetEnabled(Value: Boolean);
begin
  FEnabled := Value;
  UpdateState;
end;

procedure TDataSource.AddDataLink(DataLink: TDataLink);
begin
  FDataLinks.Add(DataLink);
  DataLink.FDataSource := Self;
  if DataSet <> nil then DataSet.UpdateBufferCount;
  DataLink.UpdateState;
end;

procedure TDataSource.RemoveDataLink(DataLink: TDataLink);
begin
  DataLink.FDataSource := nil;
  FDataLinks.Remove(DataLink);
  DataLink.UpdateState;
  if DataSet <> nil then DataSet.UpdateBufferCount;
end;

procedure TDataSource.NotifyDataLinks(Event: TDataEvent; Info: Longint);
var
  I: Integer;
begin
  for I := 0 to FDataLinks.Count - 1 do
    TDataLink(FDataLinks[I]).DataEvent(Event, Info);
end;

procedure TDataSource.DataEvent(Event: TDataEvent; Info: Longint);
begin
  if Event = deUpdateState then UpdateState else
    if FState <> dsInactive then
    begin
      NotifyDataLinks(Event, Info);
      case Event of
        deFieldChange:
          if Assigned(FOnDataChange) then FOnDataChange(Self, TField(Info));
        deRecordChange, deDataSetChange, deDataSetScroll, deLayoutChange:
          if Assigned(FOnDataChange) then FOnDataChange(Self, nil);
        deUpdateRecord:
          if Assigned(FOnUpdateData) then FOnUpdateData(Self);
      end;
    end;
end;

{ TDataLink }

constructor TDataLink.Create;
begin
  inherited Create;
  FBufferCount := 1;
end;

destructor TDataLink.Destroy;
begin
  FActive := False;
  FEditing := False;
  SetDataSource(nil);
  inherited Destroy;
end;

procedure TDataLink.UpdateRange;
var
  Min, Max: Integer;
begin
  Min := DataSet.FActiveRecord - FBufferCount + 1;
  if Min < 0 then Min := 0;
  Max := DataSet.FBufferCount - FBufferCount;
  if Max < 0 then Max := 0;
  if Max > DataSet.FActiveRecord then Max := DataSet.FActiveRecord;
  if FFirstRecord < Min then FFirstRecord := Min;
  if FFirstRecord > Max then FFirstRecord := Max;
end;

function TDataLink.GetDataSet: TDataSet;
begin
  if DataSource <> nil then Result := DataSource.DataSet else Result := nil;
end;

procedure TDataLink.SetDataSource(ADataSource: TDataSource);
begin
  if FDataSource <> nil then FDataSource.RemoveDataLink(Self);
  if ADataSource <> nil then ADataSource.AddDataLink(Self);
end;

procedure TDataLink.SetReadOnly(Value: Boolean);
begin
  if FReadOnly <> Value then
  begin
    FReadOnly := Value;
    UpdateState;
  end;
end;

procedure TDataLink.SetActive(Value: Boolean);
begin
  if FActive <> Value then
  begin
    FActive := Value;
    if Value then UpdateRange else FFirstRecord := 0;
    ActiveChanged;
  end;
end;

procedure TDataLink.SetEditing(Value: Boolean);
begin
  if FEditing <> Value then
  begin
    FEditing := Value;
    EditingChanged;
  end;
end;

procedure TDataLink.UpdateState;
begin
  SetActive((DataSource <> nil) and (DataSource.State <> dsInactive));
  SetEditing((DataSource <> nil) and (DataSource.State in dsEditModes) and
    not FReadOnly);
end;

procedure TDataLink.UpdateRecord;
begin
  FUpdating := True;
  try
    UpdateData;
  finally
    FUpdating := False;
  end;
end;

function TDataLink.Edit: Boolean;
begin
  if not FReadOnly and (DataSource <> nil) then DataSource.Edit;
  Result := FEditing;
end;

function TDataLink.GetActiveRecord: Integer;
begin
  if DataSource.State = dsSetKey then
    Result := 0 else
    Result := DataSource.DataSet.FActiveRecord - FFirstRecord;
end;

procedure TDataLink.SetActiveRecord(Value: Integer);
begin
  if DataSource.State <> dsSetKey then
    DataSource.DataSet.FActiveRecord := Value + FFirstRecord;
end;

procedure TDataLink.SetBufferCount(Value: Integer);
begin
  if FBufferCount <> Value then
  begin
    FBufferCount := Value;
    if Active then
    begin
      UpdateRange;
      DataSet.UpdateBufferCount;
      UpdateRange;
    end;
  end;
end;

function TDataLink.GetRecordCount: Integer;
begin
  if DataSource.State = dsSetKey then Result := 1 else
  begin
    Result := DataSource.DataSet.FRecordCount;
    if Result > FBufferCount then Result := FBufferCount;
  end;
end;

procedure TDataLink.DataEvent(Event: TDataEvent; Info: Longint);
var
  Active, First, Last, Count: Integer;
begin
  if Event = deUpdateState then UpdateState else
    if FActive then
      case Event of
        deFieldChange, deRecordChange:
          if not FUpdating then RecordChanged(TField(Info));
        deDataSetChange, deDataSetScroll, deLayoutChange:
          begin
            Count := 0;
            if DataSource.State <> dsSetKey then
            begin
              Active := DataSource.DataSet.FActiveRecord;
              First := FFirstRecord + Info;
              Last := First + FBufferCount - 1;
              if Active > Last then Count := Active - Last else
                if Active < First then Count := Active - First;
              FFirstRecord := First + Count;
            end;
            case Event of
              deDataSetChange: DataSetChanged;
              deDataSetScroll: DataSetScrolled(Count);
              deLayoutChange: LayoutChanged;
            end;
          end;
        deUpdateRecord:
          UpdateRecord;
        deCheckBrowseMode:
          CheckBrowseMode;
        deFocusControl:
          FocusControl(TFieldRef(Info));
      end;
end;

procedure TDataLink.ActiveChanged;
begin
end;

procedure TDataLink.CheckBrowseMode;
begin
end;

procedure TDataLink.DataSetChanged;
begin
  RecordChanged(nil);
end;

procedure TDataLink.DataSetScrolled(Distance: Integer);
begin
  DataSetChanged;
end;

procedure TDataLink.EditingChanged;
begin
end;

procedure TDataLink.FocusControl(Field: TFieldRef);
begin
end;

procedure TDataLink.LayoutChanged;
begin
  DataSetChanged;
end;

procedure TDataLink.RecordChanged(Field: TField);
begin
end;

procedure TDataLink.UpdateData;
begin
end;

{ Initialization and termination }

procedure DoneSession; far;
begin
  Session.Free;
end;

begin
  Session := TSession.Create(nil);
  AddExitProc(DoneSession);
end.
