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

unit DBTables;

{$N+,P+,S-}

interface

uses SysUtils, WinTypes, WinProcs, DbiErrs, DbiTypes, DbiProcs,
  Classes, Controls, Graphics, Mask, DB;

type

{ TIndexDef }

  TIndexDefs = class;

  TIndexOptions = set of (ixPrimary, ixUnique, ixDescending,
    ixCaseInsensitive, ixExpression);

  TIndexDef = class
  private
    FOwner: TIndexDefs;
    FName: PString;
    FFields: PString;
    FOptions: TIndexOptions;
    function GetExpression: string;
    function GetFields: string;
    function GetName: string;
  public
    constructor Create(Owner: TIndexDefs; const Name, Fields: string;
      Options: TIndexOptions);
    destructor Destroy; override;
    property Expression: string read GetExpression;
    property Fields: string read GetFields;
    property Name: string read GetName;
    property Options: TIndexOptions read FOptions;
  end;

{ TIndexDefs }

  TTable = class;

  TIndexDefs = class
  private
    FTable: TTable;
    FItems: TList;
    FUpdated: Boolean;
    FReserved: Byte;
    function GetCount: Integer;
    function GetItem(Index: Integer): TIndexDef;
  public
    constructor Create(Table: TTable);
    destructor Destroy; override;
    procedure Add(const Name, Fields: string; Options: TIndexOptions);
    procedure Assign(IndexDefs: TIndexDefs);
    procedure Clear;
    function FindIndexForFields(const Fields: string): TIndexDef;
    function IndexOf(const Name: string): Integer;
    procedure Update;
    property Count: Integer read GetCount;
    property Items[Index: Integer]: TIndexDef read GetItem; default;
  end;

{ TTableDataLink }

  TTableDataLink = class(TDataLink)
  private
    FTable: TTable;
    FFieldNames: PString;
    FFields: TList;
    procedure SetFieldNames(const Value: string);
  protected
    procedure ActiveChanged; override;
    procedure CheckBrowseMode; override;
    procedure LayoutChanged; override;
    procedure RecordChanged(Field: TField); override;
  public
    constructor Create(Table: TTable);
    destructor Destroy; override;
  end;

{ TTable }

  TBatchMode = (batAppend, batUpdate, batAppendUpdate, batDelete, batCopy);
  TTableType = (ttDefault, ttParadox, ttDBase, ttASCII);
  TLockType = (ltReadLock, ltWriteLock);
  TIndexName = string[127];

  TTable = class(TDBDataSet)
  private
    FIndexDefs: TIndexDefs;
    FDataLink: TTableDataLink;
    FExclusive: Boolean;
    FReadOnly: Boolean;
    FTableType: TTableType;
    FFieldsIndex: Boolean;
    FTableName: TFileName;
    FIndexName: TIndexName;
    procedure DecodeIndexDesc(const IndexDesc: IDXDesc;
      var Name, Fields: string; var Options: TIndexOptions);
    procedure EncodeFieldDesc(var FieldDesc: FLDDesc;
      const Name: string; DataType: TFieldType; Size: Word);
    procedure EncodeIndexDesc(var IndexDesc: IDXDesc;
      const Name, Fields: string; Options: TIndexOptions);
    function GetDriverTypeName(Buffer: PChar): PChar;
    function GetIndexFieldNames: string;
    function GetIndexName: string;
    procedure GetIndexParams(const IndexName: string; FieldsIndex: Boolean;
      PIndexName, PIndexTag: PChar);
    function GetMasterFields: string;
    function GetTableTypeName: PChar;
    function IsDBaseTable: Boolean;
    procedure MasterChanged;
    procedure SetDataSource(Value: TDataSource);
    procedure SetExclusive(Value: Boolean);
    procedure SetIndex(const Value: string; FieldsIndex: Boolean);
    procedure SetIndexFieldNames(const Value: string);
    procedure SetIndexName(const Value: string);
    procedure SetMasterFields(const Value: string);
    procedure SetReadOnly(Value: Boolean);
    procedure SetTableLock(LockType: TLockType; Lock: Boolean);
    procedure SetTableName(const Value: TFileName);
    procedure SetTableType(Value: TTableType);
    procedure UpdateIndexDefs;
    procedure UpdateRange;
  protected
    function CreateHandle: HDBICur; override;
    procedure DataEvent(Event: TDataEvent; Info: Longint); override;
    procedure DoOnNewRecord; override;
    function GetDataSource: TDataSource; override;
    procedure InitFieldDefs; override;
    procedure PrepareCursor; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function BatchMove(ASource: TDataSet; AMode: TBatchMode): Longint;
    procedure AddIndex(const Name, Fields: string; Options: TIndexOptions);
    procedure ApplyRange;
    procedure CancelRange;
    procedure CreateTable;
    procedure DeleteIndex(const Name: string);
    procedure DeleteTable;
    procedure EditKey;
    procedure EditRangeEnd;
    procedure EditRangeStart;
    procedure EmptyTable;
    function FindKey(const KeyValues: array of const): Boolean;
    procedure FindNearest(const KeyValues: array of const);
    procedure GetIndexNames(List: TStrings);
    procedure GotoCurrent(Table: TTable);
    function GotoKey: Boolean;
    procedure GotoNearest;
    procedure LockTable(LockType: TLockType);
    procedure RenameTable(const NewTableName: string);
    procedure SetKey;
    procedure SetRange(const StartValues, EndValues: array of const);
    procedure SetRangeEnd;
    procedure SetRangeStart;
    procedure UnlockTable(LockType: TLockType);
    property IndexDefs: TIndexDefs read FIndexDefs;
    property IndexFieldCount: Integer read GetIndexFieldCount;
    property IndexFields[Index: Integer]: TField read GetIndexField write SetIndexField;
    property KeyExclusive: Boolean read GetKeyExclusive write SetKeyExclusive;
    property KeyFieldCount: Integer read GetKeyFieldCount write SetKeyFieldCount;
  published
    property Exclusive: Boolean read FExclusive write SetExclusive default False;
    property IndexFieldNames: string read GetIndexFieldNames write SetIndexFieldNames;
    property IndexName: string read GetIndexName write SetIndexName;
    property MasterFields: string read GetMasterFields write SetMasterFields;
    property MasterSource: TDataSource read GetDataSource write SetDataSource;
    property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
    property TableName: TFileName read FTableName write SetTableName;
    property TableType: TTableType read FTableType write SetTableType default ttDefault;
    property UpdateMode;
  end;

{ TBatchMove }

  TBatchMove = class(TComponent)
  private
    FDestination: TTable;
    FSource: TDataSet;
    FMode: TBatchMode;
    FAbortOnKeyViol: Boolean;
    FAbortOnProblem: Boolean;
    FTransliterate: Boolean;
    FRecordCount: Longint;
    FMovedCount: Longint;
    FKeyViolCount: Longint;
    FProblemCount: Longint;
    FChangedCount: Longint;
    FMappings: TStrings;
    FKeyViolTableName: TFileName;
    FProblemTableName: TFileName;
    FChangedTableName: TFileName;
    function ConvertName(const Name: string; Buffer: PChar): PChar;
    procedure SetMappings(Value: TStrings);
  protected
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Execute;
  public
    property ChangedCount: Longint read FChangedCount;
    property KeyViolCount: Longint read FKeyViolCount;
    property MovedCount: Longint read FMovedCount;
    property ProblemCount: Longint read FProblemCount;
  published
    property AbortOnKeyViol: Boolean read FAbortOnKeyViol write FAbortOnKeyViol default True;
    property AbortOnProblem: Boolean read FAbortOnProblem write FAbortOnProblem default True;
    property ChangedTableName: TFileName read FChangedTableName write FChangedTableName;
    property Destination: TTable read FDestination write FDestination;
    property KeyViolTableName: TFileName read FKeyViolTableName write FKeyViolTableName;
    property Mappings: TStrings read FMappings write SetMappings;
    property Mode: TBatchMode read FMode write FMode default batAppend;
    property ProblemTableName: TFileName read FProblemTableName write FProblemTableName;
    property RecordCount: Longint read FRecordCount write FRecordCount default 0;
    property Source: TDataSet read FSource write FSource;
    property Transliterate: Boolean read FTransliterate write FTransliterate default True;
  end;

{ TParam }

  TQuery = class;
  TParams = class;

  TParamType = (ptUnknown, ptInput, ptOutput, ptInputOutput, ptResult);

  TParamRec = record
    case TFieldType of
      ftBoolean: (FBoolean: WordBool);
      ftCurrency,
      ftBCD,
      ftFloat: (FFloat: Double);
      ftDateTime,
      ftTime,
      ftDate: (FDateTime: TDateTime);
      ftSmallint,
      ftWord,
      ftInteger: (FInteger: LongInt);
  end;

  TParam = class(TObject)
  private
    FParamList: TParams;
    FData: TParamRec;
    FName: PString;
    FString: PString;
    FDataType: TFieldType;
    FNull: Boolean;
    FBound: Boolean;
    FParamType: TParamType;
    procedure AccessError;
    procedure InitValue;
    function IsValidInt(const Value: string; var RetValue: LongInt): Boolean;
    function IsValidFloat(const Value: string; var RetValue: Double): Boolean;
  protected
    procedure SetAsBoolean(Value: Boolean);
    procedure SetAsFloat(Value: Double);
    procedure SetAsInteger(Value: Longint);
    procedure SetAsString(const Value: string);
    procedure SetAsDate(Value: TDateTime);
    procedure SetAsTime(Value: TDateTime);
    procedure SetAsDateTime(Value: TDateTime);
    procedure SetAsWord(Value: LongInt);
    procedure SetAsSmallInt(Value: LongInt);
    procedure SetAsCurrency(Value: Double);
    procedure SetAsBCD(Value: Double);
    function GetAsBoolean: Boolean;
    function GetAsFloat: Double;
    function GetAsInteger: Longint;
    function GetAsString: string;
    function GetAsDateTime: TDateTime;
    function GetParamName: string;
    procedure SetDataType(Value: TFieldType);
    procedure SetParamName(const Value: string);
    procedure SetText(const Value: string);
  public
    constructor Create(AParamList: TParams; AParamType: TParamType);
    destructor Destroy; override;
    procedure Assign(Param: TParam);
    procedure AssignField(Field: TField);
    procedure GetData(Buffer: Pointer);
    function GetDataSize: Word;
    procedure SetData(Buffer: Pointer);
    procedure Clear;
    property Name: string read GetParamName write SetParamName;
    property DataType: TFieldType read FDataType write SetDataType;
    property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;
    property AsFloat: Double read GetAsFloat write SetAsFloat;
    property AsInteger: LongInt read GetAsInteger write SetAsInteger;
    property AsString: string read GetAsString write SetAsString;
    property AsDate: TDateTime read GetAsDateTime write SetAsDate;
    property AsTime: TDateTime read GetAsDateTime write SetAsTime;
    property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
    property AsSmallInt: LongInt read GetAsInteger write SetAsSmallInt;
    property AsWord: LongInt read GetAsInteger write SetAsWord;
    property AsCurrency: Double read GetAsFloat write SetAsCurrency;
    property AsBCD: Double read GetAsFloat write SetAsBCD;
    property IsNull: Boolean read FNull;
    property ParamType: TParamType read FParamType write FParamType;
    property Bound: Boolean read FBound write FBound;
    property Text: string read GetAsString write SetText;
  end;

{ TParams }

  TParams = class(TPersistent)
  private
    FItems: TList;
    function GetParam(Index: Word): TParam;
    function GetVersion: Integer;
    procedure ReadBinaryData(Stream: TStream);
    procedure WriteBinaryData(Stream: TStream);
  protected
    procedure DefineProperties(Filer: TFiler); override;
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure AssignValues(Value: TParams);
    procedure AddParam(Value: TParam);
    procedure RemoveParam(Value: TParam);
    function CreateParam(FldType: TFieldType; const ParamName: string;
      ParamType: TParamType): TParam;
    function Count: Integer;
    procedure Clear;
    function ParamByName(const Value: string): TParam;
    property Items[Index: Word]: TParam read GetParam; default;
  end;

{ TStoredProc }

  PServerDesc = ^TServerDesc;
  TServerDesc = record
    ParamName: string[DBIMAXSPNAMELEN];
    BindType: TFieldType;
  end;

  TParamBindMode = (pbByName, pbByNumber);

  TStoredProc = class(TDBDataSet)
  private
    FStmtHandle: HDBIStmt;
    FProcName: PString;
    FParams: TParams;
    FParamDesc: PChar;
    FRecordBuffer: PChar;
    FOverLoad: Word;
    FPrepared: Boolean;
    FQueryMode: Boolean;
    FServerDescs: PChar;
    FBindMode: TParamBindMode;
    procedure BindParams;
    function CheckServerParams: Boolean;
    function CreateCursor(GenHandle: Boolean): HDBICur;
    procedure CreateParamDesc;
    procedure FreeStatement;
    function GetCursor(GenHandle: Boolean): HDBICur;
    procedure PrepareProc;
    procedure SetParamsList(Value: TParams);
    procedure SetServerParams;
  protected
    function CreateHandle: HDBICur; override;
    procedure Disconnect; override;
    function GetProcName: string;
    function GetParamsCount: Word;
    procedure SetDBFlag(Flag: Integer; Value: Boolean); override;
    procedure SetOverLoad(Value: Word);
    procedure SetProcName(const Value: string);
    procedure SetPrepared(Value: Boolean);
    procedure SetPrepare(Value: Boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CopyParams(Value: TParams);
    function DescriptionsAvailable: Boolean;
    procedure ExecProc;
    function ParamByName(const Value: string): TParam;
    procedure Prepare;
    procedure GetResults;
    procedure UnPrepare;
    property ParamCount: Word read GetParamsCount;
    property StmtHandle: HDBIStmt read FStmtHandle;
    property Prepared: Boolean read FPrepared write SetPrepare;
  published
    property StoredProcName: string read GetProcName write SetProcName;
    property Overload: Word read FOverload write SetOverload default 0;
    property Params: TParams read FParams write SetParamsList;
    property ParamBindMode: TParamBindMode read FBindMode write FBindMode default pbByName;
  end;

{ TQuery }

  TQuery = class(TDBDataSet)
  private
    FStmtHandle: HDBIStmt;
    FSQL: TStrings;
    FPrepared: Boolean;
    FParams: TParams;
    FText: PChar;
    FDataLink: TDataLink;
    FLocal: Boolean;
    FUniDirectional: Boolean;
    FRequestLive: Boolean;
    FSQLBinary: PChar;
    function CreateCursor(GenHandle: Boolean): HDBICur;
    procedure CreateParams(List: TParams; const Value: PChar);
    procedure DefineProperties(Filer: TFiler); override;
    procedure FreeStatement;
    function GetQueryCursor(GenHandle: Boolean): HDBICur;
    procedure GetStatementHandle(SQLText: PChar);
    function GetSQLText: PChar;
    procedure PrepareSQL(Value: PChar);
    procedure QueryChanged(Sender: TObject);
    procedure ReadBinaryData(Stream: TStream);
    procedure RefreshParams;
    procedure SetDataSource(Value: TDataSource);
    procedure SetQuery(Value: TStrings);
    procedure SetParamsList(Value: TParams);
    procedure SetParams;
    procedure SetParamsFromCursor;
    procedure SetPrepared(Value: Boolean);
    procedure SetPrepare(Value: Boolean);
    procedure WriteBinaryData(Stream: TStream);
  protected
    function CreateHandle: HDBICur; override;
    procedure Disconnect; override;
    function GetDataSource: TDataSource; override;
    function GetParamsCount: Word;
    procedure SetDBFlag(Flag: Integer; Value: Boolean); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ExecSQL;
    function ParamByName(const Value: string): TParam;
    procedure Prepare;
    procedure UnPrepare;
    property Prepared: Boolean read FPrepared write SetPrepare;
    property ParamCount: Word read GetParamsCount;
    property Local: Boolean read FLocal;
    property StmtHandle: HDBIStmt read FStmtHandle;
    property Text: PChar read FText;
    property SQLBinary: PChar read FSQLBinary write FSQLBinary;
  published
    property SQL: TStrings read FSQL write SetQuery;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property UniDirectional: Boolean read FUniDirectional write FUniDirectional default False;
    property RequestLive: Boolean read FRequestLive write FRequestLive default False;
    property Params: TParams read FParams write SetParamsList;
    property UpdateMode;
  end;

{ TStringField }

  TStringField = class(TField)
  private
    FTransliterate: Boolean;
    FReserved: Byte;
  protected
    function GetAsBoolean: Boolean; override;
    function GetAsDateTime: TDateTime; override;
    function GetAsFloat: Double; override;
    function GetAsInteger: Longint; override;
    function GetAsString: string; override;
    function GetDefaultWidth: Integer; override;
    procedure GetText(var Text: string; DisplayText: Boolean); override;
    procedure SetAsBoolean(Value: Boolean); override;
    procedure SetAsDateTime(Value: TDateTime); override;
    procedure SetAsFloat(Value: Double); override;
    procedure SetAsInteger(Value: Longint); override;
    procedure SetAsString(const Value: string); override;
  public
    constructor Create(AOwner: TComponent); override;
    property Value: string read GetAsString write SetAsString;
  published
    property EditMask;
    property Size default 20;
    property Transliterate: Boolean read FTransliterate write FTransliterate default True;
  end;

{ TNumericField }

  TNumericField = class(TField)
  private
    FDisplayFormat: PString;
    FEditFormat: PString;
    function GetDisplayFormat: string;
    function GetEditFormat: string;
    procedure RangeError(Value, Min, Max: Double);
    procedure SetDisplayFormat(const Value: string);
    procedure SetEditFormat(const Value: string);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Alignment default taRightJustify;
    property DisplayFormat: string read GetDisplayFormat write SetDisplayFormat;
    property EditFormat: string read GetEditFormat write SetEditFormat;
  end;

{ TIntegerField }

  TIntegerField = class(TNumericField)
  private
    FMinRange: Longint;
    FMaxRange: Longint;
    FMinValue: Longint;
    FMaxValue: Longint;
    procedure CheckRange(Value, Min, Max: Longint);
    procedure SetMaxValue(Value: Longint);
    procedure SetMinValue(Value: Longint);
  protected
    function GetAsFloat: Double; override;
    function GetAsInteger: Longint; override;
    function GetAsString: string; override;
    procedure GetText(var Text: string; DisplayText: Boolean); override;
    function GetValue(var Value: Longint): Boolean;
    procedure SetAsFloat(Value: Double); override;
    procedure SetAsInteger(Value: Longint); override;
    procedure SetAsString(const Value: string); override;
  public
    constructor Create(AOwner: TComponent); override;
    function IsValidChar(Ch: Char): Boolean; override;
    property Value: Longint read GetAsInteger write SetAsInteger;
  published
    property MaxValue: Longint read FMaxValue write SetMaxValue default 0;
    property MinValue: Longint read FMinValue write SetMinValue default 0;
  end;

{ TSmallintField }

  TSmallintField = class(TIntegerField)
  public
    constructor Create(AOwner: TComponent); override;
  end;

{ TWordField }

  TWordField = class(TIntegerField)
  public
    constructor Create(AOwner: TComponent); override;
  end;

{ TFloatField }

  TFloatField = class(TNumericField)
  private
    FCurrency: Boolean;
    FCheckRange: Boolean;
    FPrecision: Integer;
    FMinValue: Double;
    FMaxValue: Double;
    procedure SetCurrency(Value: Boolean);
    procedure SetMaxValue(Value: Double);
    procedure SetMinValue(Value: Double);
    procedure SetPrecision(Value: Integer);
    procedure UpdateCheckRange;
  protected
    function GetAsFloat: Double; override;
    function GetAsInteger: Longint; override;
    function GetAsString: string; override;
    procedure GetText(var Text: string; DisplayText: Boolean); override;
    function GetValue(var Value: Double): Boolean;
    procedure SetAsFloat(Value: Double); override;
    procedure SetAsInteger(Value: Longint); override;
    procedure SetAsString(const Value: string); override;
  public
    constructor Create(AOwner: TComponent); override;
    function IsValidChar(Ch: Char): Boolean; override;
    property Value: Double read GetAsFloat write SetAsFloat;
  published
    property Currency: Boolean read FCurrency write SetCurrency default False;
    property MaxValue: Double read FMaxValue write SetMaxValue;
    property MinValue: Double read FMinValue write SetMinValue;
    property Precision: Integer read FPrecision write SetPrecision default 15;
  end;

{ TCurrencyField }

  TCurrencyField = class(TFloatField)
  public
    constructor Create(AOwner: TComponent); override;
  end;

{ TBCDField }

  TBCDField = class(TFloatField)
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Size default 4;
  end;

{ TBooleanField }

  TBooleanField = class(TField)
  private
    FDisplayValues: PString;
    FTextValues: array[Boolean] of string[15];
    function GetDisplayValues: string;
    procedure LoadTextValues;
    procedure SetDisplayValues(const Value: string);
  protected
    function GetAsBoolean: Boolean; override;
    function GetAsString: string; override;
    function GetDefaultWidth: Integer; override;
    procedure SetAsBoolean(Value: Boolean); override;
    procedure SetAsString(const Value: string); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Value: Boolean read GetAsBoolean write SetAsBoolean;
  published
    property DisplayValues: string read GetDisplayValues write SetDisplayValues;
  end;

{ TDateTimeField }

  TDateTimeField = class(TField)
  private
    FDisplayFormat: PString;
    function GetDisplayFormat: string;
    function GetValue(var Value: TDateTime): Boolean;
    procedure SetDisplayFormat(const Value: string);
  protected
    function GetAsDateTime: TDateTime; override;
    function GetAsFloat: Double; override;
    function GetAsString: string; override;
    procedure GetText(var Text: string; DisplayText: Boolean); override;
    procedure SetAsDateTime(Value: TDateTime); override;
    procedure SetAsFloat(Value: Double); override;
    procedure SetAsString(const Value: string); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Value: TDateTime read GetAsDateTime write SetAsDateTime;
  published
    property DisplayFormat: string read GetDisplayFormat write SetDisplayFormat;
    property EditMask;
  end;

{ TDateField }

  TDateField = class(TDateTimeField)
  public
    constructor Create(AOwner: TComponent); override;
  end;

{ TTimeField }

  TTimeField = class(TDateTimeField)
  public
    constructor Create(AOwner: TComponent); override;
  end;

{ TBytesField }

  TBytesField = class(TField)
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Size default 16;
  end;

{ TVarBytesField }

  TVarBytesField = class(TField)
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Size default 16;
  end;

{ TBlobField }

  TBlobField = class(TField)
  private
    FModified: Boolean;
    FTransliterate: Boolean;
    procedure LoadFromBlob(Blob: TBlobField);
    procedure LoadFromBitmap(Bitmap: TBitmap);
    procedure LoadFromStrings(Strings: TStrings);
    procedure SaveToBitmap(Bitmap: TBitmap);
    procedure SaveToStrings(Strings: TStrings);
  protected
    procedure AssignTo(Dest: TPersistent); override;
    procedure FreeBuffers; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Assign(Source: TPersistent); override;
    procedure Clear; override;
    procedure LoadFromFile(const FileName: string);
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToFile(const FileName: string);
    procedure SaveToStream(Stream: TStream);
  published
    property Size default 0;
  end;

{ TMemoField }

  TMemoField = class(TBlobField)
  public
    constructor Create(AOwner: TComponent); override;
  public
    property Transliterate: Boolean read FTransliterate write FTransliterate default True;
  end;

{ TGraphicField }

  TGraphicField = class(TBlobField)
  public
    constructor Create(AOwner: TComponent); override;
  end;

{ TBlobStream }

  TBlobStreamMode = (bmRead, bmWrite, bmReadWrite);

  TBlobStream = class(TStream)
  private
    FField: TBlobField;
    FDataSet: TDataSet;
    FRecord: PChar;
    FBuffer: PChar;
    FFieldNo: Integer;
    FOpened: Boolean;
    FModified: Boolean;
    FPosition: Longint;
    function GetBlobSize: Longint;
  public
    constructor Create(Field: TBlobField; Mode: TBlobStreamMode);
    destructor Destroy; override;
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;
    procedure Truncate;
  end;

{ TFieldDataLink }

  TFieldDataLink = class(TDataLink)
  private
    FField: TField;
    FFieldName: PString;
    FControl: TWinControl;
    FEditing: Boolean;
    FModified: Boolean;
    FOnDataChange: TNotifyEvent;
    FOnEditingChange: TNotifyEvent;
    FOnUpdateData: TNotifyEvent;
    FOnActiveChange: TNotifyEvent;
    function GetFieldName: string;
    function GetCanModify: Boolean;
    procedure SetEditing(Value: Boolean);
    procedure SetField(Value: TField);
    procedure SetFieldName(const Value: string);
    procedure UpdateField;
  protected
    procedure ActiveChanged; override;
    procedure EditingChanged; override;
    procedure FocusControl(Field: TFieldRef); override;
    procedure LayoutChanged; override;
    procedure RecordChanged(Field: TField); override;
    procedure UpdateData; override;
  public
    constructor Create;
    destructor Destroy; override;
    function Edit: Boolean;
    procedure Modified;
    procedure Reset;
    property CanModify: Boolean read GetCanModify;
    property Control: TWinControl read FControl write FControl;
    property Editing: Boolean read FEditing;
    property Field: TField read FField;
    property FieldName: string read GetFieldName write SetFieldName;
    property OnDataChange: TNotifyEvent read FOnDataChange write FOnDataChange;
    property OnEditingChange: TNotifyEvent read FOnEditingChange write FOnEditingChange;
    property OnUpdateData: TNotifyEvent read FOnUpdateData write FOnUpdateData;
    property OnActiveChange: TNotifyEvent read FOnActiveChange write FOnActiveChange;
  end;

implementation

uses DBConsts, Forms;

{ TQueryDataLink }

type
  TQueryDataLink = class(TDataLink)
  private
    FQuery: TQuery;
  protected
    procedure ActiveChanged; override;
    procedure RecordChanged(Field: TField); override;
    procedure CheckBrowseMode; override;
  public
    constructor Create(AQuery: TQuery);
  end;

{ Date and time conversion record }

type
  TDateTimeRec = record
    case TFieldType of
      ftDate: (Date: Longint);
      ftTime: (Time: Longint);
      ftDateTime: (DateTime: TDateTime);
  end;

{ Paradox graphic BLOB header }

type
  TGraphicHeader = record
    Count: Word;                { Fixed at 1 }
    HType: Word;                { Fixed at $0100 }
    Size: Longint;              { Size not including header }
  end;

{ Utility routines }

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

function IsFloat(const Value: string): Boolean;
var
  I: Integer;
begin
  Result := False;
  if Value <> '' then
  begin
    for I := 1 to Length(Value) do
      if not (Value[I] in [DecimalSeparator, '0'..'9']) then Exit;
    Result := True;
  end;
end;

function IsInteger(const Value: string): Boolean;
var
  I: Integer;
begin
  Result := False;
  if Value <> '' then
  begin
    for I := 1 to Length(Value) do
      if not (Value[I] in ['0'..'9']) then Exit;
    Result := True;
  end;
end;

{ TIndexDef }

constructor TIndexDef.Create(Owner: TIndexDefs; const Name, Fields: string;
  Options: TIndexOptions);
begin
  if Owner <> nil then
  begin
    Owner.FItems.Add(Self);
    Owner.FUpdated := False;
    FOwner := Owner;
  end;
  FName := NewStr(Name);
  FFields := NewStr(Fields);
  FOptions := Options;
end;

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

function TIndexDef.GetExpression: string;
begin
  if ixExpression in Options then Result := FFields^ else Result := '';
end;

function TIndexDef.GetFields: string;
begin
  if ixExpression in Options then Result := '' else Result := FFields^;
end;

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

{ TIndexDefs }

constructor TIndexDefs.Create(Table: TTable);
begin
  FTable := Table;
  FItems := TList.Create;
end;

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

procedure TIndexDefs.Add(const Name, Fields: string;
  Options: TIndexOptions);
begin
  if IndexOf(Name) >= 0 then DBErrorFmt(SDuplicateIndexName, [Name]);
  TIndexDef.Create(Self, Name, Fields, Options);
end;

procedure TIndexDefs.Assign(IndexDefs: TIndexDefs);
var
  I: Integer;
begin
  Clear;
  for I := 0 to IndexDefs.Count - 1 do
    with IndexDefs[I] do Add(Name, Fields, Options);
end;

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

function TIndexDefs.FindIndexForFields(const Fields: string): TIndexDef;
var
  Exact: Boolean;
  I, L: Integer;
begin
  Update;
  L := Length(Fields);
  Exact := True;
  while True do
  begin
    for I := 0 to FItems.Count - 1 do
    begin
      Result := FItems[I];
      if Result.FOptions * [ixDescending, ixExpression] = [] then
        if Exact then
        begin
          if AnsiCompareText(Fields, Result.FFields^) = 0 then Exit;
        end else
        begin
          if (AnsiCompareText(Fields, Copy(Result.FFields^, 1, L)) = 0) and
            ((Length(Result.FFields^) = L) or
            (Result.FFields^[L + 1] = ';')) then Exit;
        end;
    end;
    if not Exact then
      DBErrorFmt(SNoIndexForFields, [FTable.TableName, Fields]);
    Exact := False;
  end;
end;

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

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

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

procedure TIndexDefs.Update;
begin
  FTable.UpdateIndexDefs;
end;

{ TBatchMove }

constructor TBatchMove.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAbortOnKeyViol := True;
  FAbortOnProblem := True;
  FTransliterate := True;
  FMappings := TStringList.Create;
end;

destructor TBatchMove.Destroy;
begin
  FMappings.Free;
  inherited Destroy;
end;

function TBatchMove.ConvertName(const Name: string; Buffer: PChar): PChar;
begin
  if Name <> '' then
    Result := AnsiToNative(Destination.DBLocale, Name, Buffer, 255) else
    Result := nil;
end;

procedure TBatchMove.Execute;
type
  PFieldMap = ^TFieldMap;
  TFieldMap = array[1..1024] of Word;
var
  SourceActive, DestinationActive: Boolean;
  BatchMode: TBatchMode;
  I: Integer;
  FieldCount: Word;
  FieldMap: PFieldMap;
  DestName, SourceName: string[31];
  Mapping: string[63];
  SKeyViolName, SProblemName, SChangedName: DBITBLNAME;

  procedure GetMappingNames;
  var
    P: Integer;
    Mapping: string[63];
  begin
    Mapping := FMappings[I];
    P := Pos('=', Mapping);
    if P > 0 then
    begin
      DestName := Copy(Mapping, 1, P - 1);
      SourceName := Copy(Mapping, P + 1, 255);
    end else
    begin
      DestName := Mapping;
      SourceName := Mapping;
    end;
  end;

begin
  if (Destination = nil) or (Source = nil) or (Destination = Source) then
    DBError(SInvalidBatchMove);
  SourceActive := Source.Active;
  DestinationActive := Destination.Active;
  FieldCount := 0;
  FieldMap := nil;
  try
    Source.DisableControls;
    Destination.DisableControls;
    Source.Open;
    Source.CheckBrowseMode;
    Source.UpdateCursorPos;
    BatchMode := FMode;
    if BatchMode = batCopy then
    begin
      Destination.Close;
      if FMappings.Count = 0 then
        Destination.FieldDefs := Source.FieldDefs
      else
      begin
        Destination.FieldDefs.Clear;
        for I := 0 to FMappings.Count - 1 do
        begin
          GetMappingNames;
          with Source.FieldDefs.Find(SourceName) do
            Destination.FieldDefs.Add(DestName, DataType, Size, Required);
        end;
      end;
      Destination.IndexDefs.Clear;
      Destination.CreateTable;
      BatchMode := batAppend;
    end;
    Destination.Open;
    Destination.CheckBrowseMode;
    if FMappings.Count <> 0 then
    begin
      FieldCount := Destination.FieldDefs.Count;
      FieldMap := AllocMem(FieldCount * SizeOf(Word));
      for I := 0 to FMappings.Count - 1 do
      begin
        GetMappingNames;
        FieldMap^[Destination.FieldDefs.Find(DestName).FieldNo] :=
          Source.FieldDefs.Find(SourceName).FieldNo;
      end;
    end;
    if FRecordCount > 0 then
    begin
      Source.UpdateCursorPos;
      FMovedCount := FRecordCount;
    end else
    begin
      Check(DbiSetToBegin(Source.Handle));
      FMovedCount := MaxLongint;
    end;
    Source.CursorPosChanged;
    try
      Check(DbiBatchMove(nil, Source.Handle, nil, Destination.Handle,
        EBATMode(BatchMode), FieldCount, PWord(FieldMap), nil, nil, 0,
        ConvertName(FKeyViolTableName, SKeyViolName),
        ConvertName(FProblemTableName, SProblemName),
        ConvertName(FChangedTableName, SChangedName),
        @FProblemCount, @FKeyViolCount, @FChangedCount,
        FAbortOnProblem, FAbortOnKeyViol, FMovedCount, FTransliterate));
    finally
      if DestinationActive then Destination.First;
    end;
  finally
    if FieldMap <> nil then FreeMem(FieldMap, FieldCount * SizeOf(Word));
    if not DestinationActive then Destination.Close;
    if not SourceActive then Source.Close;
    Destination.EnableControls;
    Source.EnableControls;
  end;
end;

procedure TBatchMove.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if Operation = opRemove then
  begin
    if Destination = AComponent then Destination := nil;
    if Source = AComponent then Source := nil;
  end;
end;

procedure TBatchMove.SetMappings(Value: TStrings);
begin
  FMappings.Assign(Value);
end;

{ TTableDataLink }

constructor TTableDataLink.Create(Table: TTable);
begin
  inherited Create;
  FTable := Table;
  FFieldNames := NullStr;
  FFields := TList.Create;
end;

destructor TTableDataLink.Destroy;
begin
  DisposeStr(FFieldNames);
  FFields.Free;
  inherited Destroy;
end;

procedure TTableDataLink.ActiveChanged;
var
  Pos: Integer;
begin
  FFields.Clear;
  if Active then
    try
      Pos := 1;
      while Pos <= Length(FFieldNames^) do FFields.Add(
        DataSet.FieldByName(ExtractFieldName(FFieldNames^, Pos)));
    except
      FFields.Clear;
      raise;
    end;
  if FTable.Active and not (csDestroying in FTable.ComponentState) then
    if Active and (FFields.Count > 0) then
      FTable.MasterChanged else
      FTable.CancelRange;
end;

procedure TTableDataLink.CheckBrowseMode;
begin
  if FTable.Active then FTable.CheckBrowseMode;
end;

procedure TTableDataLink.LayoutChanged;
begin
  ActiveChanged;
end;

procedure TTableDataLink.RecordChanged(Field: TField);
begin
  if (DataSource.State <> dsSetKey) and FTable.Active and
    (FFields.Count > 0) and ((Field = nil) or
    (FFields.IndexOf(Field) >= 0)) then
    FTable.MasterChanged;
end;

procedure TTableDataLink.SetFieldNames(const Value: string);
begin
  if FFieldNames^ <> Value then
  begin
    AssignStr(FFieldNames, Value);
    ActiveChanged;
  end;
end;

{ TTable }

constructor TTable.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FIndexDefs := TIndexDefs.Create(Self);
  FDataLink := TTableDataLink.Create(Self);
end;

destructor TTable.Destroy;
begin
  FDataLink.Free;
  FIndexDefs.Free;
  inherited Destroy;
end;

procedure TTable.AddIndex(const Name, Fields: string;
  Options: TIndexOptions);
var
  STableName: array[0..SizeOf(TFileName) - 1] of Char;
  IndexDesc: IDXDesc;
begin
  FieldDefs.Update;
  EncodeIndexDesc(IndexDesc, Name, Fields, Options);
  if Active then
  begin
    CheckBrowseMode;
    CursorPosChanged;
    Check(DbiAddIndex(DBHandle, Handle, nil, nil, IndexDesc, nil));
  end else
  begin
    SetDBFlag(dbfTable, True);
    try
      Check(DbiAddIndex(DBHandle, nil, AnsiToNative(DBLocale, TableName,
        STableName, SizeOf(STableName) - 1), GetTableTypeName,
        IndexDesc, nil));
    finally
      SetDBFlag(dbfTable, False);
    end;
  end;
  FIndexDefs.FUpdated := False;
end;

procedure TTable.ApplyRange;
begin
  CheckBrowseMode;
  if SetCursorRange then First;
end;

function TTable.BatchMove(ASource: TDataSet; AMode: TBatchMode): Longint;
begin
  with TBatchMove.Create(nil) do
  try
    Destination := Self;
    Source := ASource;
    Mode := AMode;
    Execute;
    Result := MovedCount;
  finally
    Free;
  end;
end;

procedure TTable.CancelRange;
begin
  CheckBrowseMode;
  UpdateCursorPos;
  if ResetCursorRange then Resync([]);
end;

function TTable.CreateHandle: HDBICur;
const
  OpenModes: array[Boolean] of DbiOpenMode = (dbiReadWrite, dbiReadOnly);
  ShareModes: array[Boolean] of DbiShareMode = (dbiOpenShared, dbiOpenExcl);
var
  STableName: array[0..SizeOf(TFileName) - 1] of Char;
  SIndexName: array[0..SizeOf(TIndexName) - 1] of Char;
  SIndexTag: array[0..SizeOf(TSymbolStr) - 1] of Char;
begin
  if FTableName = '' then DBError(SNoTableName);
  AnsiToNative(DBLocale, FTableName, STableName, SizeOf(STableName) - 1);
  GetIndexParams(FIndexName, FFieldsIndex, SIndexName, SIndexTag);
  Result := nil;
  while not CheckOpen(DbiOpenTable(DBHandle, STableName, GetTableTypeName,
    SIndexName, SIndexTag, 0, OpenModes[FReadOnly], ShareModes[FExclusive],
    xltField, False, nil, Result)) do {Retry};
end;

procedure TTable.CreateTable;
var
  I, J: Integer;
  FieldDescs: PFLDDesc;
  ValCheckPtr: PVCHKDesc;
  DriverTypeName: DBINAME;
  TableDesc: CRTblDesc;
begin
  CheckInactive;
  if FieldDefs.Count = 0 then
    for I := 0 to FieldCount - 1 do
      with Fields[I] do
        if not Calculated then
          FieldDefs.Add(FieldName, DataType, Size, Required);
  FieldDescs := nil;
  FillChar(TableDesc, SizeOf(TableDesc), 0);
  with TableDesc do
  begin
    SetDBFlag(dbfTable, True);
    try
      AnsiToNative(Locale, TableName, szTblName, SizeOf(szTblName) - 1);
      if GetTableTypeName <> nil then
        StrCopy(szTblType, GetTableTypeName);
      iFldCount := FieldDefs.Count;
      FieldDescs := AllocMem(iFldCount * SizeOf(FLDDesc));
      for I := 0 to FieldDefs.Count - 1 do
        with FieldDefs[I] do
        begin
          EncodeFieldDesc(PFieldDescList(FieldDescs)^[I], Name,
            DataType, Size);
          if Required then Inc(iValChkCount);
        end;
      pFldDesc := AllocMem(iFldCount * SizeOf(FLDDesc));
      Check(DbiTranslateRecordStructure(nil, iFldCount, FieldDescs,
        GetDriverTypeName(DriverTypeName), nil, pFLDDesc));
      iIdxCount := IndexDefs.Count;
      pIdxDesc := AllocMem(iIdxCount * SizeOf(IDXDesc));
      for I := 0 to IndexDefs.Count - 1 do
        with IndexDefs[I] do
          EncodeIndexDesc(PIndexDescList(pIdxDesc)^[I], Name, Fields,
            Options);
      if iValChkCount <> 0 then
      begin
        pVChkDesc := AllocMem(iValChkCount * SizeOf(VCHKDesc));
        ValCheckPtr := pVChkDesc;
        for I := 0 to FieldDefs.Count - 1 do
          if FieldDefs[I].Required then
          begin
            ValCheckPtr^.iFldNum := I + 1;
            ValCheckPtr^.bRequired := True;
            Inc(ValCheckPtr);
          end;
      end;
      Check(DbiCreateTable(DBHandle, True, TableDesc));
    finally
      if pVChkDesc <> nil then FreeMem(pVChkDesc, iValChkCount * SizeOf(VCHKDesc));
      if pIdxDesc <> nil then FreeMem(pIdxDesc, iIdxCount * SizeOf(IDXDesc));
      if pFldDesc <> nil then FreeMem(pFldDesc, iFldCount * SizeOf(FLDDesc));
      if FieldDescs <> nil then FreeMem(FieldDescs, iFldCount * SizeOf(FLDDesc));
      SetDBFlag(dbfTable, False);
    end;
  end;
end;

procedure TTable.DataEvent(Event: TDataEvent; Info: Longint);
begin
  if Event = dePropertyChange then FIndexDefs.FUpdated := False;
  inherited DataEvent(Event, Info);
end;

procedure TTable.DecodeIndexDesc(const IndexDesc: IDXDesc;
  var Name, Fields: string; var Options: TIndexOptions);
var
  IndexOptions: TIndexOptions;
  I: Integer;
  P: PChar;
begin
  with IndexDesc do
  begin
    if szTagName[0] = #0 then P := szName else P := szTagName;
    NativeToAnsi(Locale, P, Name);
    IndexOptions := [];
    if bPrimary then Include(IndexOptions, ixPrimary);
    if bUnique then Include(IndexOptions, ixUnique);
    if bDescending then Include(IndexOptions, ixDescending);
    if bCaseInsensitive then Include(IndexOptions, ixCaseInsensitive);
    if bExpIdx then
    begin
      Include(IndexOptions, ixExpression);
      NativeToAnsi(Locale, szKeyExp, Fields);
    end else
    begin
      Fields := '';
      for I := 0 to iFldsInKey - 1 do
      begin
        if I <> 0 then Fields := Fields + ';';
        Fields := Fields + FieldDefs[aiKeyFld[I] - 1].Name;
      end;
    end;
    Options := IndexOptions;
  end;
end;

procedure TTable.DeleteIndex(const Name: string);
var
  STableName: array[0..SizeOf(TFileName) - 1] of Char;
  SIndexName: array[0..SizeOf(TIndexName) - 1] of Char;
  SIndexTag: array[0..SizeOf(TSymbolStr) - 1] of Char;
begin
  GetIndexParams(Name, False, SIndexName, SIndexTag);
  if Active then
  begin
    CheckBrowseMode;
    Check(DbiDeleteIndex(DBHandle, Handle, nil, nil, SIndexName,
      SIndexTag, 0));
  end else
  begin
    SetDBFlag(dbfTable, True);
    try
      Check(DbiDeleteIndex(DBHandle, nil, AnsiToNative(DBLocale, TableName,
        STableName, SizeOf(STableName) - 1), GetTableTypeName,
        SIndexName, SIndexTag, 0));
    finally
      SetDBFlag(dbfTable, False);
    end;
  end;
  FIndexDefs.FUpdated := False;
end;

procedure TTable.DeleteTable;
var
  STableName: array[0..SizeOf(TFileName) - 1] of Char;
begin
  CheckInactive;
  SetDBFlag(dbfTable, True);
  try
    Check(DbiDeleteTable(DBHandle, AnsiToNative(DBLocale, TableName,
      STableName, SizeOf(STableName) - 1), GetTableTypeName));
  finally
    SetDBFlag(dbfTable, False);
  end;
end;

procedure TTable.DoOnNewRecord;
var
  I: Integer;
begin
  if FDataLink.Active and (FDataLink.FFields.Count > 0) then
    for I := 0 to FDataLink.FFields.Count - 1 do
      IndexFields[I] := TField(FDataLink.FFields[I]);
  inherited DoOnNewRecord;
end;

procedure TTable.EditKey;
begin
  SetKeyBuffer(kiLookup, False);
end;

procedure TTable.EditRangeEnd;
begin
  SetKeyBuffer(kiRangeEnd, False);
end;

procedure TTable.EditRangeStart;
begin
  SetKeyBuffer(kiRangeStart, False);
end;

procedure TTable.EmptyTable;
var
  STableName: array[0..SizeOf(TFileName) - 1] of Char;
begin
  if Active then
  begin
    CheckBrowseMode;
    Check(DbiEmptyTable(DBHandle, Handle, nil, nil));
    ClearBuffers;
    DataEvent(deDataSetChange, 0);
  end else
  begin
    SetDBFlag(dbfTable, True);
    try
      Check(DbiEmptyTable(DBHandle, nil, AnsiToNative(DBLocale, TableName,
        STableName, SizeOf(STableName) - 1), GetTableTypeName));
    finally
      SetDBFlag(dbfTable, False);
    end;
  end;
end;

procedure TTable.EncodeFieldDesc(var FieldDesc: FLDDesc;
  const Name: string; DataType: TFieldType; Size: Word);
const
  TypeMap: array[TFieldType] of Byte = (
    fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
    fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
    fldVARBYTES, fldBLOB, fldBLOB, fldBLOB);
begin
  with FieldDesc do
  begin
    AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1);
    iFldType := TypeMap[DataType];
    case DataType of
      ftString, ftBytes, ftVarBytes, ftBlob, ftMemo, ftGraphic:
        iUnits1 := Size;
      ftBCD:
        begin
          iUnits1 := 32;
          iUnits2 := Size;
        end;
    end;
    case DataType of
      ftCurrency:
        iSubType := fldstMONEY;
      ftBlob:
        iSubType := fldstBINARY;
      ftMemo:
        iSubType := fldstMEMO;
      ftGraphic:
        iSubType := fldstGRAPHIC;
    end;
  end;
end;

procedure TTable.EncodeIndexDesc(var IndexDesc: IDXDesc;
  const Name, Fields: string; Options: TIndexOptions);
var
  Pos: Integer;
begin
  FillChar(IndexDesc, SizeOf(IndexDesc), 0);
  with IndexDesc do
  begin
    if IsDBaseTable then
      AnsiToNative(DBLocale, Name, szTagName, SizeOf(szTagName) - 1)
    else
      AnsiToNative(DBLocale, Name, szName, SizeOf(szName) - 1);
    bPrimary := ixPrimary in Options;
    bUnique := ixUnique in Options;
    bDescending := ixDescending in Options;
    bMaintained := True;
    bCaseInsensitive := ixCaseInsensitive in Options;
    if ixExpression in Options then
    begin
      bExpIdx := True;
      AnsiToNative(DBLocale, Fields, szKeyExp, SizeOf(szKeyExp) - 1);
    end else
    begin
      Pos := 1;
      while (Pos <= Length(Fields)) and (iFldsInKey < 16) do
      begin
        aiKeyFld[iFldsInKey] :=
          FieldDefs.Find(ExtractFieldName(Fields, Pos)).FieldNo;
        Inc(iFldsInKey);
      end;
    end;
  end;
end;

function TTable.FindKey(const KeyValues: array of const): Boolean;
begin
  CheckBrowseMode;
  SetKeyFields(kiLookup, KeyValues);
  Result := GotoKey;
end;

procedure TTable.FindNearest(const KeyValues: array of const);
begin
  CheckBrowseMode;
  SetKeyFields(kiLookup, KeyValues);
  GotoNearest;
end;

function TTable.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

function TTable.GetDriverTypeName(Buffer: PChar): PChar;
var
  Length: Word;
begin
  Result := Buffer;
  Check(DbiGetProp(HDBIOBJ(DBHandle), dbDATABASETYPE, Buffer,
    SizeOf(DBINAME), Length));
  if StrIComp(Buffer, 'STANDARD') = 0 then
  begin
    Result := GetTableTypeName;
    if Result <> nil then Result := StrCopy(Buffer, Result);
  end;
end;

function TTable.GetIndexFieldNames: string;
begin
  if FFieldsIndex then Result := FIndexName else Result := '';
end;

function TTable.GetIndexName: string;
begin
  if FFieldsIndex then Result := '' else Result := FIndexName;
end;

procedure TTable.GetIndexNames(List: TStrings);
var
  I: Integer;
begin
  UpdateIndexDefs;
  for I := 0 to FIndexDefs.Count - 1 do
    with FIndexDefs[I] do
      if FName^ <> '' then List.Add(FName^);
end;

procedure TTable.GetIndexParams(const IndexName: string;
  FieldsIndex: Boolean; PIndexName, PIndexTag: PChar);
var
  I: Integer;
  IndexStr: TIndexName;
begin
  PIndexName[0] := #0;
  PIndexTag[0] := #0;
  if (IndexName <> '') and not InfoQueryMode then
  begin
    IndexStr := IndexName;
    if FieldsIndex then
      if Database.IsSQLBased then
      begin
        for I := 1 to Length(IndexStr) do
          if IndexStr[I] = ';' then IndexStr[I] := '@';
        IndexStr := '@' + IndexStr;
      end else
        IndexStr := IndexDefs.FindIndexForFields(IndexName).Name;
    if IsDBaseTable then
    begin
      AnsiToNative(DBLocale, IndexStr, PIndexTag, SizeOf(TSymbolStr) - 1);
      IndexStr := ChangeFileExt(FTableName, '.MDX');
    end;
    AnsiToNative(DBLocale, IndexStr, PIndexName, SizeOf(TIndexName) - 1);
  end;
end;

function TTable.GetMasterFields: string;
begin
  Result := FDataLink.FFieldNames^;
end;

function TTable.GetTableTypeName: PChar;
const
  Names: array[TTableType] of PChar =
    ('PARADOX', 'PARADOX', 'DBASE', 'ASCIIDRV');
begin
  Result := nil;
  if not Database.IsSQLBased and ((FTableType <> ttDefault) or
    (ExtractFileExt(FTableName) = '')) then
    Result := Names[FTableType];
end;

procedure TTable.GotoCurrent(Table: TTable);
begin
  CheckBrowseMode;
  Table.CheckBrowseMode;
  if (AnsiCompareText(DatabaseName, Table.DatabaseName) <> 0) or
    (AnsiCompareText(TableName, Table.TableName) <> 0) then
    DBError(STableMismatch);
  Table.UpdateCursorPos;
  Check(DbiSetToCursor(Handle, Table.Handle));
  Resync([rmExact, rmCenter]);
end;

function TTable.GotoKey: Boolean;
var
  KeyBuffer: PKeyBuffer;
begin
  CheckBrowseMode;
  CursorPosChanged;
  KeyBuffer := GetKeyBuffer(kiLookup);
  Result := False;
  if DbiGetRecordForKey(Handle, False, KeyBuffer^.FieldCount, 0,
    PChar(KeyBuffer) + SizeOf(TKeyBuffer), nil) = 0 then
  begin
    Resync([rmExact, rmCenter]);
    Result := True;
  end;
end;

procedure TTable.GotoNearest;
var
  SearchCond: DBISearchCond;
  KeyBuffer: PKeyBuffer;
begin
  CheckBrowseMode;
  CursorPosChanged;
  KeyBuffer := GetKeyBuffer(kiLookup);
  if KeyBuffer^.Exclusive then
    SearchCond := keySEARCHGT else
    SearchCond := keySEARCHGEQ;
  Check(DbiSetToKey(Handle, SearchCond, False, KeyBuffer^.FieldCount, 0,
    PChar(KeyBuffer) + SizeOf(TKeyBuffer)));
  Resync([rmCenter]);
end;

procedure TTable.InitFieldDefs;
var
  FieldNo: Word;
  FCursor, VCursor: HDBICur;
  RequiredFields: set of 0..255;
  STableName: array[0..SizeOf(TFileName) - 1] of Char;
  FieldDesc: FLDDesc;
  ValCheckDesc: VCHKDesc;
begin
  SetDBFlag(dbfFieldList, True);
  try
    AnsiToNative(DBLocale, TableName, STableName, SizeOf(STableName) - 1);
    RequiredFields := [];
    while not CheckOpen(DbiOpenFieldList(DBHandle, STableName,
      GetTableTypeName, False, FCursor)) do {Retry};
    try
      if DbiOpenVChkList(DBHandle, STableName, GetTableTypeName,
        VCursor) = 0 then
      begin
        while DbiGetNextRecord(VCursor, dbiNoLock, @ValCheckDesc, nil) = 0 do
          if ValCheckDesc.bRequired then
            Include(RequiredFields, ValCheckDesc.iFldNum - 1);
        DbiCloseCursor(VCursor);
      end;
      FieldNo := 0;
      FieldDefs.Clear;
      while DbiGetNextRecord(FCursor, dbiNoLock, @FieldDesc, nil) = 0 do
      begin
        FieldDefs.AddFieldDesc(FieldDesc, FieldNo in RequiredFields,
          FieldNo + 1);
        Inc(FieldNo);
      end;
    finally
      DbiCloseCursor(FCursor);
    end;
  finally
    SetDBFlag(dbfFieldList, False);
  end;
end;

function TTable.IsDBaseTable: Boolean;
begin
  Result := (FTableType = ttDBase) or
    (CompareText(ExtractFileExt(TableName), '.DBF') = 0);
end;

procedure TTable.LockTable(LockType: TLockType);
begin
  SetTableLock(LockType, True);
end;

procedure TTable.MasterChanged;
begin
  CheckBrowseMode;
  UpdateRange;
  ApplyRange;
end;

procedure TTable.PrepareCursor;
begin
  if FDataLink.Active and (FDataLink.FFields.Count > 0) then
  begin
    UpdateRange;
    SetCursorRange;
  end;
end;

procedure TTable.RenameTable(const NewTableName: string);
var
  SCurTableName: array[0..SizeOf(TFileName) - 1] of Char;
  SNewTableName: array[0..SizeOf(TFileName) - 1] of Char;
begin
  CheckInactive;
  SetDBFlag(dbfTable, True);
  try
    Check(DbiRenameTable(DBHandle, AnsiToNative(DBLocale, TableName,
      SCurTableName, SizeOf(SCurTableName) - 1), GetTableTypeName,
      AnsiToNative(DBLocale, NewTableName, SNewTableName,
      SizeOf(SNewTableName) - 1)));
  finally
    SetDBFlag(dbfTable, False);
  end;
  TableName := NewTableName;
end;

procedure TTable.SetDataSource(Value: TDataSource);
begin
  if IsLinkedTo(Value) then DBError(SCircularDataLink);
  FDataLink.DataSource := Value;
end;

procedure TTable.SetExclusive(Value: Boolean);
begin
  CheckInactive;
  FExclusive := Value;
end;

procedure TTable.SetIndex(const Value: string; FieldsIndex: Boolean);
var
  SIndexName: array[0..SizeOf(TIndexName) - 1] of Char;
  SIndexTag: array[0..SizeOf(TSymbolStr) - 1] of Char;
begin
  if Active then CheckBrowseMode;
  if (FIndexName <> Value) or (FFieldsIndex <> FieldsIndex) then
  begin
    if Active then
    begin
      GetIndexParams(Value, FieldsIndex, SIndexName, SIndexTag);
      SwitchToIndex(SIndexName, SIndexTag);
    end;
    FIndexName := Value;
    FFieldsIndex := FieldsIndex;
    if Active then Resync([]);
  end;
end;

procedure TTable.SetIndexFieldNames(const Value: string);
begin
  SetIndex(Value, Value <> '');
end;

procedure TTable.SetIndexName(const Value: string);
begin
  SetIndex(Value, False);
end;

procedure TTable.SetKey;
begin
  SetKeyBuffer(kiLookup, True);
end;

procedure TTable.SetMasterFields(const Value: string);
begin
  FDataLink.SetFieldNames(Value);
end;

procedure TTable.SetRange(const StartValues, EndValues: array of const);
begin
  CheckBrowseMode;
  SetKeyFields(kiRangeStart, StartValues);
  SetKeyFields(kiRangeEnd, EndValues);
  ApplyRange;
end;

procedure TTable.SetRangeEnd;
begin
  SetKeyBuffer(kiRangeEnd, True);
end;

procedure TTable.SetRangeStart;
begin
  SetKeyBuffer(kiRangeStart, True);
end;

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

procedure TTable.SetTableLock(LockType: TLockType; Lock: Boolean);
var
  L: DBILockType;
begin
  if State = dsInactive then DBError(SDataSetClosed);
  if LockType = ltReadLock then L := dbiREADLOCK else L := dbiWRITELOCK;
  if Lock then
    Check(DbiAcqTableLock(Handle, L)) else
    Check(DbiRelTableLock(Handle, False, L));
end;

procedure TTable.SetTableName(const Value: TFileName);
begin
  CheckInactive;
  FTableName := Value;
  DataEvent(dePropertyChange, 0);
end;

procedure TTable.SetTableType(Value: TTableType);
begin
  CheckInactive;
  FTableType := Value;
end;

procedure TTable.UpdateIndexDefs;
var
  Cursor: HDBICur;
  STableName: array[0..SizeOf(TFileName) - 1] of Char;
  Options: TIndexOptions;
  Name: TSymbolStr;
  Fields: string;
  IndexDesc: IDXDesc;
begin
  if not FIndexDefs.FUpdated then
  begin
    SetDBFlag(dbfIndexList, True);
    try
      FieldDefs.Update;
      while not CheckOpen(DbiOpenIndexList(DBHandle, AnsiToNative(DBLocale,
        TableName, STableName, SizeOf(STableName) - 1), GetTableTypeName,
        Cursor)) do {Retry};
      try
        IndexDefs.Clear;
        while DbiGetNextRecord(Cursor, dbiNoLock, @IndexDesc, nil) = 0 do
          if IndexDesc.bMaintained then
          begin
            DecodeIndexDesc(IndexDesc, Name, Fields, Options);
            IndexDefs.Add(Name, Fields, Options);
          end;
        IndexDefs.FUpdated := True;
      finally
        DbiCloseCursor(Cursor);
      end;
    finally
      SetDBFlag(dbfIndexList, False);
    end;
  end;
end;

procedure TTable.UpdateRange;
begin
  SetLinkRanges(FDataLink.FFields);
end;

{ TParams }

constructor TParams.Create;
begin
  FItems := TList.Create;
end;

destructor TParams.Destroy;
begin
  Clear;
  FItems.Free;
  inherited Destroy;
end;

procedure TParams.Assign(Source: TPersistent);
var
  I: Integer;
begin
  if Source is TParams then
  begin
    Clear;
    for I := 0 to TParams(Source).Count - 1 do
      with TParam.Create(Self, ptUnknown) do
        Assign(TParams(Source)[I]);
  end
  else inherited Assign(Source);
end;

procedure TParams.AssignTo(Dest: TPersistent);
begin
  if Dest is TParams then TParams(Dest).Assign(Self)
  else inherited AssignTo(Dest);
end;

procedure TParams.AssignValues(Value: TParams);
var
  I, J: Integer;
begin
    for I := 0 to Count - 1 do
      for J := 0 to Value.Count - 1 do
        if Items[I].Name = Value[J].Name then
        begin
          Items[I].Assign(Value[J]);
          Break;
        end;
end;

procedure TParams.AddParam(Value: TParam);
begin
  FItems.Add(Value);
  Value.FParamList := Self;
end;

procedure TParams.RemoveParam(Value: TParam);
begin
  FItems.Remove(Value);
  Value.FParamList := nil;
end;

function TParams.CreateParam(FldType: TFieldType; const ParamName: string;
  ParamType: TParamType): TParam;
begin
  Result := TParam.Create(Self, ParamType);
  with Result do
  begin
    Name := ParamName;
    DataType :=  FldType;
  end;
end;

function TParams.Count: Integer;
begin
  Result := FItems.Count;
end;

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

function TParams.GetParam(Index: Word): TParam;
begin
  Result := ParamByName(TParam(FItems[Index]).Name);
end;

function TParams.ParamByName(const Value: string): TParam;
var
  I: Integer;
begin
  for I := 0 to FItems.Count - 1 do
  begin
    Result := FItems[I];
    if AnsiCompareText(Result.Name, Value) = 0 then Exit;
  end;
  DBErrorFmt(SParameterNotFound, [Value]);
end;

procedure TParams.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineBinaryProperty('Data', ReadBinaryData, WriteBinaryData, Count > 0);
end;

procedure TParams.ReadBinaryData(Stream: TStream);
var
  I, Temp, NumItems: Integer;
  Buffer: array[0..255] of char;
  TempStr: string;
begin
  Clear;
  with Stream do
  begin
    ReadBuffer(Temp, SizeOf(Temp));
    if Temp <> GetVersion then DBError(SInvalidVersion);
    ReadBuffer(NumItems, SizeOf(NumItems));
    for I := 0 to NumItems - 1 do
      with TParam.Create(Self, ptUnknown) do
      begin
        ReadBuffer(TempStr, 1);
        ReadBuffer(TempStr[1], Ord(TempStr[0]));
        Name := TempStr;
        ReadBuffer(FParamType, SizeOf(FParamType));
        ReadBuffer(FDataType, SizeOf(FDataType));
        if DataType <> ftUnknown then
        begin
          ReadBuffer(Temp, SizeOf(Temp));
          ReadBuffer(Buffer, Temp);
          SetData(@Buffer);
        end;
        ReadBuffer(FNull, SizeOf(FNull));
        ReadBuffer(FBound, SizeOf(FBound));
      end;
  end;
end;

procedure TParams.WriteBinaryData(Stream: TStream);
var
  I, Temp: Integer;
  Buffer: array[0..255] of char;
begin
  with Stream do
  begin
    Temp := GetVersion;
    WriteBuffer(Temp, SizeOf(Temp));
    Temp := Count;
    WriteBuffer(Temp, SizeOf(Temp));
    for I := 0 to Count - 1 do
      with Items[I] do
      begin
        WriteBuffer(FName^, Length(FName^) + 1);
        WriteBuffer(FParamType, SizeOf(FParamType));
        WriteBuffer(FDataType, SizeOf(FDataType));
        if DataType <> ftUnknown then
        begin
          GetData(@Buffer);
          Temp := GetDataSize;
          WriteBuffer(Temp, SizeOf(Temp));
          WriteBuffer(Buffer, Temp);
        end;
        WriteBuffer(FNull, SizeOf(FNull));
        WriteBuffer(FBound, SizeOf(FBound));
      end;
  end;
end;

function TParams.GetVersion: Integer;
begin
  Result := 1;
end;

{ TParam }

constructor TParam.Create(AParamList: TParams; AParamType: TParamType);
begin
  if AParamList <> nil then
    AParamList.AddParam(Self);
  FName := NullStr;
  FString := NullStr;
  DataType := ftUnknown;
  ParamType := AParamType;
  FBound := False;
end;

destructor TParam.Destroy;
begin
  if FParamList <> nil then
    FParamList.RemoveParam(Self);
  DisposeStr(FName);
  DisposeStr(FString);
end;

procedure TParam.SetDataType(Value: TFieldType);
begin
  FData.FFloat := 0;
  AssignStr(FString, '');
  FDataType := Value;
end;

procedure TParam.SetParamName(const Value: string);
begin
  AssignStr(FName, Value);
end;

function TParam.GetParamName: string;
begin
  Result := FName^;
end;

function TParam.GetDataSize: Word;
begin
  case DataType of
    ftUnknown:
      DBErrorFmt(SFieldUndefinedType, [FName^]);
    ftString: Result := Length(FString^) + 1;
    ftBoolean: Result := SizeOf(WordBool);
    ftDateTime,
    ftBCD,
    ftCurrency,
    ftFloat: Result := SizeOf(Double);
    ftTime,
    ftDate,
    ftInteger: Result := SizeOf(LongInt);
    ftSmallint: Result := SizeOf(Integer);
    ftWord: Result := SizeOf(Word);
  else
    DBErrorFmt(SFieldUnsupportedType, [FName^]);
  end;
end;

procedure TParam.GetData(Buffer: Pointer);
begin
  case DataType of
    ftUnknown:
      DBErrorFmt(SFieldUndefinedType, [FName^]);
    ftString:
      begin
        StrMove(Buffer, @FString^[1], Ord(FString^[0]));
        (PChar(Buffer) + Ord(FString^[0]))^ := #0;
      end;
    ftSmallint: Integer(Buffer^) := AsInteger;
    ftWord: Word(Buffer^) := AsInteger;
    ftInteger: LongInt(Buffer^) := AsInteger;
    ftTime: LongInt(Buffer^) := Round(Frac(AsDateTime) * MSecsPerDay);
    ftDate: LongInt(Buffer^) := Trunc(AsDateTime);
    ftDateTime: Double(Buffer^) := AsDateTime * MSecsPerDay;
    ftBCD,
    ftCurrency,
    ftFloat: Double(Buffer^) := AsFloat;
    ftBoolean: WordBool(Buffer^) := AsBoolean;
  else
    DBErrorFmt(SFieldUnsupportedType, [FName^]);
  end;
end;

procedure TParam.SetData(Buffer: Pointer);
begin
  case DataType of
    ftUnknown:
      DBErrorFmt(SFieldUndefinedType, [FName^]);
    ftString: AsString := StrPas(Buffer);
    ftWord: AsWord := Integer(Buffer^);
    ftSmallint: AsSmallInt := Integer(Buffer^);
    ftInteger: AsInteger := LongInt(Buffer^);
    ftTime: AsDateTime := LongInt(Buffer^) / MSecsPerDay;
    ftDate: AsDateTime := LongInt(Buffer^);
    ftDateTime: AsDateTime := Double(Buffer^) / MSecsPerDay;
    ftBCD: AsBCD := Double(Buffer^);
    ftCurrency: AsCurrency := Double(Buffer^);
    ftFloat: AsFloat := Double(Buffer^);
    ftBoolean: AsBoolean := WordBool(Buffer^);
  else
    DBErrorFmt(SFieldUnsupportedType, [FName^]);
  end;
end;

procedure TParam.SetText(const Value: string);
var
  L: Integer;
begin
  case DataType of
    ftString: AsString := Value;
    ftBoolean:
      begin
        L := Length(Value);
        if L = 0 then Clear
        else if AnsiCompareText(Value, Copy(LoadStr(STextFalse), 1, L)) = 0 then
          AsBoolean := False
        else if AnsiCompareText(Value, Copy(LoadStr(STextTrue), 1, L)) = 0 then
          AsBoolean := True
        else DBErrorFmt(SInvalidBoolValue, [Value, Name]);
      end;
    ftTime: AsTime := StrToTime(Value);
    ftDate: AsDate := StrToDate(Value);
    ftDateTime: AsDateTime := StrToDateTime(Value);
    ftCurrency: AsCurrency := StrToFloat(Value);
    ftBCD: AsBCD := StrToFloat(Value);
    ftFloat: AsFloat := StrToFloat(Value);
    ftSmallint: AsSmallInt := StrToInt(Value);
    ftWord: AsWord := StrToInt(Value);
    ftInteger: AsInteger := StrToInt(Value);
  end;
end;

procedure TParam.Assign(Param: TParam);
begin
  if Param <> nil then
  begin
    DataType := Param.DataType;
    if Param.IsNull then Clear else
    case DataType of
      ftString: AsString := Param.AsString;
      ftBoolean: AsBoolean := Param.AsBoolean;
      ftTime: AsTime := Param.AsTime;
      ftDate: AsDate := Param.AsDate;
      ftDateTime: AsDateTime := Param.AsDateTime;
      ftCurrency: AsCurrency := Param.AsCurrency;
      ftBCD: AsBCD := Param.AsBCD;
      ftFloat: AsFloat := Param.AsFloat;
      ftSmallint: AsSmallInt := Param.AsSmallInt;
      ftWord: AsWord := Param.AsWord;
      ftInteger: AsInteger := Param.AsInteger;
    end;
    FBound := Param.Bound;
    Name := Param.Name;
    if ParamType = ptUnknown then ParamType := Param.ParamType;
  end;
end;

procedure TParam.AssignField(Field: TField);
begin
  DataType := Field.DataType;
  if Field.IsNull then Clear else
    case Field.DataType of
      ftUnknown:
        DBErrorFmt(SFieldUndefinedType, [FName^]);
      ftString: AsString := Field.AsString;
      ftSmallint: AsSmallInt := Field.AsInteger;
      ftWord: AsWord := Field.AsInteger;
      ftInteger: AsInteger := Field.AsInteger;
      ftTime: AsTime := Field.AsDateTime;
      ftDate: AsDate := Field.AsDateTime;
      ftDateTime: AsDateTime := Field.AsDateTime;
      ftBCD: AsBCD := Field.AsFloat;
      ftCurrency: AsCurrency := Field.AsFloat;
      ftFloat: AsFloat := Field.AsFloat;
      ftBoolean: AsBoolean := Field.AsBoolean;
    else
      DBErrorFmt(SFieldUnsupportedType, [FName^]);
    end;
  FBound := True;
  Name := Field.FieldName;
end;

procedure TParam.AccessError;
begin
  DBErrorFmt(SParamAccessError, [FName^]);
end;

procedure TParam.Clear;
begin
  FNull := True;
  FData.FFloat := 0;
  AssignStr(FString, '');
end;

procedure TParam.InitValue;
begin
  FBound := True;
  FNull := False;
end;

procedure TParam.SetAsBoolean(Value: Boolean);
begin
  InitValue;
  DataType := ftBoolean;
  FData.FBoolean := Value;
end;

function TParam.IsValidInt(const Value: string; var RetValue: LongInt): Boolean;
var
  E: Integer;
begin
  Result := IsInteger(Value);
  if Result then
  begin
    Val(Value, RetValue, E);
    if E <> 0 then DBErrorFmt(SInvalidIntegerField, [Name]);
  end;
end;

function TParam.IsValidFloat(const Value: string; var RetValue: Double): Boolean;
var
  E: Integer;
begin
  Result := IsFloat(Value);
  if Result then
  begin
    Val(Value, RetValue, E);
    if E <> 0 then DBErrorFmt(SInvalidFloatField, [Name]);
  end;
end;

function TParam.GetAsBoolean: Boolean;
var
  FloatValue: Double;
  IntValue: LongInt;
  Len: Integer;
begin
  if IsNull then Result := False else
    case DataType of
      ftString:
        begin
          Len := Length(FString^);
          if Len = 0 then Result := False
          else begin
            if IsValidInt(FString^, IntValue) then
              Result := IntValue <> 0
            else if IsValidFloat(FString^, FloatValue) then
              Result := FloatValue <> 0
            else if AnsiCompareText(FString^, Copy(LoadStr(STextFalse), 1, Len)) = 0 then
              Result := False
            else if AnsiCompareText(FString^, Copy(LoadStr(STextTrue), 1, Len)) = 0 then
              Result := True
            else DBErrorFmt(SInvalidBoolValue, [FString^, Name]);
          end;
        end;
      ftSmallint,
      ftWord,
      ftInteger: Result := AsInteger <> 0;
      ftTime,
      ftDate,
      ftDateTime: Result := AsDateTime <> 0;
      ftBCD,
      ftCurrency,
      ftFloat: Result := AsFloat <> 0;
      ftBoolean: Result := FData.FBoolean;
    else
      AccessError;
    end;
end;

procedure TParam.SetAsFloat(Value: Double);
begin
  InitValue;
  DataType := ftFloat;
  FData.FFloat := Value;
end;

procedure TParam.SetAsCurrency(Value: Double);
begin
  SetAsFloat(Value);
  FDataType := ftCurrency;
end;

procedure TParam.SetAsBCD(Value: Double);
begin
  SetAsFloat(Value);
  FDataType := ftBCD;
end;

function TParam.GetAsFloat: Double;
var
  FloatValue: Double;
  IntValue: LongInt;
begin
  if IsNull then Result := 0 else
    case DataType of
      ftString:
        begin
          if Length(FString^) > 0 then
          begin
            if IsValidInt(FString^, IntValue) then
              Result := IntValue
            else if IsValidFloat(FString^, FloatValue) then
              Result := FloatValue
            else Result := 0;
          end
          else Result := 0;
        end;
      ftCurrency,
      ftBCD,
      ftFloat:
        Result := FData.FFloat;
      ftSmallint,
      ftWord,
      ftInteger: Result := AsInteger;
      ftTime,
      ftDate,
      ftDateTime: Result := AsDateTime;
    else
      AccessError;
    end;
end;

procedure TParam.SetAsInteger(Value: Longint);
begin
  InitValue;
  DataType := ftInteger;
  FData.FInteger := Value;
end;

procedure TParam.SetAsWord(Value: LongInt);
begin
  SetAsInteger(Value);
  FDataType := ftWord;
end;

procedure TParam.SetAsSmallInt(Value: LongInt);
begin
  SetAsInteger(Value);
  FDataType := ftSmallint;
end;

function TParam.GetAsInteger: Longint;
var
  FloatValue: Double;
  IntValue: LongInt;
begin
  if IsNull then Result := 0 else
    case DataType of
      ftString:
        begin
          if Length(FString^) > 0 then
          begin
            if IsValidInt(FString^, IntValue) then
              Result := IntValue
            else if IsValidFloat(FString^, FloatValue) then
              Result := Trunc(FloatValue)
            else Result := 0;
          end
          else Result := 0;
        end;
      ftWord,
      ftSmallint,
      ftInteger:
        Result := FData.FInteger;
      ftCurrency,
      ftBCD,
      ftFloat:
        Result := Trunc(AsFloat);
      ftTime,
      ftDate,
      ftDateTime:
        Result := Trunc(AsDateTime);
    else
      AccessError;
    end;
end;

procedure TParam.SetAsString(const Value: string);
begin
  InitValue;
  DataType := ftString;
  AssignStr(FString, Value);
end;

function TParam.GetAsString: string;
begin
  if IsNull then Result := '' else
    case DataType of
      ftUnknown:
        DBErrorFmt(SFieldUndefinedType, [FName^]);
      ftString: Result := FString^;
      ftWord,
      ftSmallint,
      ftInteger: Result := IntToStr(FData.FInteger);
      ftDate: Result := DateToStr(FData.FDateTime);
      ftTime: Result := TimeToStr(FData.FDateTime);
      ftDateTime: Result := DateTimeToStr(FData.FDateTime);
      ftCurrency,
      ftBCD,
      ftFloat: Result := FloatToStr(FData.FFloat);
      ftBoolean:
        begin
          if AsBoolean then Result := LoadStr(STextTrue)
          else Result := LoadStr(STextFalse);
        end;
    else
      DBErrorFmt(SFieldUnsupportedType, [FName^]);
    end;
end;

procedure TParam.SetAsDate(Value: TDateTime);
begin
  InitValue;
  DataType := ftDate;
  FData.FDateTime := Value;
end;

procedure TParam.SetAsTime(Value: TDateTime);
begin
  SetAsDate(Value);
  FDataType := ftTime;
end;

procedure TParam.SetAsDateTime(Value: TDateTime);
begin
  SetAsDate(Value);
  FDataType := ftDateTime;
end;

function TParam.GetAsDateTime: TDateTime;
begin
  if IsNull then Result := 0 else
    case DataType of
      ftString: Result := StrToDateTime(AsString);
      ftDate,
      ftTime,
      ftDateTime:
        Result := FData.FDateTime;
      ftWord,
      ftSmallint,
      ftInteger:
        Result := AsInteger;
      ftCurrency,
      ftBCD,
      ftFloat:
        Result := AsFloat;
    else
      AccessError;
    end;
end;

{ TQueryDataLink }

constructor TQueryDataLink.Create(AQuery: TQuery);
begin
  inherited Create;
  FQuery := AQuery;
end;

procedure TQueryDataLink.ActiveChanged;
begin
  if FQuery.Active then FQuery.RefreshParams;
end;

procedure TQueryDataLink.RecordChanged(Field: TField);
begin
  if (Field = nil) and FQuery.Active then FQuery.RefreshParams;
end;

procedure TQueryDataLink.CheckBrowseMode;
begin
  if FQuery.Active then FQuery.CheckBrowseMode;
end;

{ TStoredProc }

constructor TStoredProc.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FParams := TParams.Create;
  FProcName := NullStr;
  FParamDesc := nil;
  FRecordBuffer := nil;
  FServerDescs := nil;
end;

destructor TStoredProc.Destroy;
begin
  Destroying;
  Disconnect;
  FParams.Free;
  DisposeStr(FProcName);
  inherited Destroy;
end;

procedure TStoredProc.Disconnect;
begin
  Close;
  UnPrepare;
end;

function TStoredProc.CreateCursor(GenHandle: Boolean): HDBICur;
begin
  if StoredProcName <> '' then
  begin
    SetPrepared(True);
    Result := GetCursor(GenHandle);
  end
  else Result := nil;
end;

function TStoredProc.CreateHandle: HDBICur;
begin
  Result := CreateCursor(True);
end;

function TStoredProc.GetCursor(GenHandle: Boolean): HDBICur;
var
  PCursor: phDBICur;
  CursorProps: CurProps;
begin
  Result := nil;
  if GenHandle then PCursor := @Result
  else PCursor := nil;
  BindParams;
  Check(DbiQExec(StmtHandle, PCursor));
  GetResults;
end;

procedure TStoredProc.ExecProc;
begin
  CheckInActive;
  SetDBFlag(dbfExecProc, True);
  CreateCursor(False);
end;

function TStoredProc.GetProcName: string;
begin
  Result := FProcName^;
end;

procedure TStoredProc.SetProcName(const Value: string);
begin
  CheckInactive;
  if Value <> FProcName^ then
  begin
    AssignStr(FProcName, Value);
    FreeStatement;
    FParams.Clear;
  end;
end;

procedure TStoredProc.SetOverLoad(Value: Word);
begin
  CheckInactive;
  if Value <> OverLoad then
  begin
    FOverLoad := Value;
    FreeStatement;
    FParams.Clear;
  end;
end;

function TStoredProc.GetParamsCount: Word;
begin
  Result := FParams.Count;
end;

procedure TStoredProc.CreateParamDesc;
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
  Desc: SPParamDesc;
  Database: TDatabase;
  Cursor: HDBICur;
  Buffer: array[0..DBIMAXSPNAMELEN] of char;
  Name: string;
  DataType: TFieldType;
begin
  Database := Session.OpenDatabase(DatabaseName);
  try
    AnsiToNative(Database.Locale, StoredProcName, Buffer, DBIMAXSPNAMELEN);
    if DbiOpenSPParamList(Database.Handle, Buffer, False, OverLoad, Cursor) = 0 then
    try
      while DbiGetNextRecord(Cursor, dbiNOLOCK, @Desc, nil) = 0 do
        with Desc do
        begin
          NativeToAnsi(Database.Locale, szName, Name);
          if (TParamType(eParamType) = ptResult) and (Name = '') then
            Name := LoadStr(SResultName);
          if uFldType < MAXLOGFLDTYPES then DataType := TypeMap[uFldType]
          else DataType := ftUnknown;
          if (uFldType = fldFLOAT) and (uSubType = fldstMONEY) then
            DataType := ftCurrency;
          FParams.CreateParam(DataType, Name, TParamType(eParamType));
        end;
      SetServerParams;
    finally
      DbiCloseCursor(Cursor);
    end;
  finally
    Session.CloseDatabase(Database);
  end;
end;

procedure TStoredProc.SetServerParams;
var
  I: Integer;
  DescPtr: PServerDesc;
begin
  FServerDescs := StrAlloc(Params.Count * SizeOf(TServerDesc));
  DescPtr := PServerDesc(FServerDescs);
  for I := 0 to Params.Count - 1 do
    with Params[I], DescPtr^ do
    begin
      ParamName := Name;
      BindType := DataType;
      Inc(DescPtr);
    end;
end;

function TStoredProc.CheckServerParams: Boolean;
var
  I, J: Integer;
  DescPtr: PServerDesc;
begin
  if FServerDescs = nil then
  begin
    SetServerParams;
    Result := False;
  end else
  begin
    DescPtr := PServerDesc(FServerDescs);
    for I := 0 to StrBufSize(FServerDescs) div SizeOf(TServerDesc) - 1 do
    begin
      for J := 0 to Params.Count - 1 do
        with Params.Items[J], DescPtr^ do
          if (Name = ParamName) and (DataType <> BindType) then
          begin
            Result := False;
            Exit;
          end;
      Inc(DescPtr);
    end;
    Result := True;
  end;
end;

function TStoredProc.DescriptionsAvailable: Boolean;
var
  Database: TDatabase;
  Cursor: HDBICur;
  Buffer: array[0..DBIMAXSPNAMELEN] of char;
begin
  Result := False;
  Database := Session.OpenDatabase(DatabaseName);
  try
    AnsiToNative(Database.Locale, StoredProcName, Buffer, DBIMAXSPNAMELEN);
    Result := DbiOpenSPParamList(Database.Handle, Buffer, False, OverLoad, Cursor) = 0;
    if Result then DbiCloseCursor(Cursor);
  finally
    Session.CloseDatabase(Database);
  end;
end;

procedure TStoredProc.PrepareProc;
const
  TypeMap: array[TFieldType] of Byte = (
    fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
    fldFLOAT, fldFLOAT, fldFLOAT, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
    fldVARBYTES, fldBLOB, fldBLOB, fldBLOB);
var
  I: Integer;
  Desc: PSPParamDesc;
  NumBytes, Offset: Word;
  Buffer: array[0..DBIMAXSPNAMELEN] of char;
begin
  FParamDesc := StrAlloc(FParams.Count * SizeOf(SPParamDesc));
  FillChar(FParamDesc^, StrBufSize(FParamDesc), 0);
  Desc := PSPParamDesc(FParamDesc);

  NumBytes := 0;
  for I := 0 to FParams.Count - 1 do
    with Params[I] do
      if DataType = ftString then Inc(NumBytes, High(string) + 2)
      else Inc(NumBytes, GetDataSize + 2);

  FRecordBuffer := StrAlloc(NumBytes);
  FillChar(FRecordBuffer^, NumBytes, 0);
  Offset := 0;
  for I := 0 to FParams.Count - 1 do
  begin
    with Params[I] do
    begin
      with Desc^ do
      begin
        if DataType = ftUnknown then
          DBErrorFmt(SNoParameterValue, [Name]);
        if ParamType = ptUnknown then
          DBErrorFmt(SNoParameterType, [Name]);
        if FBindMode = pbByName then
          AnsiToNative(Locale, Name, szName, DBIMAXNAMELEN)
        else uParamNum := I + 1;
        eParamType := STMTParamType(ParamType);
        uFldType := TypeMap[DataType];
        if DataType = ftCurrency then uSubType := fldstMONEY;
        if uFldType = fldZString then
        begin
          uLen := High(string);
          iUnits1 := uLen - 1;
        end else
          uLen := GetDataSize;
        uOffset := Offset;
        Inc(Offset, uLen);
        uNullOffset := NumBytes - 2 * (I + 1);
      end;
      if ParamType in [ptInput, ptInputOutput] then
        Integer(Pointer(FRecordBuffer + NumBytes - 2 * (I + 1))^) := IndNull;
      Inc(Desc);
    end;
  end;
  AnsiToNative(Locale, StoredProcName, Buffer, DBIMAXSPNAMELEN);
  Check(DbiQPrepareProc(DBHandle, Buffer, FParams.Count,
    PSPParamDesc(FParamDesc), nil, FStmtHandle));
end;

procedure TStoredProc.GetResults;
var
  I: Integer;
  Len: Word;
  IsBlank: WordBool;
  Buffer: array[0..255] of char;
  CurPtr: PChar;
  IntPtr: ^Integer;
  NumBytes: Word;
begin
  CurPtr := FRecordBuffer;
  NumBytes := StrBufSize(FRecordBuffer);
  for I := 0 to FParams.Count - 1 do
    with Params[I] do
    begin
      if ParamType in [ptOutput, ptInputOutput, ptResult] then
      begin
        SetData(CurPtr);
        IntPtr := Pointer(FRecordBuffer + NumBytes - 2 * (I + 1));
        if IntPtr^ = IndNull then Clear
        else if IntPtr^ = IndTrunc then DBErrorFmt(STruncationError, [Name]);
      end;
      if DataType = ftString then Inc(CurPtr, High(string))
      else Inc(CurPtr, GetDataSize);
    end;
end;

procedure TStoredProc.BindParams;
var
  I: Integer;
  CurPtr: PChar;
  NumBytes: Word;
  IntPtr: ^Integer;
  DrvName: array[0..SizeOf(TSymbolStr) - 1] of Char;
  DrvLocale: TLocale;
begin
  if FRecordBuffer = nil then Exit;
  if not CheckServerParams then
  begin
    SetPrepared(False);
    SetPrepared(True);
  end;
  DrvName[0] := #0;
  DrvLocale := nil;
  DbiGetProp(HDBIOBJ(StmtHandle), stmtLANGDRVNAME, @DrvName, SizeOf(DrvName), NumBytes);
  if StrLen(DrvName) > 0 then OsLdLoadBySymbName(DrvName, DrvLocale);
  try
    NumBytes := StrBufSize(FRecordBuffer);
    CurPtr := FRecordBuffer;
    for I := 0 to FParams.Count - 1 do
    begin
      with Params[I] do
      begin
        if ParamType in [ptInput, ptInputOutput] then
        begin
          GetData(CurPtr);
          IntPtr := Pointer(FRecordBuffer + NumBytes - 2 * (I + 1));
          if IsNull then IntPtr^ := IndNull
          else IntPtr^ := 0;
        end;
        if DataType = ftString then
        begin
          if DrvLocale <> nil then
            AnsiToNativeBuf(DrvLocale, CurPtr, CurPtr, GetDataSize);
          Inc(CurPtr, High(string));
        end
        else Inc(CurPtr, GetDataSize);
      end;
    end;
    Check(DbiQSetProcParams(StmtHandle, FParams.Count,
      PSPParamDesc(FParamDesc), FRecordBuffer));
  finally
    if DrvLocale <> nil then OsLdUnloadObj(DrvLocale);
  end;
end;

procedure TStoredProc.SetPrepared(Value: Boolean);
begin
  if Handle <> nil then DBError(SDataSetOpen);
  if Prepared <> Value then
  begin
    if Value then
      try
        if FParams.Count = 0 then CreateParamDesc;
        if not FQueryMode then PrepareProc;
        FPrepared := True;
      except
        FreeStatement;
        raise;
      end
    else FreeStatement;
  end;
end;

procedure TStoredProc.Prepare;
begin
  SetDBFlag(dbfStoredProc, True);
  SetPrepared(True);
end;

procedure TStoredProc.UnPrepare;
begin
  SetPrepared(False);
  SetDBFlag(dbfStoredProc, False);
  SetDBFlag(dbfExecProc, False);
end;

procedure TStoredProc.FreeStatement;
begin
  if StmtHandle <> nil then DbiQFree(FStmtHandle);
  StrDispose(FParamDesc);
  FParamDesc := nil;
  StrDispose(FRecordBuffer);
  FRecordBuffer := nil;
  StrDispose(FServerDescs);
  FServerDescs := nil;
  FPrepared := False;
end;

procedure TStoredProc.SetPrepare(Value: Boolean);
begin
  if Value then Prepare
  else UnPrepare;
end;

procedure TStoredProc.SetDBFlag(Flag: Integer; Value: Boolean);
begin
  if not Value and (DBFlags - [Flag] = []) then SetPrepared(False);
  inherited SetDBFlag(Flag, Value);
end;

procedure TStoredProc.CopyParams(Value: TParams);
begin
  if not Prepared and (FParams.Count = 0) then
  try
    FQueryMode := True;
    Prepare;
    Value.Assign(FParams);
  finally
    UnPrepare;
    FQueryMode := False;
  end else
    Value.Assign(FParams);
end;

procedure TStoredProc.SetParamsList(Value: TParams);
begin
  CheckInactive;
  if Prepared then
  begin
    SetPrepared(False);
    FParams.Assign(Value);
    SetPrepared(True);
  end else
    FParams.Assign(Value);
end;

function TStoredProc.ParamByName(const Value: string): TParam;
begin
  Result := FParams.ParamByName(Value);
end;

{ TQuery }

constructor TQuery.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FSQL := TStringList.Create;
  TStringList(SQL).OnChange := QueryChanged;
  FParams := TParams.Create;
  FDataLink := TQueryDataLink.Create(Self);
  FText := nil;
  RequestLive := False;
end;

destructor TQuery.Destroy;
begin
  Destroying;
  Disconnect;
  SQL.Free;
  StrDispose(FText);
  FParams.Free;
  FDataLink.Free;
  StrDispose(SQLBinary);
  inherited Destroy;
end;

procedure TQuery.Disconnect;
begin
  Close;
  UnPrepare;
end;

procedure TQuery.SetPrepare(Value: Boolean);
begin
  if Value then Prepare
  else UnPrepare;
end;

procedure TQuery.Prepare;
begin
  SetDBFlag(dbfPrepared, True);
  SetPrepared(True);
end;

procedure TQuery.UnPrepare;
begin
  SetPrepared(False);
  SetDBFlag(dbfPrepared, False);
end;

procedure TQuery.SetDataSource(Value: TDataSource);
begin
  if IsLinkedTo(Value) then DBError(SCircularDataLink);
  FDataLink.DataSource := Value;
end;

function TQuery.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

procedure TQuery.SetQuery(Value: TStrings);
begin
  Disconnect;
  TStringList(SQL).OnChange := nil;
  SQL.Assign(Value);
  TStringList(SQL).OnChange := QueryChanged;
  QueryChanged(nil);
end;

procedure TQuery.QueryChanged(Sender: TObject);
var
  List: TParams;
begin
  Disconnect;
  StrDispose(FText);
  FText := SQL.GetText;
  StrDispose(SQLBinary);
  SQLBinary := nil;
  List := TParams.Create;
  try
    CreateParams(List, Text);
    List.AssignValues(FParams);
    FParams.Free;
    FParams := List;
  except
    List.Free;
  end;
end;

procedure TQuery.SetParamsList(Value: TParams);
begin
  FParams.AssignValues(Value);
end;

function TQuery.GetParamsCount: Word;
begin
  Result := FParams.Count;
end;

procedure TQuery.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineBinaryProperty('Data', ReadBinaryData, WriteBinaryData, SQLBinary <> nil);
end;

procedure TQuery.ReadBinaryData(Stream: TStream);
begin
  SQLBinary := StrAlloc(Stream.Size);
  Stream.ReadBuffer(SQLBinary^, Stream.Size);
end;

procedure TQuery.WriteBinaryData(Stream: TStream);
begin
  Stream.WriteBuffer(SQLBinary^, StrBufSize(SQLBinary));
end;

procedure TQuery.SetPrepared(Value: Boolean);
begin
  if Handle <> nil then DBError(SDataSetOpen);
  if Value <> Prepared then
  begin
    if Value then
    begin
      if StrLen(Text) > 1 then PrepareSQL(Text)
      else DBError(SEmptySQLStatement);
    end
    else FreeStatement;
    FPrepared := Value;
  end;
end;

procedure TQuery.FreeStatement;
begin
  if StmtHandle <> nil then DbiQFree(FStmtHandle);
end;

procedure TQuery.SetParamsFromCursor;
var
  I: Integer;
  DataSet: TDataSet;
  Field: TField;
begin
  if FDataLink.DataSource <> nil then
  begin
    DataSet := FDataLink.DataSource.DataSet;
    if DataSet <> nil then
    begin
      if DataSet.Active then
        for I := 0 to FParams.Count - 1 do
          with FParams[I] do
            if not Bound then
            begin
              AssignField(DataSet.FieldByName(Name));
              Bound := False;
            end;
    end;
  end;
end;

procedure TQuery.RefreshParams;
var
  DataSet: TDataSet;
begin
  DisableControls;
  try
    if FDataLink.DataSource <> nil then
    begin
      DataSet := FDataLink.DataSource.DataSet;
      if DataSet <> nil then
        if DataSet.Active and (DataSet.State <> dsSetKey) then
        begin
          Close;
          Open;
        end;
    end;
  finally
    EnableControls;
  end;
end;

function TQuery.ParamByName(const Value: string): TParam;
begin
  Result := FParams.ParamByName(Value);
end;

procedure TQuery.CreateParams(List: TParams; const Value: PChar);
var
  CurPos, StartPos: PChar;
  BufLen: Word;
  CurChar: Char;
  Literal: Boolean;
  EmbeddedLiteral: Boolean;
  Name: string;

  function NameDelimiter: Boolean;
  begin
    Result := CurChar in [' ', ',', ';', ')', #13, #10];
  end;

  function IsLiteral: Boolean;
  begin
    Result := CurChar in ['''', '"'];
  end;

  function StripLiterals(Buffer: PChar): string;
  var
    Len: Word;
    TempBuf: PChar;

    procedure StripChar(Value: Char);
    begin
      if TempBuf^ = Value then
        StrMove(TempBuf, TempBuf + 1, Len - 1);
      if TempBuf[StrLen(TempBuf) - 1] = Value then
        TempBuf[StrLen(TempBuf) - 1] := #0;
    end;

  begin
    Len := StrLen(Buffer) + 1;
    TempBuf := AllocMem(Len);
    Result := '';
    try
      StrCopy(TempBuf, Buffer);
      StripChar('''');
      StripChar('"');
      Result := StrPas(TempBuf);
    finally
      FreeMem(TempBuf, Len);
    end;
  end;

begin
  BufLen := StrLen(Value) + 1;
  CurPos := Value;
  Literal := False;
  EmbeddedLiteral := False;
  repeat
    CurChar := CurPos^;
    if (CurChar = ':') and not Literal and ((CurPos + 1)^ <> ':') then
    begin
      StartPos := CurPos;
      while (CurChar <> #0) and (Literal or not NameDelimiter) do
      begin
        Inc(CurPos);
        CurChar := CurPos^;
        if IsLiteral then
        begin
          Literal := Literal xor True;
          if CurPos = StartPos + 1 then EmbeddedLiteral := True;
        end;
      end;
      CurPos^ := #0;
      if EmbeddedLiteral then
      begin
        Name := StripLiterals(StartPos + 1);
        EmbeddedLiteral := False;
      end
      else Name := StrPas(StartPos + 1);
      List.CreateParam(ftUnknown, Name, ptUnknown);
      CurPos^ := CurChar;
      StartPos^ := '?';
      Inc(StartPos);
      StrMove(StartPos, CurPos, StrLen(CurPos) + 1);
      CurPos := StartPos;
    end
    else if (CurChar = ':') and not Literal and ((CurPos + 1)^ = ':') then
      StrMove(CurPos, CurPos + 1, StrLen(CurPos) + 1)
    else if IsLiteral then Literal := Literal xor True;
    Inc(CurPos);
  until CurChar = #0;
end;

function TQuery.CreateCursor(GenHandle: Boolean): HDBICur;
begin
  if SQL.Count > 0 then
  begin
    SetPrepared(True);
    if FDataLink.DataSource <> nil then SetParamsFromCursor;
    Result := GetQueryCursor(GenHandle);
  end
  else Result := nil;
end;

function TQuery.CreateHandle: HDBICur;
begin
  Result := CreateCursor(True)
end;

procedure TQuery.ExecSQL;
begin
  CheckInActive;
  SetDBFlag(dbfExecSQL, True);
  try
    CreateCursor(False);
  finally
    SetDBFlag(dbfExecSQL, False);
  end;
end;

function TQuery.GetQueryCursor(GenHandle: Boolean): HDBICur;
var
  PCursor: phDBICur;
  CursorProps: CurProps;
begin
  Result := nil;
  if GenHandle then PCursor := @Result
  else PCursor := nil;
  if FParams.Count > 0 then SetParams;
  Check(DbiQExec(StmtHandle, PCursor));
end;

procedure TQuery.SetParams;
const
  TypeMap: array[TFieldType] of Byte = (
    fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
    fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
    fldVARBYTES, fldBLOB, fldBLOB, fldBLOB);
var
  DescBuffer: PFieldDescList;
  I: Integer;
  NumBytes: Word;
  Param : TParam;
  FieldDesc: PFLDDesc;
  RecBuffer: PChar;
  CurPtr, FieldPtr, NullPtr: PChar;
  DrvName: array[0..SizeOf(TSymbolStr) - 1] of Char;
  DrvLocale: TLocale;
begin
  DescBuffer := AllocMem(FParams.Count * SizeOf(FLDDesc));
  FieldDesc := PFLDDesc(DescBuffer);
  NumBytes := 2;
  DrvName[0] := #0;
  DrvLocale := nil;
  DbiGetProp(HDBIOBJ(StmtHandle), stmtLANGDRVNAME, @DrvName, SizeOf(DrvName), NumBytes);
  if StrLen(DrvName) > 0 then OsLdLoadBySymbName(DrvName, DrvLocale);
  try
    for I := 0 to FParams.Count - 1 do
      Inc(NumBytes, Params[I].GetDataSize);
    RecBuffer := AllocMem(NumBytes);
    NullPtr := RecBuffer + NumBytes - 2;
    Integer(Pointer(NullPtr)^) := -1;
    CurPtr := RecBuffer;
    try
      for I := 0 to FParams.Count - 1 do
      begin
        Param := Params[I];
        with FieldDesc^ do
        begin
          iFldType := TypeMap[Param.DataType];
          if iFldType = fldUNKNOWN then
            DBErrorFmt(SNoParameterValue, [Param.Name]);
          iFldNum := I + 1;
          iLen := Param.GetDataSize;
          if iFldType = fldZString then iUnits1 := iLen - 1;
          iOffset := CurPtr - RecBuffer;
          if Param.IsNull then iNullOffset := NullPtr - RecBuffer;
        end;
        with Param do
        begin
          GetData(CurPtr);
          if (FieldDesc^.iFldType = fldZString) and (DrvLocale <> nil) then
            AnsiToNativeBuf(DrvLocale, CurPtr, CurPtr, GetDataSize);
          Inc(CurPtr, GetDataSize);
          Inc(FieldDesc);
        end;
      end;
      Check(DbiQSetParams(StmtHandle, FParams.Count,
        PFLDDesc(DescBuffer), RecBuffer));
    finally
      FreeMem(RecBuffer, NumBytes);
    end;
  finally
    FreeMem(DescBuffer, FParams.Count * SizeOf(FLDDesc));
    if DrvLocale <> nil then OsLdUnloadObj(DrvLocale);
  end;
end;

procedure TQuery.SetDBFlag(Flag: Integer; Value: Boolean);
var
  NewConnection: Boolean;
begin
  if Value then
  begin
    NewConnection := DBFlags = [];
    inherited SetDBFlag(Flag, Value);
    if not (csReading in ComponentState) and NewConnection then
      FLocal := not Database.IsSQLBased;
  end
  else begin
    if DBFlags - [Flag] = [] then SetPrepared(False);
    inherited SetDBFlag(Flag, Value);
  end;
end;

procedure TQuery.PrepareSQL(Value: PChar);
begin
  GetStatementHandle(Value);
  if not Local then
    Check(DBiSetProp(hDbiObj(StmtHandle), stmtUNIDIRECTIONAL, LongInt(FUniDirectional)));
end;

procedure TQuery.GetStatementHandle(SQLText: PChar);
const
  DataType: array[Boolean] of LongInt = (Ord(wantCanned), Ord(wantLive));
begin
  if Local then
  begin
    while not CheckOpen(DbiQPrepare(DBHandle, qrylangSQL, SQLText, FStmtHandle)) do
      {Retry};
    Check(DBiSetProp(hDbiObj(StmtHandle), stmtLIVENESS, DataType[RequestLive]));
    Check(DBiSetProp(hDbiObj(StmtHandle), stmtAUXTBLS, LongInt(False)));
  end else
  begin
    if RequestLive then
      Check(DbiQPrepareExt(DBHandle, qrylangSQL, SQLText, qprepFORUPDATE, FStmtHandle))
    else Check(DbiQPrepare(DBHandle, qrylangSQL, SQLText, FStmtHandle));
  end;
end;

function TQuery.GetSQLText: PChar;
var
  BufLen: Word;
  I: Integer;
  StrEnd: PChar;
  StrBuf: array[0..255] of Char;
begin
  BufLen := 1;
  for I := 0 to SQL.Count - 1 do
    Inc(BufLen, Ord(SQL.Strings[I][0]) + 1);
  Result := StrAlloc(BufLen);
  try
    StrEnd := Result;
    for I := 0 to SQL.Count - 1 do
    begin
      StrPCopy(StrBuf, SQL.Strings[I]);
      StrEnd := StrECopy(StrEnd, StrBuf);
      StrEnd := StrECopy(StrEnd, ' ');
    end;
  except
    StrDispose(Result);
    raise;
  end;
end;

{ TStringField }

constructor TStringField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftString);
  Size := 20;
  Transliterate := True;
end;

function TStringField.GetAsBoolean: Boolean;
var
  S: string[15];
begin
  S := GetAsString;
  Result := (Length(S) > 0) and (S[1] in ['T', 't', 'Y', 'y']);
end;

function TStringField.GetAsDateTime: TDateTime;
begin
  Result := StrToDateTime(GetAsString);
end;

function TStringField.GetAsFloat: Double;
begin
  Result := StrToFloat(GetAsString);
end;

function TStringField.GetAsInteger: Longint;
begin
  Result := StrToInt(GetAsString);
end;

function TStringField.GetAsString: string;
var
  Buffer: array[0..255] of Char;
begin
  if GetData(@Buffer) then
    if Transliterate then
      NativeToAnsi(DataSet.Locale, Buffer, Result)
    else
    begin
      Result[0] := Chr(StrLen(Buffer));
      Move(Buffer[0], Result[1], Ord(Result[0]));
    end
  else
    Result := '';
end;

function TStringField.GetDefaultWidth: Integer;
begin
  Result := Size;
end;

procedure TStringField.GetText(var Text: string; DisplayText: Boolean);
begin
  if DisplayText and (EditMaskPtr^ <> '') then
    Text := FormatMaskText(EditMaskPtr^, GetAsString) else
    Text := GetAsString;
end;

procedure TStringField.SetAsBoolean(Value: Boolean);
const
  Values: array[Boolean] of string[1] = ('F', 'T');
begin
  SetAsString(Values[Value]);
end;

procedure TStringField.SetAsDateTime(Value: TDateTime);
begin
  SetAsString(DateTimeToStr(Value));
end;

procedure TStringField.SetAsFloat(Value: Double);
begin
  SetAsString(FloatToStr(Value));
end;

procedure TStringField.SetAsInteger(Value: Longint);
begin
  SetAsString(IntToStr(Value));
end;

procedure TStringField.SetAsString(const Value: string);
var
  Buffer: array[0..255] of Char;
begin
  if Transliterate then
    AnsiToNative(DataSet.Locale, Value, Buffer, Size) else
    StrPLCopy(Buffer, Value, Size);
  SetData(@Buffer);
end;

{ TNumericField }

constructor TNumericField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Alignment := taRightJustify;
  FDisplayFormat := NullStr;
  FEditFormat := NullStr;
end;

destructor TNumericField.Destroy;
begin
  DisposeStr(FEditFormat);
  DisposeStr(FDisplayFormat);
  inherited Destroy;
end;

function TNumericField.GetDisplayFormat: string;
begin
  Result := FDisplayFormat^;
end;

function TNumericField.GetEditFormat: string;
begin
  Result := FEditFormat^;
end;

procedure TNumericField.RangeError(Value, Min, Max: Double);
begin
  DBErrorFmt(SFieldRangeError, [Value, DisplayName^, Min, Max]);
end;

procedure TNumericField.SetDisplayFormat(const Value: string);
begin
  if FDisplayFormat^ <> Value then
  begin
    AssignStr(FDisplayFormat, Value);
    PropertyChanged(False);
  end;
end;

procedure TNumericField.SetEditFormat(const Value: string);
begin
  if FEditFormat^ <> Value then
  begin
    AssignStr(FEditFormat, Value);
    PropertyChanged(False);
  end;
end;

{ TIntegerField }

constructor TIntegerField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftInteger);
  FMinRange := Low(Longint);
  FMaxRange := High(Longint);
end;

procedure TIntegerField.CheckRange(Value, Min, Max: Longint);
begin
  if (Value < Min) or (Value > Max) then RangeError(Value, Min, Max);
end;

function TIntegerField.GetAsFloat: Double;
begin
  Result := GetAsInteger;
end;

function TIntegerField.GetAsInteger: Longint;
begin
  if not GetValue(Result) then Result := 0;
end;

function TIntegerField.GetAsString: string;
var
  L: Longint;
begin
  if GetValue(L) then Str(L, Result) else Result := '';
end;

procedure TIntegerField.GetText(var Text: string; DisplayText: Boolean);
var
  FmtStr: PString;
  L: Longint;
  Buffer: array[0..223] of Char;
begin
  if GetValue(L) then
  begin
    if DisplayText or (FEditFormat^ = '') then
      FmtStr := FDisplayFormat else
      FmtStr := FEditFormat;
    if FmtStr^ = '' then
      Str(L, Text)
    else
      Text[0] := Chr(FloatToTextFmt(@Text[1], L, StrPLCopy(Buffer,
        FmtStr^, SizeOf(Buffer) - 1)));
  end else
    Text := '';
end;

function TIntegerField.GetValue(var Value: Longint): Boolean;
var
  Data: record
    case Integer of
      0: (I: Integer);
      1: (W: Word);
      2: (L: Longint);
  end;
begin
  Result := GetData(@Data);
  if Result then
    case DataType of
      ftSmallint: Value := Data.I;
      ftWord: Value := Data.W;
    else
      Value := Data.L;
    end;
end;

function TIntegerField.IsValidChar(Ch: Char): Boolean;
begin
  Result := Ch in ['+', '-', '0'..'9'];
end;

procedure TIntegerField.SetAsFloat(Value: Double);
begin
  SetAsInteger(Round(Value));
end;

procedure TIntegerField.SetAsInteger(Value: Longint);
begin
  if (FMinValue <> 0) or (FMaxValue <> 0) then
    CheckRange(Value, FMinValue, FMaxValue)
  else
    CheckRange(Value, FMinRange, FMaxRange);
  SetData(@Value);
end;

procedure TIntegerField.SetAsString(const Value: string);
var
  E: Integer;
  L: Longint;
begin
  if Value = '' then Clear else
  begin
    Val(Value, L, E);
    if E <> 0 then DBErrorFmt(SInvalidIntegerValue, [Value, DisplayName^]);
    SetAsInteger(L);
  end;
end;

procedure TIntegerField.SetMaxValue(Value: Longint);
begin
  CheckRange(Value, FMinRange, FMaxRange);
  FMaxValue := Value;
end;

procedure TIntegerField.SetMinValue(Value: Longint);
begin
  CheckRange(Value, FMinRange, FMaxRange);
  FMinValue := Value;
end;

{ TSmallintField }

constructor TSmallintField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftSmallint);
  FMinRange := Low(Smallint);
  FMaxRange := High(Smallint);
end;

{ TWordField }

constructor TWordField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftWord);
  FMinRange := Low(Word);
  FMaxRange := High(Word);
end;

{ TFloatField }

constructor TFloatField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftFloat);
  FPrecision := 15;
end;

function TFloatField.GetAsFloat: Double;
begin
  if not GetValue(Result) then Result := 0;
end;

function TFloatField.GetAsInteger: Longint;
begin
  Result := Round(GetAsFloat);
end;

function TFloatField.GetAsString: string;
var
  F: Double;
begin
  if GetValue(F) then Result := FloatToStr(F) else Result := '';
end;

procedure TFloatField.GetText(var Text: string; DisplayText: Boolean);
var
  Format: TFloatFormat;
  Digits: Integer;
  FmtStr: PString;
  F: Double;
  Buffer: array[0..223] of Char;
begin
  if GetValue(F) then
  begin
    if DisplayText or (FEditFormat^ = '') then
      FmtStr := FDisplayFormat else
      FmtStr := FEditFormat;
    if FmtStr^ = '' then
    begin
      if FCurrency then
      begin
        if DisplayText then Format := ffCurrency else Format := ffFixed;
        Digits := CurrencyDecimals;
      end else
      begin
        Format := ffGeneral;
        Digits := 0;
      end;
      Text[0] := Chr(FloatToText(@Text[1], F, Format, FPrecision, Digits));
    end else
      Text[0] := Chr(FloatToTextFmt(@Text[1], F, StrPLCopy(Buffer,
        FmtStr^, SizeOf(Buffer) - 1)));
  end else
    Text := '';
end;

function TFloatField.GetValue(var Value: Double): Boolean;
var
  BCD: FMTBcd;
begin
  if DataType <> ftBCD then Result := GetData(@Value) else
  begin
    Result := GetData(@BCD);
    if Result then DbiBcdToFloat(BCD, Value);
  end;
end;

function TFloatField.IsValidChar(Ch: Char): Boolean;
begin
  Result := Ch in [DecimalSeparator, '+', '-', '0'..'9', 'E', 'e'];
end;

procedure TFloatField.SetAsFloat(Value: Double);
var
  BCD: FMTBcd;
begin
  if FCheckRange and ((Value < FMinValue) or (Value > FMaxValue)) then
    RangeError(Value, FMinValue, FMaxValue);
  if DataType <> ftBCD then SetData(@Value) else
  begin
    DbiBcdFromFloat(Value, 32, Size, BCD);
    SetData(@BCD);
  end;
end;

procedure TFloatField.SetAsInteger(Value: Longint);
begin
  SetAsFloat(Value);
end;

procedure TFloatField.SetAsString(const Value: string);
var
  F: Extended;
  Buffer: array[0..63] of Char;
begin
  if Value = '' then Clear else
  begin
    if not TextToFloat(StrPLCopy(Buffer, Value, SizeOf(Buffer) - 1), F) then
      DBErrorFmt(SInvalidFloatValue, [Value, DisplayName^]);
    SetAsFloat(F);
  end;
end;

procedure TFloatField.SetCurrency(Value: Boolean);
begin
  if FCurrency <> Value then
  begin
    FCurrency := Value;
    PropertyChanged(False);
  end;
end;

procedure TFloatField.SetMaxValue(Value: Double);
begin
  FMaxValue := Value;
  UpdateCheckRange;
end;

procedure TFloatField.SetMinValue(Value: Double);
begin
  FMinValue := Value;
  UpdateCheckRange;
end;

procedure TFloatField.SetPrecision(Value: Integer);
begin
  if Value < 2 then Value := 2;
  if Value > 15 then Value := 15;
  if FPrecision <> Value then
  begin
    FPrecision := Value;
    PropertyChanged(False);
  end;
end;

procedure TFloatField.UpdateCheckRange;
begin
  FCheckRange := (FMinValue <> 0) or (FMaxValue <> 0);
end;

{ TCurrencyField }

constructor TCurrencyField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftCurrency);
  FCurrency := True;
end;

{ TBCDField }

constructor TBCDField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftBCD);
  Size := 4;
end;

{ TBooleanField }

constructor TBooleanField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftBoolean);
  FDisplayValues := NullStr;
  LoadTextValues;
end;

destructor TBooleanField.Destroy;
begin
  DisposeStr(FDisplayValues);
  inherited Destroy;
end;

function TBooleanField.GetAsBoolean: Boolean;
var
  B: WordBool;
begin
  if GetData(@B) then Result := B else Result := False;
end;

function TBooleanField.GetAsString: string;
var
  B: WordBool;
begin
  if GetData(@B) then Result := FTextValues[B] else Result := '';
end;

function TBooleanField.GetDefaultWidth: Integer;
begin
  if Length(FTextValues[False]) > Length(FTextValues[True]) then
    Result := Length(FTextValues[False]) else
    Result := Length(FTextValues[True]);
end;

function TBooleanField.GetDisplayValues: string;
begin
  Result := FDisplayValues^;
end;

procedure TBooleanField.LoadTextValues;
begin
  FTextValues[False] := LoadStr(STextFalse);
  FTextValues[True] := LoadStr(STextTrue);
end;

procedure TBooleanField.SetAsBoolean(Value: Boolean);
var
  B: WordBool;
begin
  B := Value;
  SetData(@B);
end;

procedure TBooleanField.SetAsString(const Value: string);
var
  L: Integer;
begin
  L := Length(Value);
  if L = 0 then
  begin
    if Length(FTextValues[False]) = 0 then SetAsBoolean(False) else
      if Length(FTextValues[True]) = 0 then SetAsBoolean(True) else
        Clear;
  end else
  begin
    if AnsiCompareText(Value, Copy(FTextValues[False], 1, L)) = 0 then
      SetAsBoolean(False)
    else
      if AnsiCompareText(Value, Copy(FTextValues[True], 1, L)) = 0 then
        SetAsBoolean(True)
      else
        DBErrorFmt(SInvalidBoolValue, [Value, DisplayName^]);
  end;
end;

procedure TBooleanField.SetDisplayValues(const Value: string);
var
  P: Integer;
begin
  if FDisplayValues^ <> Value then
  begin
    AssignStr(FDisplayValues, Value);
    if Value = '' then LoadTextValues else
    begin
      P := Pos(';', Value);
      if P = 0 then P := 256;
      FTextValues[False] := Copy(Value, P + 1, 255);
      FTextValues[True] := Copy(Value, 1, P - 1);
    end;
    PropertyChanged(True);
  end;
end;

{ TDateTimeField }

constructor TDateTimeField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftDateTime);
  FDisplayFormat := NullStr;
end;

destructor TDateTimeField.Destroy;
begin
  DisposeStr(FDisplayFormat);
  inherited Destroy;
end;

function TDateTimeField.GetAsDateTime: TDateTime;
begin
  if not GetValue(Result) then Result := 0;
end;

function TDateTimeField.GetAsFloat: Double;
begin
  Result := GetAsDateTime;
end;

function TDateTimeField.GetAsString: string;
begin
  GetText(Result, False);
end;

function TDateTimeField.GetDisplayFormat: string;
begin
  Result := FDisplayFormat^;
end;

procedure TDateTimeField.GetText(var Text: string; DisplayText: Boolean);
var
  F: PString;
  D: TDateTime;
begin
  if GetValue(D) then
  begin
    if DisplayText and (FDisplayFormat^ <> '') then
      F := FDisplayFormat
    else
      case DataType of
        ftDate: F := @ShortDateFormat;
        ftTime: F := @LongTimeFormat;
      else
        F := NullStr;
      end;
    DateTimeToString(Text, F^, D);
  end else
    Text := '';
end;

function TDateTimeField.GetValue(var Value: TDateTime): Boolean;
var
  Data: TDateTimeRec;
begin
  Result := GetData(@Data);
  if Result then
    case DataType of
      ftDate: Value := Data.Date;
      ftTime: Value := Data.Time / MSecsPerDay;
    else
      Value := Data.DateTime / MSecsPerDay;
    end;
end;

procedure TDateTimeField.SetAsDateTime(Value: TDateTime);
var
  Data: TDateTimeRec;
begin
  case DataType of
    ftDate: Data.Date := Trunc(Value);
    ftTime: Data.Time := Round(Frac(Value) * MSecsPerDay);
  else
    Data.DateTime := Value * MSecsPerDay;
  end;
  SetData(@Data);
end;

procedure TDateTimeField.SetAsFloat(Value: Double);
begin
  SetAsDateTime(Value);
end;

procedure TDateTimeField.SetAsString(const Value: string);
var
  DateTime: TDateTime;
begin
  if Value = '' then Clear else
  begin
    case DataType of
      ftDate: DateTime := StrToDate(Value);
      ftTime: DateTime := StrToTime(Value);
    else
      DateTime := StrToDateTime(Value);
    end;
    SetAsDateTime(DateTime);
  end;
end;

procedure TDateTimeField.SetDisplayFormat(const Value: string);
begin
  if FDisplayFormat^ <> Value then
  begin
    AssignStr(FDisplayFormat, Value);
    PropertyChanged(False);
  end;
end;

procedure TTable.UnlockTable(LockType: TLockType);
begin
  SetTableLock(LockType, False);
end;

{ TDateField }

constructor TDateField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftDate);
end;

{ TTimeField }

constructor TTimeField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftTime);
end;

{ TBytesField }

constructor TBytesField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftBytes);
end;

{ TVarBytesField }

constructor TVarBytesField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftVarBytes);
end;

{ TBlobField }

constructor TBlobField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftBlob);
end;

procedure TBlobField.Assign(Source: TPersistent);
begin
  if Source is TBlobField then
  begin
    LoadFromBlob(TBlobField(Source));
    Exit;
  end;
  if Source is TStrings then
  begin
    LoadFromStrings(TStrings(Source));
    Exit;
  end;
  if Source is TBitmap then
  begin
    LoadFromBitmap(TBitmap(Source));
    Exit;
  end;
  if (Source is TPicture) and (TPicture(Source).Graphic is TBitmap) then
  begin
    LoadFromBitmap(TBitmap(TPicture(Source).Graphic));
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TBlobField.AssignTo(Dest: TPersistent);
begin
  if Dest is TStrings then
  begin
    SaveToStrings(TStrings(Dest));
    Exit;
  end;
  if Dest is TBitmap then
  begin
    SaveToBitmap(TBitmap(Dest));
    Exit;
  end;
  if Dest is TPicture then
  begin
    SaveToBitmap(TPicture(Dest).Bitmap);
    Exit;
  end;
  inherited AssignTo(Dest);
end;

procedure TBlobField.Clear;
begin
  TBlobStream.Create(Self, bmWrite).Free;
end;

procedure TBlobField.FreeBuffers;
begin
  if FModified then
  begin
    DbiFreeBlob(DataSet.Handle, DataSet.ActiveBuffer, FieldNo);
    FModified := False;
  end;
end;

procedure TBlobField.LoadFromBitmap(Bitmap: TBitmap);
var
  BlobStream: TBlobStream;
  Header: TGraphicHeader;
begin
  BlobStream := TBlobStream.Create(Self, bmWrite);
  try
    if DataType = ftGraphic then
    begin
      Header.Count := 1;
      Header.HType := $0100;
      Header.Size := 0;
      BlobStream.Write(Header, SizeOf(Header));
      Bitmap.SaveToStream(BlobStream);
      Header.Size := BlobStream.Position - SizeOf(Header);
      BlobStream.Position := 0;
      BlobStream.Write(Header, SizeOf(Header));
    end else
      Bitmap.SaveToStream(BlobStream);
  finally
    BlobStream.Free;
  end;
end;

procedure TBlobField.LoadFromBlob(Blob: TBlobField);
var
  BlobStream: TBlobStream;
begin
  BlobStream := TBlobStream.Create(Self, bmWrite);
  try
    Blob.SaveToStream(BlobStream);
  finally
    BlobStream.Free;
  end;
end;

procedure TBlobField.LoadFromFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TBlobField.LoadFromStream(Stream: TStream);
var
  BlobStream: TBlobStream;
begin
  BlobStream := TBlobStream.Create(Self, bmWrite);
  try
    BlobStream.CopyFrom(Stream, 0);
  finally
    BlobStream.Free;
  end;
end;

procedure TBlobField.LoadFromStrings(Strings: TStrings);
var
  BlobStream: TBlobStream;
begin
  BlobStream := TBlobStream.Create(Self, bmWrite);
  try
    Strings.SaveToStream(BlobStream);
  finally
    BlobStream.Free;
  end;
end;

procedure TBlobField.SaveToBitmap(Bitmap: TBitmap);
var
  BlobStream: TBlobStream;
  Size: Longint;
  Header: TGraphicHeader;
begin
  BlobStream := TBlobStream.Create(Self, bmRead);
  try
    Size := BlobStream.Size;
    if Size >= SizeOf(TGraphicHeader) then
    begin
      BlobStream.Read(Header, SizeOf(Header));
      if (Header.Count <> 1) or (Header.HType <> $0100) or
        (Header.Size <> Size - SizeOf(Header)) then
        BlobStream.Position := 0;
    end;
    Bitmap.LoadFromStream(BlobStream);
  finally
    BlobStream.Free;
  end;
end;

procedure TBlobField.SaveToFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TBlobField.SaveToStream(Stream: TStream);
var
  BlobStream: TBlobStream;
begin
  BlobStream := TBlobStream.Create(Self, bmRead);
  try
    Stream.CopyFrom(BlobStream, 0);
  finally
    BlobStream.Free;
  end;
end;

procedure TBlobField.SaveToStrings(Strings: TStrings);
var
  BlobStream: TBlobStream;
begin
  BlobStream := TBlobStream.Create(Self, bmRead);
  try
    Strings.LoadFromStream(BlobStream);
  finally
    BlobStream.Free;
  end;
end;

{ TMemoField }

constructor TMemoField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftMemo);
  Transliterate := True;
end;

{ TGraphicField }

constructor TGraphicField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftGraphic);
end;

{ TBlobStream }

constructor TBlobStream.Create(Field: TBlobField; Mode: TBlobStreamMode);
var
  OpenMode: DbiOpenMode;
begin
  FField := Field;
  FDataSet := Field.DataSet;
  FRecord := FDataSet.ActiveBuffer;
  FFieldNo := Field.FieldNo;
  if not FField.FModified then
  begin
    if Mode = bmRead then
    begin
      FBuffer := AllocMem(FDataSet.RecordSize);
      FRecord := FBuffer;
      if not FDataSet.GetCurrentRecord(FBuffer) then Exit;
      OpenMode := dbiReadOnly;
    end else
    begin
      if not (FDataSet.State in [dsEdit, dsInsert]) then DBError(SNotEditing);
      OpenMode := dbiReadWrite;
    end;
    Check(DbiOpenBlob(FDataSet.Handle, FRecord, FFieldNo, OpenMode));
  end;
  FOpened := True;
  if Mode = bmWrite then Truncate;
end;

destructor TBlobStream.Destroy;
begin
  if FOpened then
  begin
    if FModified then FField.FModified := True;
    if not FField.FModified then
      DbiFreeBlob(FDataSet.Handle, FRecord, FFieldNo);
  end;
  if FBuffer <> nil then FreeMem(FBuffer, FDataSet.RecordSize);
  if FModified then
  try
    FField.DataChanged;
  except
    Application.HandleException(Self);
  end;
end;

function TBlobStream.Read(var Buffer; Count: Longint): Longint;
var
  Status: DBIResult;
  N: Word;
  L: Longint;
  P: Pointer;
begin
  Result := 0;
  if FOpened then
  begin
    P := @Buffer;
    while Count > 0 do
    begin
      if PtrRec(P).Ofs < $8000 then
        N := $8000 else
        N := Word(-Integer(PtrRec(P).Ofs));
      if N > Count then N := Count;
      Status := DbiGetBlob(FDataSet.Handle, FRecord, FFieldNo, FPosition,
        N, P, L);
      case Status of
        DBIERR_NONE, DBIERR_ENDOFBLOB:
          begin
            if FField.FTransliterate then
              NativeToAnsiBuf(FDataSet.Locale, P, P, L);
            Inc(FPosition, L);
            Inc(Result, L);
          end;
        DBIERR_INVALIDBLOBOFFSET:
          {Nothing};
      else
        DbiError(Status);
      end;
      if Status <> DBIERR_NONE then Break;
      Dec(Count, N);
      Inc(PtrRec(P).Ofs, N);
      if PtrRec(P).Ofs = 0 then Inc(PtrRec(P).Seg, SelectorInc);
    end;
  end;
end;

function TBlobStream.Write(const Buffer; Count: Longint): Longint;
var
  N: Word;
  P, Temp: Pointer;
begin
  Result := 0;
  if FOpened then
  begin
    Result := Count;
    P := @Buffer;
    while Count > 0 do
    begin
      if PtrRec(P).Ofs < $8000 then
        N := $8000 else
        N := Word(-Integer(PtrRec(P).Ofs));
      if N > Count then N := Count;
      if FField.FTransliterate then
      begin
        GetMem(Temp, N);
        try
          AnsiToNativeBuf(FDataSet.Locale, P, Temp, N);
          Check(DbiPutBlob(FDataSet.Handle, FRecord, FFieldNo, FPosition,
            N, Temp));
        finally
          FreeMem(Temp, N);
        end;
      end else
        Check(DbiPutBlob(FDataSet.Handle, FRecord, FFieldNo, FPosition,
          N, P));
      Inc(FPosition, N);
      Dec(Count, N);
      Inc(PtrRec(P).Ofs, N);
      if PtrRec(P).Ofs = 0 then Inc(PtrRec(P).Seg, SelectorInc);
    end;
    FModified := True;
  end;
end;

function TBlobStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
  case Origin of
    0: FPosition := Offset;
    1: Inc(FPosition, Offset);
    2: FPosition := GetBlobSize + Offset;
  end;
  Result := FPosition;
end;

procedure TBlobStream.Truncate;
begin
  if FOpened then
  begin
    Check(DbiTruncateBlob(FDataSet.Handle, FRecord, FFieldNo, FPosition));
    FModified := True;
  end;
end;

function TBlobStream.GetBlobSize: Longint;
begin
  Result := 0;
  if FOpened then
    Check(DbiGetBlobSize(FDataSet.Handle, FRecord, FFieldNo, Result));
end;

{ TFieldDataLink }

constructor TFieldDataLink.Create;
begin
  inherited Create;
  FFieldName := NullStr;
end;

destructor TFieldDataLink.Destroy;
begin
  DisposeStr(FFieldName);
  inherited Destroy;
end;

procedure TFieldDataLink.SetEditing(Value: Boolean);
begin
  if FEditing <> Value then
  begin
    FEditing := Value;
    FModified := False;
    if Assigned(FOnEditingChange) then FOnEditingChange(Self);
  end;
end;

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

procedure TFieldDataLink.SetFieldName(const Value: string);
begin
  if FFieldName^ <> Value then
  begin
    AssignStr(FFieldName, Value);
    UpdateField;
  end;
end;

procedure TFieldDataLink.SetField(Value: TField);
begin
  if FField <> Value then
  begin
    FField := Value;
    EditingChanged;
    RecordChanged(nil);
  end;
end;

procedure TFieldDataLink.UpdateField;
begin
  SetField(nil);
  if Active and (FFieldName^ <> '') then
    SetField(DataSource.DataSet.FieldByName(FFieldName^));
end;

function TFieldDataLink.Edit: Boolean;
begin
  if CanModify then inherited Edit;
  Result := FEditing;
end;

function TFieldDataLink.GetCanModify: Boolean;
begin
  Result := not ReadOnly and (Field <> nil) and Field.CanModify;
end;

procedure TFieldDataLink.Modified;
begin
  FModified := True;
end;

procedure TFieldDataLink.Reset;
begin
  RecordChanged(nil);
end;

procedure TFieldDataLink.ActiveChanged;
begin
  UpdateField;
  if Assigned(FOnActiveChange) then FOnActiveChange(Self);
end;

procedure TFieldDataLink.EditingChanged;
begin
  SetEditing(inherited Editing and CanModify);
end;

procedure TFieldDataLink.FocusControl(Field: TFieldRef);
begin
  if (Field^ <> nil) and (Field^ = FField) and (FControl <> nil) and
    FControl.CanFocus then
  begin
    Field^ := nil;
    FControl.SetFocus;
  end;
end;

procedure TFieldDataLink.RecordChanged(Field: TField);
begin
  if (Field = nil) or (Field = FField) then
  begin
    if Assigned(FOnDataChange) then FOnDataChange(Self);
    FModified := False;
  end;
end;

procedure TFieldDataLink.LayoutChanged;
begin
  UpdateField;
end;

procedure TFieldDataLink.UpdateData;
begin
  if FModified then
  begin
    if (Field <> nil) and Assigned(FOnUpdateData) then FOnUpdateData(Self);
    FModified := False;
  end;
end;

end.
