home *** CD-ROM | disk | FTP | other *** search
/ PC Pro 1999 February / DPPCPRO0299.ISO / February / Delphi / Install / DATA.Z / DBTABLES.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-06-09  |  144.7 KB  |  5,592 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1995,96 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit DBTables;
  11.  
  12. {$N+,P+,S-,R-}
  13.  
  14. interface
  15.  
  16. uses SysUtils, Windows, Bde, Classes, Controls, Graphics, Mask, DB;
  17.  
  18. type
  19.  
  20. { TIndexDef }
  21.  
  22.   TIndexDefs = class;
  23.  
  24.   TIndexOptions = set of (ixPrimary, ixUnique, ixDescending,
  25.     ixCaseInsensitive, ixExpression);
  26.  
  27.   TIndexDef = class
  28.   private
  29.     FOwner: TIndexDefs;
  30.     FSource: string;
  31.     FName: string;
  32.     FFields: string;
  33.     FOptions: TIndexOptions;
  34.     function GetExpression: string;
  35.     function GetFields: string;
  36.   public
  37.     constructor Create(Owner: TIndexDefs; const Name, Fields: string;
  38.       Options: TIndexOptions);
  39.     destructor Destroy; override;
  40.     property Expression: string read GetExpression;
  41.     property Fields: string read GetFields;
  42.     property Name: string read FName;
  43.     property Options: TIndexOptions read FOptions;
  44.     property Source: string read FSource;
  45.   end;
  46.  
  47. { TIndexDefs }
  48.  
  49.   TTable = class;
  50.  
  51.   TIndexDefs = class
  52.   private
  53.     FTable: TTable;
  54.     FItems: TList;
  55.     FUpdated: Boolean;
  56.     FReserved: Byte;
  57.     function GetCount: Integer;
  58.     function GetIndexForFields(const Fields: string;
  59.       CaseInsensitive: Boolean): TIndexDef;
  60.     function GetItem(Index: Integer): TIndexDef;
  61.   public
  62.     constructor Create(Table: TTable);
  63.     destructor Destroy; override;
  64.     procedure Add(const Name, Fields: string; Options: TIndexOptions);
  65.     procedure Assign(IndexDefs: TIndexDefs);
  66.     procedure Clear;
  67.     function FindIndexForFields(const Fields: string): TIndexDef;
  68.     function IndexOf(const Name: string): Integer;
  69.     procedure Update;
  70.     property Count: Integer read GetCount;
  71.     property Items[Index: Integer]: TIndexDef read GetItem; default;
  72.   end;
  73.  
  74. { TTableDataLink }
  75.  
  76.   TTableDataLink = class(TDataLink)
  77.   private
  78.     FTable: TTable;
  79.     FFieldNames: string;
  80.     FFields: TList;
  81.     procedure SetFieldNames(const Value: string);
  82.   protected
  83.     procedure ActiveChanged; override;
  84.     procedure CheckBrowseMode; override;
  85.     procedure LayoutChanged; override;
  86.     procedure RecordChanged(Field: TField); override;
  87.   public
  88.     constructor Create(Table: TTable);
  89.     destructor Destroy; override;
  90.   end;
  91.  
  92. { TTable }
  93.  
  94.   TBatchMode = (batAppend, batUpdate, batAppendUpdate, batDelete, batCopy);
  95.   TTableType = (ttDefault, ttParadox, ttDBase, ttASCII);
  96.   TLockType = (ltReadLock, ltWriteLock);
  97.   TIndexName = type string;
  98.  
  99.   TIndexFiles = class(TStringList)
  100.   private
  101.     FOwner: TTable;
  102.   public
  103.     constructor Create(AOwner: TTable);
  104.     function Add(const S: string): Integer; override;
  105.     procedure Clear; override;
  106.     procedure Delete(Index: Integer); override;
  107.     procedure Insert(Index: Integer; const S: string); override;
  108.   end;
  109.  
  110.   TTable = class(TDBDataSet)
  111.   private
  112.     FIndexDefs: TIndexDefs;
  113.     FDataLink: TTableDataLink;
  114.     FExclusive: Boolean;
  115.     FReadOnly: Boolean;
  116.     FTableType: TTableType;
  117.     FFieldsIndex: Boolean;
  118.     FTableName: TFileName;
  119.     FIndexName: TIndexName;
  120.     FIndexFiles: TStrings;
  121.     FLookupHandle: HDBICur;
  122.     FLookupKeyFields: string;
  123.     FLookupCursor: HDBICur;
  124.     procedure DecodeIndexDesc(const IndexDesc: IDXDesc;
  125.       var Source, Name, Fields: string; var Options: TIndexOptions);
  126.     procedure EncodeFieldDesc(var FieldDesc: FLDDesc;
  127.       const Name: string; DataType: TFieldType; Size: Word);
  128.     procedure EncodeIndexDesc(var IndexDesc: IDXDesc;
  129.       const Name, Fields: string; Options: TIndexOptions);
  130.     function GetDriverTypeName(Buffer: PChar): PChar;
  131.     function GetIndexFieldNames: string;
  132.     function GetIndexName: string;
  133.     procedure GetIndexParams(const IndexName: string; FieldsIndex: Boolean;
  134.       var IndexedName, IndexTag: string);
  135.     function GetMasterFields: string;
  136.     function GetTableTypeName: PChar;
  137.     function IsDBaseTable: Boolean;
  138.     procedure MasterChanged;
  139.     procedure SetDataSource(Value: TDataSource);
  140.     procedure SetExclusive(Value: Boolean);
  141.     procedure SetIndex(const Value: string; FieldsIndex: Boolean);
  142.     procedure SetIndexFieldNames(const Value: string);
  143.     procedure SetIndexFiles(Value: TStrings);
  144.     procedure SetIndexName(const Value: string);
  145.     procedure SetMasterFields(const Value: string);
  146.     procedure SetReadOnly(Value: Boolean);
  147.     procedure SetTableLock(LockType: TLockType; Lock: Boolean);
  148.     procedure SetTableName(const Value: TFileName);
  149.     procedure SetTableType(Value: TTableType);
  150.     procedure UpdateIndexDefs;
  151.     procedure UpdateRange;
  152.   protected
  153.     function CreateHandle: HDBICur; override;
  154.     procedure DataEvent(Event: TDataEvent; Info: Longint); override;
  155.     procedure DestroyHandle; override;
  156.     procedure DestroyLookupCursor; override;
  157.     procedure DoOnNewRecord; override;
  158.     function GetCanModify: Boolean; override;
  159.     function GetDataSource: TDataSource; override;
  160.     function GetHandle(const IndexName, IndexTag: string): HDBICur;
  161.     function GetLanguageDriverName: string;
  162.     function GetLookupCursor(const KeyFields: string;
  163.       CaseInsensitive: Boolean): HDBICur; override;
  164.     procedure InitFieldDefs; override;
  165.     function IsProductionIndex(const IndexName: string): Boolean;
  166.     procedure PrepareCursor; override;
  167.   public
  168.     constructor Create(AOwner: TComponent); override;
  169.     destructor Destroy; override;
  170.     function BatchMove(ASource: TDataSet; AMode: TBatchMode): Longint;
  171.     procedure AddIndex(const Name, Fields: string; Options: TIndexOptions);
  172.     procedure ApplyRange;
  173.     procedure CancelRange;
  174.     procedure CloseIndexFile(const IndexFileName: string);
  175.     procedure CreateTable;
  176.     procedure DeleteIndex(const Name: string);
  177.     procedure DeleteTable;
  178.     procedure EditKey;
  179.     procedure EditRangeEnd;
  180.     procedure EditRangeStart;
  181.     procedure EmptyTable;
  182.     function FindKey(const KeyValues: array of const): Boolean;
  183.     procedure FindNearest(const KeyValues: array of const);
  184.     procedure GetIndexNames(List: TStrings);
  185.     procedure GotoCurrent(Table: TTable);
  186.     function GotoKey: Boolean;
  187.     procedure GotoNearest;
  188.     procedure LockTable(LockType: TLockType);
  189.     procedure OpenIndexFile(const IndexName: string);
  190.     procedure RenameTable(const NewTableName: string);
  191.     procedure SetKey;
  192.     procedure SetRange(const StartValues, EndValues: array of const);
  193.     procedure SetRangeEnd;
  194.     procedure SetRangeStart;
  195.     procedure UnlockTable(LockType: TLockType);
  196.     property IndexDefs: TIndexDefs read FIndexDefs;
  197.     property IndexFieldCount: Integer read GetIndexFieldCount;
  198.     property IndexFields[Index: Integer]: TField read GetIndexField write SetIndexField;
  199.     property KeyExclusive: Boolean read GetKeyExclusive write SetKeyExclusive;
  200.     property KeyFieldCount: Integer read GetKeyFieldCount write SetKeyFieldCount;
  201.   published
  202.     property Exclusive: Boolean read FExclusive write SetExclusive default False;
  203.     property IndexFieldNames: string read GetIndexFieldNames write SetIndexFieldNames;
  204.     property IndexFiles: TStrings read FIndexFiles write SetIndexFiles;
  205.     property IndexName: string read GetIndexName write SetIndexName;
  206.     property MasterFields: string read GetMasterFields write SetMasterFields;
  207.     property MasterSource: TDataSource read GetDataSource write SetDataSource;
  208.     property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
  209.     property TableName: TFileName read FTableName write SetTableName;
  210.     property TableType: TTableType read FTableType write SetTableType default ttDefault;
  211.     property UpdateMode;
  212.     property UpdateObject;
  213.   end;
  214.  
  215. { TBatchMove }
  216.  
  217.   TBatchMove = class(TComponent)
  218.   private
  219.     FDestination: TTable;
  220.     FSource: TDataSet;
  221.     FMode: TBatchMode;
  222.     FAbortOnKeyViol: Boolean;
  223.     FAbortOnProblem: Boolean;
  224.     FTransliterate: Boolean;
  225.     FRecordCount: Longint;
  226.     FMovedCount: Longint;
  227.     FKeyViolCount: Longint;
  228.     FProblemCount: Longint;
  229.     FChangedCount: Longint;
  230.     FMappings: TStrings;
  231.     FKeyViolTableName: TFileName;
  232.     FProblemTableName: TFileName;
  233.     FChangedTableName: TFileName;
  234.     FCommitCount: Integer;
  235.     function ConvertName(const Name: string; Buffer: PChar): PChar;
  236.     procedure SetDesination(Value: TTable);
  237.     procedure SetMappings(Value: TStrings);
  238.     procedure SetSource(Value: TDataSet);
  239.   protected
  240.     procedure Notification(AComponent: TComponent;
  241.       Operation: TOperation); override;
  242.   public
  243.     constructor Create(AOwner: TComponent); override;
  244.     destructor Destroy; override;
  245.     procedure Execute;
  246.   public
  247.     property ChangedCount: Longint read FChangedCount;
  248.     property KeyViolCount: Longint read FKeyViolCount;
  249.     property MovedCount: Longint read FMovedCount;
  250.     property ProblemCount: Longint read FProblemCount;
  251.   published
  252.     property AbortOnKeyViol: Boolean read FAbortOnKeyViol write FAbortOnKeyViol default True;
  253.     property AbortOnProblem: Boolean read FAbortOnProblem write FAbortOnProblem default True;
  254.     property CommitCount: Integer read FCommitCount write FCommitCount default 0;
  255.     property ChangedTableName: TFileName read FChangedTableName write FChangedTableName;
  256.     property Destination: TTable read FDestination write FDestination;
  257.     property KeyViolTableName: TFileName read FKeyViolTableName write FKeyViolTableName;
  258.     property Mappings: TStrings read FMappings write SetMappings;
  259.     property Mode: TBatchMode read FMode write FMode default batAppend;
  260.     property ProblemTableName: TFileName read FProblemTableName write FProblemTableName;
  261.     property RecordCount: Longint read FRecordCount write FRecordCount default 0;
  262.     property Source: TDataSet read FSource write SetSource;
  263.     property Transliterate: Boolean read FTransliterate write FTransliterate default True;
  264.   end;
  265.  
  266. { TParam }
  267.  
  268.   TQuery = class;
  269.   TParams = class;
  270.  
  271.   TParamType = (ptUnknown, ptInput, ptOutput, ptInputOutput, ptResult);
  272.  
  273.   TParam = class(TObject)
  274.   private
  275.     FParamList: TParams;
  276.     FData: Variant;
  277.     FName: string;
  278.     FDataType: TFieldType;
  279.     FNull: Boolean;
  280.     FBound: Boolean;
  281.     FParamType: TParamType;
  282.     procedure AccessError;
  283.     procedure InitValue;
  284.   protected
  285.     function GetAsBCD: Currency;
  286.     function GetAsBoolean: Boolean;
  287.     function GetAsDateTime: TDateTime;
  288.     function GetAsFloat: Double;
  289.     function GetAsInteger: Longint;
  290.     function GetAsString: string;
  291.     function GetAsVariant: Variant;
  292.     function IsEqual(Value: TParam): Boolean;
  293.     procedure SetAsBCD(Value: Currency);
  294.     procedure SetAsBoolean(Value: Boolean);
  295.     procedure SetAsCurrency(Value: Double);
  296.     procedure SetAsDate(Value: TDateTime);
  297.     procedure SetAsDateTime(Value: TDateTime);
  298.     procedure SetAsFloat(Value: Double);
  299.     procedure SetAsInteger(Value: Longint);
  300.     procedure SetAsString(const Value: string);
  301.     procedure SetAsSmallInt(Value: LongInt);
  302.     procedure SetAsTime(Value: TDateTime);
  303.     procedure SetAsVariant(Value: Variant);
  304.     procedure SetAsWord(Value: LongInt);
  305.     procedure SetDataType(Value: TFieldType);
  306.     procedure SetText(const Value: string);
  307.   public
  308.     constructor Create(AParamList: TParams; AParamType: TParamType);
  309.     destructor Destroy; override;
  310.     procedure Assign(Param: TParam);
  311.     procedure AssignField(Field: TField);
  312.     procedure AssignFieldValue(Field: TField; const Value: Variant);
  313.     procedure Clear;
  314.     procedure GetData(Buffer: Pointer);
  315.     function GetDataSize: Word;
  316.     procedure SetData(Buffer: Pointer);
  317.     property AsBCD: Currency read GetAsBCD write SetAsBCD;
  318.     property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;
  319.     property AsCurrency: Double read GetAsFloat write SetAsCurrency;
  320.     property AsDate: TDateTime read GetAsDateTime write SetAsDate;
  321.     property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
  322.     property AsFloat: Double read GetAsFloat write SetAsFloat;
  323.     property AsInteger: LongInt read GetAsInteger write SetAsInteger;
  324.     property AsSmallInt: LongInt read GetAsInteger write SetAsSmallInt;
  325.     property AsString: string read GetAsString write SetAsString;
  326.     property AsTime: TDateTime read GetAsDateTime write SetAsTime;
  327.     property AsWord: LongInt read GetAsInteger write SetAsWord;
  328.     property Bound: Boolean read FBound write FBound;
  329.     property DataType: TFieldType read FDataType write SetDataType;
  330.     property IsNull: Boolean read FNull;
  331.     property Name: string read FName write FName;
  332.     property ParamType: TParamType read FParamType write FParamType;
  333.     property Text: string read GetAsString write SetText;
  334.     property Value: Variant read GetAsVariant write SetAsVariant;
  335.   end;
  336.  
  337. { TParams }
  338.  
  339.   TParams = class(TPersistent)
  340.   private
  341.     FItems: TList;
  342.     function GetParam(Index: Word): TParam;
  343.     function GetParamValue(const ParamName: string): Variant;
  344.     function GetVersion: Word;
  345.     procedure ReadBinaryData(Stream: TStream);
  346.     procedure SetParamValue(const ParamName: string;
  347.       const Value: Variant);
  348.     procedure WriteBinaryData(Stream: TStream);
  349.   protected
  350.     procedure AssignTo(Dest: TPersistent); override;
  351.     procedure DefineProperties(Filer: TFiler); override;
  352.   public
  353.     constructor Create; virtual;
  354.     destructor Destroy; override;
  355.     procedure Assign(Source: TPersistent); override;
  356.     procedure AssignValues(Value: TParams);
  357.     procedure AddParam(Value: TParam);
  358.     procedure RemoveParam(Value: TParam);
  359.     function CreateParam(FldType: TFieldType; const ParamName: string;
  360.       ParamType: TParamType): TParam;
  361.     function Count: Integer;
  362.     procedure Clear;
  363.     procedure GetParamList(List: TList; const ParamNames: string);
  364.     function IsEqual(Value: TParams): Boolean;
  365.     function ParamByName(const Value: string): TParam;
  366.     property Items[Index: Word]: TParam read GetParam; default;
  367.     property ParamValues[const ParamName: string]: Variant read GetParamValue write SetParamValue;
  368.   end;
  369.  
  370. { TStoredProc }
  371.  
  372.   PServerDesc = ^TServerDesc;
  373.   TServerDesc = record
  374.     ParamName: string[DBIMAXSPNAMELEN];
  375.     BindType: TFieldType;
  376.   end;
  377.  
  378.   TParamBindMode = (pbByName, pbByNumber);
  379.  
  380.   TStoredProc = class(TDBDataSet)
  381.   private
  382.     FStmtHandle: HDBIStmt;
  383.     FProcName: string;
  384.     FParams: TParams;
  385.     FParamDesc: PChar;
  386.     FRecordBuffer: PChar;
  387.     FOverLoad: Word;
  388.     FPrepared: Boolean;
  389.     FQueryMode: Boolean;
  390.     FServerDescs: PChar;
  391.     FBindMode: TParamBindMode;
  392.     procedure BindParams;
  393.     function CheckServerParams: Boolean;
  394.     function CreateCursor(GenHandle: Boolean): HDBICur;
  395.     procedure CreateParamDesc;
  396.     procedure FreeStatement;
  397.     function GetCursor(GenHandle: Boolean): HDBICur;
  398.     procedure PrepareProc;
  399.     procedure SetParamsList(Value: TParams);
  400.     procedure SetServerParams;
  401.   protected
  402.     function CreateHandle: HDBICur; override;
  403.     procedure Disconnect; override;
  404.     function GetParamsCount: Word;
  405.     procedure SetDBFlag(Flag: Integer; Value: Boolean); override;
  406.     procedure SetOverLoad(Value: Word);
  407.     procedure SetProcName(const Value: string);
  408.     procedure SetPrepared(Value: Boolean);
  409.     procedure SetPrepare(Value: Boolean);
  410.   public
  411.     constructor Create(AOwner: TComponent); override;
  412.     destructor Destroy; override;
  413.     procedure CopyParams(Value: TParams);
  414.     function DescriptionsAvailable: Boolean;
  415.     procedure ExecProc;
  416.     function ParamByName(const Value: string): TParam;
  417.     procedure Prepare;
  418.     procedure GetResults;
  419.     procedure UnPrepare;
  420.     property ParamCount: Word read GetParamsCount;
  421.     property StmtHandle: HDBIStmt read FStmtHandle;
  422.     property Prepared: Boolean read FPrepared write SetPrepare;
  423.   published
  424.     property StoredProcName: string read FProcName write SetProcName;
  425.     property Overload: Word read FOverload write SetOverload default 0;
  426.     property Params: TParams read FParams write SetParamsList;
  427.     property ParamBindMode: TParamBindMode read FBindMode write FBindMode default pbByName;
  428.     property UpdateObject;
  429.   end;
  430.  
  431. { TQuery }
  432.  
  433.   TQuery = class(TDBDataSet)
  434.   private
  435.     FStmtHandle: HDBIStmt;
  436.     FSQL: TStrings;
  437.     FPrepared: Boolean;
  438.     FParams: TParams;
  439.     FText: string;
  440.     FDataLink: TDataLink;
  441.     FLocal: Boolean;
  442.     FRowsAffected: Integer;
  443.     FUniDirectional: Boolean;
  444.     FRequestLive: Boolean;
  445.     FSQLBinary: PChar;
  446.     FConstrained: Boolean;
  447.     FParamCheck: Boolean;
  448.     function CreateCursor(GenHandle: Boolean): HDBICur;
  449.     procedure CreateParams(List: TParams; const Value: PChar);
  450.     procedure DefineProperties(Filer: TFiler); override;
  451.     procedure FreeStatement;
  452.     function GetQueryCursor(GenHandle: Boolean): HDBICur;
  453.     procedure GetStatementHandle(SQLText: PChar);
  454.     function GetSQLText: PChar;
  455.     function GetRowsAffected: Integer;
  456.     procedure PrepareSQL(Value: PChar);
  457.     procedure QueryChanged(Sender: TObject);
  458.     procedure ReadBinaryData(Stream: TStream);
  459.     procedure RefreshParams;
  460.     procedure SetDataSource(Value: TDataSource);
  461.     procedure SetQuery(Value: TStrings);
  462.     procedure SetParamsList(Value: TParams);
  463.     procedure SetParams;
  464.     procedure SetParamsFromCursor;
  465.     procedure SetPrepared(Value: Boolean);
  466.     procedure SetPrepare(Value: Boolean);
  467.     procedure WriteBinaryData(Stream: TStream);
  468.   protected
  469.     function CreateHandle: HDBICur; override;
  470.     procedure Disconnect; override;
  471.     function GetDataSource: TDataSource; override;
  472.     function GetParamsCount: Word;
  473.     procedure SetDBFlag(Flag: Integer; Value: Boolean); override;
  474.   public
  475.     constructor Create(AOwner: TComponent); override;
  476.     destructor Destroy; override;
  477.     procedure ExecSQL;
  478.     function ParamByName(const Value: string): TParam;
  479.     procedure Prepare;
  480.     procedure UnPrepare;
  481.     property Prepared: Boolean read FPrepared write SetPrepare;
  482.     property ParamCount: Word read GetParamsCount;
  483.     property Local: Boolean read FLocal;
  484.     property StmtHandle: HDBIStmt read FStmtHandle;
  485.     property Text: string read FText;
  486.     property RowsAffected: Integer read GetRowsAffected;
  487.     property SQLBinary: PChar read FSQLBinary write FSQLBinary;
  488.   published
  489.     property Constrained: Boolean read FConstrained write FConstrained default False;
  490.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  491.     property Params: TParams read FParams write SetParamsList;
  492.     property ParamCheck: Boolean read FParamCheck write FParamCheck default True;
  493.     property RequestLive: Boolean read FRequestLive write FRequestLive default False;
  494.     property SQL: TStrings read FSQL write SetQuery;
  495.     property UniDirectional: Boolean read FUniDirectional write FUniDirectional default False;
  496.     property UpdateMode;
  497.     property UpdateObject;
  498. end;
  499.  
  500. { TUpdateSQL }
  501.  
  502.   TUpdateSQL = class(TDataSetUpdateObject)
  503.   private
  504.     FDataSet: TDataSet;
  505.     FQueries: array[TUpdateKind] of TQuery;
  506.     FSQLText: array[TUpdateKind] of TStrings;
  507.     function GetQuery(UpdateKind: TUpdateKind): TQuery;
  508.     function GetSQL(UpdateKind: TUpdateKind): TStrings;
  509.     function GetSQLIndex(Index: Integer): TStrings;
  510.     procedure SetSQL(UpdateKind: TUpdateKind; Value: TStrings);
  511.     procedure SetSQLIndex(Index: Integer; Value: TStrings);
  512.   protected
  513.     function GetDataSet: TDataSet; override;
  514.     procedure SetDataSet(ADataSet: TDataSet); override;
  515.   public
  516.     constructor Create(AOwner: TComponent); override;
  517.     destructor Destroy; override;
  518.     procedure Apply(UpdateKind: TUpdateKind); override;
  519.     procedure ExecSQL(UpdateKind: TUpdateKind);
  520.     procedure SetParams(UpdateKind: TUpdateKind);
  521.     property DataSet;
  522.     property Query[UpdateKind: TUpdateKind]: TQuery read GetQuery;
  523.     property SQL[UpdateKind: TUpdateKind]: TStrings read GetSQL write SetSQL;
  524.   published
  525.     property ModifySQL: TStrings index 0 read GetSQLIndex write SetSQLIndex;
  526.     property InsertSQL: TStrings index 1 read GetSQLIndex write SetSQLIndex;
  527.     property DeleteSQL: TStrings index 2 read GetSQLIndex write SetSQLIndex;
  528.   end;
  529.  
  530. { TStringField }
  531.  
  532.   TStringField = class(TField)
  533.   private
  534.     FTransliterate: Boolean;
  535.     FReserved: Byte;
  536.   protected
  537.     function GetAsBoolean: Boolean; override;
  538.     function GetAsDateTime: TDateTime; override;
  539.     function GetAsFloat: Double; override;
  540.     function GetAsInteger: Longint; override;
  541.     function GetAsString: string; override;
  542.     function GetAsVariant: Variant; override;
  543.     function GetDefaultWidth: Integer; override;
  544.     procedure GetText(var Text: string; DisplayText: Boolean); override;
  545.     function GetValue(var Value: string): Boolean;
  546.     procedure SetAsBoolean(Value: Boolean); override;
  547.     procedure SetAsDateTime(Value: TDateTime); override;
  548.     procedure SetAsFloat(Value: Double); override;
  549.     procedure SetAsInteger(Value: Longint); override;
  550.     procedure SetAsString(const Value: string); override;
  551.     procedure SetVarValue(const Value: Variant); override;
  552.   public
  553.     constructor Create(AOwner: TComponent); override;
  554.     property Value: string read GetAsString write SetAsString;
  555.   published
  556.     property EditMask;
  557.     property Size default 20;
  558.     property Transliterate: Boolean read FTransliterate write FTransliterate default True;
  559.   end;
  560.  
  561. { TNumericField }
  562.  
  563.   TNumericField = class(TField)
  564.   private
  565.     FDisplayFormat: string;
  566.     FEditFormat: string;
  567.     procedure RangeError(Value, Min, Max: Extended);
  568.     procedure SetDisplayFormat(const Value: string);
  569.     procedure SetEditFormat(const Value: string);
  570.   public
  571.     constructor Create(AOwner: TComponent); override;
  572.   published
  573.     property Alignment default taRightJustify;
  574.     property DisplayFormat: string read FDisplayFormat write SetDisplayFormat;
  575.     property EditFormat: string read FEditFormat write SetEditFormat;
  576.   end;
  577.  
  578. { TIntegerField }
  579.  
  580.   TIntegerField = class(TNumericField)
  581.   private
  582.     FMinRange: Longint;
  583.     FMaxRange: Longint;
  584.     FMinValue: Longint;
  585.     FMaxValue: Longint;
  586.     procedure CheckRange(Value, Min, Max: Longint);
  587.     procedure SetMaxValue(Value: Longint);
  588.     procedure SetMinValue(Value: Longint);
  589.   protected
  590.     function GetAsFloat: Double; override;
  591.     function GetAsInteger: Longint; override;
  592.     function GetAsString: string; override;
  593.     function GetAsVariant: Variant; override;
  594.     procedure GetText(var Text: string; DisplayText: Boolean); override;
  595.     function GetValue(var Value: Longint): Boolean;
  596.     procedure SetAsFloat(Value: Double); override;
  597.     procedure SetAsInteger(Value: Longint); override;
  598.     procedure SetAsString(const Value: string); override;
  599.     procedure SetVarValue(const Value: Variant); override;
  600.   public
  601.     constructor Create(AOwner: TComponent); override;
  602.     function IsValidChar(Ch: Char): Boolean; override;
  603.     property Value: Longint read GetAsInteger write SetAsInteger;
  604.   published
  605.     property MaxValue: Longint read FMaxValue write SetMaxValue default 0;
  606.     property MinValue: Longint read FMinValue write SetMinValue default 0;
  607.   end;
  608.  
  609. { TSmallintField }
  610.  
  611.   TSmallintField = class(TIntegerField)
  612.   public
  613.     constructor Create(AOwner: TComponent); override;
  614.   end;
  615.  
  616. { TWordField }
  617.  
  618.   TWordField = class(TIntegerField)
  619.   public
  620.     constructor Create(AOwner: TComponent); override;
  621.   end;
  622.  
  623. { TAutoIncField }
  624.  
  625.   TAutoIncField = class(TIntegerField)
  626.   public
  627.     constructor Create(AOwner: TComponent); override;
  628.   end;
  629.  
  630. { TFloatField }
  631.  
  632.   TFloatField = class(TNumericField)
  633.   private
  634.     FCurrency: Boolean;
  635.     FCheckRange: Boolean;
  636.     FPrecision: Integer;
  637.     FMinValue: Double;
  638.     FMaxValue: Double;
  639.     procedure SetCurrency(Value: Boolean);
  640.     procedure SetMaxValue(Value: Double);
  641.     procedure SetMinValue(Value: Double);
  642.     procedure SetPrecision(Value: Integer);
  643.     procedure UpdateCheckRange;
  644.   protected
  645.     function GetAsFloat: Double; override;
  646.     function GetAsInteger: Longint; override;
  647.     function GetAsString: string; override;
  648.     function GetAsVariant: Variant; override;
  649.     procedure GetText(var Text: string; DisplayText: Boolean); override;
  650.     procedure SetAsFloat(Value: Double); override;
  651.     procedure SetAsInteger(Value: Longint); override;
  652.     procedure SetAsString(const Value: string); override;
  653.     procedure SetVarValue(const Value: Variant); override;
  654.   public
  655.     constructor Create(AOwner: TComponent); override;
  656.     function IsValidChar(Ch: Char): Boolean; override;
  657.     property Value: Double read GetAsFloat write SetAsFloat;
  658.   published
  659.     property Currency: Boolean read FCurrency write SetCurrency default False;
  660.     property MaxValue: Double read FMaxValue write SetMaxValue;
  661.     property MinValue: Double read FMinValue write SetMinValue;
  662.     property Precision: Integer read FPrecision write SetPrecision default 15;
  663.   end;
  664.  
  665. { TCurrencyField }
  666.  
  667.   TCurrencyField = class(TFloatField)
  668.   public
  669.     constructor Create(AOwner: TComponent); override;
  670.   published
  671.     property Currency default True;
  672.   end;
  673.  
  674. { TBCDField }
  675.  
  676.   TBCDField = class(TNumericField)
  677.   public
  678.     FCurrency: Boolean;
  679.     FCheckRange: Boolean;
  680.     FMinValue: Currency;
  681.     FMaxValue: Currency;
  682.     procedure SetCurrency(Value: Boolean);
  683.     procedure SetMaxValue(Value: Currency);
  684.     procedure SetMinValue(Value: Currency);
  685.     procedure UpdateCheckRange;
  686.   protected
  687.     function GetAsCurrency: Currency; override;
  688.     function GetAsFloat: Double; override;
  689.     function GetAsInteger: Longint; override;
  690.     function GetAsString: string; override;
  691.     function GetAsVariant: Variant; override;
  692.     procedure GetText(var Text: string; DisplayText: Boolean); override;
  693.     function GetValue(var Value: Currency): Boolean;
  694.     procedure SetAsCurrency(Value: Currency); override;
  695.     procedure SetAsFloat(Value: Double); override;
  696.     procedure SetAsInteger(Value: Longint); override;
  697.     procedure SetAsString(const Value: string); override;
  698.     procedure SetVarValue(const Value: Variant); override;
  699.   public
  700.     constructor Create(AOwner: TComponent); override;
  701.     function IsValidChar(Ch: Char): Boolean; override;
  702.     property Value: Currency read GetAsCurrency write SetAsCurrency;
  703.   published
  704.     property Currency: Boolean read FCurrency write SetCurrency default False;
  705.     property MaxValue: Currency read FMaxValue write SetMaxValue;
  706.     property MinValue: Currency read FMinValue write SetMinValue;
  707.     property Size default 4;
  708.   end;
  709.  
  710. { TBooleanField }
  711.  
  712.   TBooleanField = class(TField)
  713.   private
  714.     FDisplayValues: string;
  715.     FTextValues: array[Boolean] of string;
  716.     procedure LoadTextValues;
  717.     procedure SetDisplayValues(const Value: string);
  718.   protected
  719.     function GetAsBoolean: Boolean; override;
  720.     function GetAsString: string; override;
  721.     function GetAsVariant: Variant; override;
  722.     function GetDefaultWidth: Integer; override;
  723.     procedure SetAsBoolean(Value: Boolean); override;
  724.     procedure SetAsString(const Value: string); override;
  725.     procedure SetVarValue(const Value: Variant); override;
  726.   public
  727.     constructor Create(AOwner: TComponent); override;
  728.     property Value: Boolean read GetAsBoolean write SetAsBoolean;
  729.   published
  730.     property DisplayValues: string read FDisplayValues write SetDisplayValues;
  731.   end;
  732.  
  733. { TDateTimeField }
  734.  
  735.   TDateTimeField = class(TField)
  736.   private
  737.     FDisplayFormat: string;
  738.     function GetValue(var Value: TDateTime): Boolean;
  739.     procedure SetDisplayFormat(const Value: string);
  740.   protected
  741.     function GetAsDateTime: TDateTime; override;
  742.     function GetAsFloat: Double; override;
  743.     function GetAsString: string; override;
  744.     function GetAsVariant: Variant; override;
  745.     procedure GetText(var Text: string; DisplayText: Boolean); override;
  746.     procedure SetAsDateTime(Value: TDateTime); override;
  747.     procedure SetAsFloat(Value: Double); override;
  748.     procedure SetAsString(const Value: string); override;
  749.     procedure SetVarValue(const Value: Variant); override;
  750.   public
  751.     constructor Create(AOwner: TComponent); override;
  752.     property Value: TDateTime read GetAsDateTime write SetAsDateTime;
  753.   published
  754.     property DisplayFormat: string read FDisplayFormat write SetDisplayFormat;
  755.     property EditMask;
  756.   end;
  757.  
  758. { TDateField }
  759.  
  760.   TDateField = class(TDateTimeField)
  761.   public
  762.     constructor Create(AOwner: TComponent); override;
  763.   end;
  764.  
  765. { TTimeField }
  766.  
  767.   TTimeField = class(TDateTimeField)
  768.   public
  769.     constructor Create(AOwner: TComponent); override;
  770.   end;
  771.  
  772.  
  773. { TBinaryField }
  774.  
  775.   TBinaryField = class(TField)
  776.   protected
  777.     function GetAsVariant: Variant; override;
  778.     procedure SetVarValue(const Value: Variant); override;
  779.   public
  780.     constructor Create(AOwner: TComponent); override;
  781.   published
  782.     property Size default 16;
  783.   end;
  784.  
  785. { TBytesField }
  786.  
  787.   TBytesField = class(TBinaryField)
  788.   public
  789.     constructor Create(AOwner: TComponent); override;
  790.   end;
  791.  
  792. { TVarBytesField }
  793.  
  794.   TVarBytesField = class(TBytesField)
  795.   public
  796.     constructor Create(AOwner: TComponent); override;
  797.   end;
  798.  
  799. { TBlobField }
  800.  
  801.   TBlobType = ftBlob..ftTypedBinary;
  802.  
  803.   TBlobField = class(TField)
  804.   private
  805.     FModified: Boolean;
  806.     FTransliterate: Boolean;
  807.     function GetBlobType: TBlobType;
  808.     procedure LoadFromBlob(Blob: TBlobField);
  809.     procedure LoadFromBitmap(Bitmap: TBitmap);
  810.     procedure LoadFromStrings(Strings: TStrings);
  811.     procedure SaveToBitmap(Bitmap: TBitmap);
  812.     procedure SaveToStrings(Strings: TStrings);
  813.     procedure SetBlobType(Value: TBlobType);
  814.   protected
  815.     procedure AssignTo(Dest: TPersistent); override;
  816.     procedure FreeBuffers; override;
  817.     function GetAsString: string; override;
  818.     function GetAsVariant: Variant; override;
  819.     procedure GetText(var Text: string; DisplayText: Boolean); override;
  820.     procedure SetAsString(const Value: string); override;
  821.     procedure SetVarValue(const Value: Variant); override;
  822.   public
  823.     constructor Create(AOwner: TComponent); override;
  824.     procedure Assign(Source: TPersistent); override;
  825.     procedure Clear; override;
  826.     procedure LoadFromFile(const FileName: string);
  827.     procedure LoadFromStream(Stream: TStream);
  828.     procedure SaveToFile(const FileName: string);
  829.     procedure SaveToStream(Stream: TStream);
  830.     procedure SetFieldType(Value: TFieldType); override;
  831.     procedure SetText(const Value: string); override;
  832.     property Value: string read GetAsString write SetAsString;
  833.   published
  834.     property BlobType: TBlobType read GetBlobType write SetBlobType;
  835.     property Size default 0;
  836.   end;
  837.  
  838. { TMemoField }
  839.  
  840.   TMemoField = class(TBlobField)
  841.   public
  842.     constructor Create(AOwner: TComponent); override;
  843.   published
  844.     property Transliterate: Boolean read FTransliterate write FTransliterate default True;
  845.   end;
  846.  
  847. { TGraphicField }
  848.  
  849.   TGraphicField = class(TBlobField)
  850.   public
  851.     constructor Create(AOwner: TComponent); override;
  852.   end;
  853.  
  854. { TBlobStream }
  855.  
  856.   TBlobStreamMode = (bmRead, bmWrite, bmReadWrite);
  857.  
  858.   TBlobStream = class(TStream)
  859.   private
  860.     FField: TBlobField;
  861.     FDataSet: TDataSet;
  862.     FRecord: PChar;
  863.     FBuffer: PChar;
  864.     FFieldNo: Integer;
  865.     FOpened: Boolean;
  866.     FModified: Boolean;
  867.     FPosition: Longint;
  868.     function GetBlobSize: Longint;
  869.   public
  870.     constructor Create(Field: TBlobField; Mode: TBlobStreamMode);
  871.     destructor Destroy; override;
  872.     function Read(var Buffer; Count: Longint): Longint; override;
  873.     function Write(const Buffer; Count: Longint): Longint; override;
  874.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  875.     procedure Truncate;
  876.   end;
  877.  
  878. { TFieldDataLink }
  879.  
  880.   TFieldDataLink = class(TDataLink)
  881.   private
  882.     FField: TField;
  883.     FFieldName: string;
  884.     FControl: TWinControl;
  885.     FEditing: Boolean;
  886.     FModified: Boolean;
  887.     FOnDataChange: TNotifyEvent;
  888.     FOnEditingChange: TNotifyEvent;
  889.     FOnUpdateData: TNotifyEvent;
  890.     FOnActiveChange: TNotifyEvent;
  891.     function GetCanModify: Boolean;
  892.     procedure SetEditing(Value: Boolean);
  893.     procedure SetField(Value: TField);
  894.     procedure SetFieldName(const Value: string);
  895.     procedure UpdateField;
  896.   protected
  897.     procedure ActiveChanged; override;
  898.     procedure EditingChanged; override;
  899.     procedure FocusControl(Field: TFieldRef); override;
  900.     procedure LayoutChanged; override;
  901.     procedure RecordChanged(Field: TField); override;
  902.     procedure UpdateData; override;
  903.   public
  904.     function Edit: Boolean;
  905.     procedure Modified;
  906.     procedure Reset;
  907.     property CanModify: Boolean read GetCanModify;
  908.     property Control: TWinControl read FControl write FControl;
  909.     property Editing: Boolean read FEditing;
  910.     property Field: TField read FField;
  911.     property FieldName: string read FFieldName write SetFieldName;
  912.     property OnDataChange: TNotifyEvent read FOnDataChange write FOnDataChange;
  913.     property OnEditingChange: TNotifyEvent read FOnEditingChange write FOnEditingChange;
  914.     property OnUpdateData: TNotifyEvent read FOnUpdateData write FOnUpdateData;
  915.     property OnActiveChange: TNotifyEvent read FOnActiveChange write FOnActiveChange;
  916.   end;
  917.  
  918. function BCDToCurr(const BCD: FMTBcd; var Curr: Currency): Boolean;
  919. function CurrToBCD(Curr: Currency; var BCD: FMTBcd; Precision,
  920.   Decimals: Integer): Boolean;
  921.  
  922. implementation
  923.  
  924. uses DBConsts, Forms;
  925.  
  926. { TQueryDataLink }
  927.  
  928. type
  929.   TQueryDataLink = class(TDataLink)
  930.   private
  931.     FQuery: TQuery;
  932.   protected
  933.     procedure ActiveChanged; override;
  934.     procedure RecordChanged(Field: TField); override;
  935.     procedure CheckBrowseMode; override;
  936.   public
  937.     constructor Create(AQuery: TQuery);
  938.   end;
  939.  
  940. { Date and time conversion record }
  941.  
  942. type
  943.   TDateTimeRec = record
  944.     case TFieldType of
  945.       ftDate: (Date: Longint);
  946.       ftTime: (Time: Longint);
  947.       ftDateTime: (DateTime: TDateTime);
  948.   end;
  949.  
  950. { Paradox graphic BLOB header }
  951.  
  952. type
  953.   TGraphicHeader = record
  954.     Count: Word;                { Fixed at 1 }
  955.     HType: Word;                { Fixed at $0100 }
  956.     Size: Longint;              { Size not including header }
  957.   end;
  958.  
  959. { Utility routines }
  960.  
  961. procedure CheckIndexOpen(Status: DBIResult);
  962. begin
  963.   if (Status <> 0) and (Status <> DBIERR_INDEXOPEN) then
  964.     DbiError(Status);
  965. end;
  966.  
  967. function IsFloat(const Value: string): Boolean;
  968. var
  969.   I: Integer;
  970. begin
  971.   Result := False;
  972.   if Value <> '' then
  973.   begin
  974.     for I := 1 to Length(Value) do
  975.       if not (Value[I] in [DecimalSeparator, '0'..'9']) then Exit;
  976.     Result := True;
  977.   end;
  978. end;
  979.  
  980. function IsInteger(const Value: string): Boolean;
  981. var
  982.   I: Integer;
  983. begin
  984.   Result := False;
  985.   if Value <> '' then
  986.   begin
  987.     for I := 1 to Length(Value) do
  988.       if not (Value[I] in ['0'..'9']) then Exit;
  989.     Result := True;
  990.   end;
  991. end;
  992.  
  993. function CompDiv(var Dividend: Comp; Divisor: Integer): Integer;
  994. asm
  995.         MOV     ECX,EDX
  996.         MOV     EDX,[EAX].Integer[4]
  997.         MOV     EAX,[EAX].Integer[0]
  998.         DIV     ECX
  999. end;
  1000.  
  1001. function CompMod(var Dividend: Comp; Divisor: Integer): Integer;
  1002. asm
  1003.         MOV     ECX,EDX
  1004.         MOV     EDX,[EAX].Integer[4]
  1005.         MOV     EAX,[EAX].Integer[0]
  1006.         DIV     ECX
  1007.         MOV     EAX,EDX
  1008. end;
  1009.  
  1010. function BCDToCurr(const BCD: FMTBcd; var Curr: Currency): Boolean;
  1011. const
  1012.   FConst10: Single = 10;
  1013.   CWNear: Word = $133F;
  1014. var
  1015.   CtrlWord: Word;
  1016.   Temp: Integer;
  1017.   Digits: array[0..63] of Byte;
  1018. asm
  1019.         PUSH    EBX
  1020.         PUSH    ESI
  1021.         MOV     EBX,EAX
  1022.         MOV     ESI,EDX
  1023.         MOV     AL,0
  1024.         MOVZX   EDX,[EBX].FMTBcd.iPrecision
  1025.         OR      EDX,EDX
  1026.         JE      @@8
  1027.         LEA     ECX,[EDX+1]
  1028.         SHR     ECX,1
  1029. @@1:    MOV     AL,[EBX].FMTBcd.iFraction.Byte[ECX-1]
  1030.         MOV     AH,AL
  1031.         SHR     AL,4
  1032.         AND     AH,0FH
  1033.         MOV     Digits.Word[ECX*2-2],AX
  1034.         DEC     ECX
  1035.         JNE     @@1
  1036.         XOR     EAX,EAX
  1037. @@2:    MOV     AL,Digits.Byte[ECX]
  1038.         OR      AL,AL
  1039.         JNE     @@3
  1040.         INC     ECX
  1041.         CMP     ECX,EDX
  1042.         JNE     @@2
  1043.         FLDZ
  1044.         JMP     @@7
  1045. @@3:    MOV     Temp,EAX
  1046.         FILD    Temp
  1047. @@4:    INC     ECX
  1048.         CMP     ECX,EDX
  1049.         JE      @@5
  1050.         FMUL    FConst10
  1051.         MOV     AL,Digits.Byte[ECX]
  1052.         MOV     Temp,EAX
  1053.         FIADD   Temp
  1054.         JMP     @@4
  1055. @@5:    MOV     AL,[EBX].FMTBcd.iSignSpecialPlaces
  1056.         OR      AL,AL
  1057.         JNS     @@6
  1058.         FCHS
  1059. @@6:    AND     EAX,3FH
  1060.         SUB     EAX,4
  1061.         NEG     EAX
  1062.         CALL    FPower10
  1063. @@7:    FSTCW   CtrlWord
  1064.         FLDCW   CWNear
  1065.         FISTP   [ESI].Currency
  1066.         FSTSW   AX
  1067.         NOT     AL
  1068.         AND     AL,1
  1069.         FCLEX
  1070.         FLDCW   CtrlWord
  1071.         FWAIT
  1072. @@8:    POP     ESI
  1073.         POP     EBX
  1074. end;
  1075.  
  1076. function CurrToBCD(Curr: Currency; var BCD: FMTBcd; Precision,
  1077.   Decimals: Integer): Boolean;
  1078. const
  1079.   Power10: array[0..3] of Single = (10000, 1000, 100, 10);
  1080. var
  1081.   Digits: array[0..63] of Byte;
  1082. asm
  1083.         PUSH    EBX
  1084.         PUSH    ESI
  1085.         PUSH    EDI
  1086.         MOV     ESI,EAX
  1087.         XCHG    ECX,EDX
  1088.         MOV     [ESI].FMTBcd.iPrecision,CL
  1089.         MOV     [ESI].FMTBcd.iSignSpecialPlaces,DL
  1090. @@1:    SUB     EDX,4
  1091.         JE      @@3
  1092.         JA      @@2
  1093.         FILD    Curr
  1094.         FDIV    Power10.Single[EDX*4+16]
  1095.         FISTP   Curr
  1096.         JMP     @@3
  1097. @@2:    DEC     ECX
  1098.         MOV     Digits.Byte[ECX],0
  1099.         DEC     EDX
  1100.         JNE     @@2
  1101. @@3:    MOV     EAX,Curr.Integer[0]
  1102.         MOV     EBX,Curr.Integer[4]
  1103.         OR      EBX,EBX
  1104.         JNS     @@4
  1105.         NEG     EBX
  1106.         NEG     EAX
  1107.         SBB     EBX,0
  1108.         OR      [ESI].FMTBcd.iSignSpecialPlaces,80H
  1109. @@4:    MOV     EDI,10
  1110. @@5:    MOV     EDX,EAX
  1111.         OR      EDX,EBX
  1112.         JE      @@7
  1113.         XOR     EDX,EDX
  1114.         OR      EBX,EBX
  1115.         JE      @@6
  1116.         XCHG    EAX,EBX
  1117.         DIV     EDI
  1118.         XCHG    EAX,EBX
  1119. @@6:    DIV     EDI
  1120. @@7:    MOV     Digits.Byte[ECX-1],DL
  1121.         DEC     ECX
  1122.         JNE     @@5
  1123.         OR      EAX,EBX
  1124.         MOV     AL,0
  1125.         JNE     @@9
  1126.         MOV     CL,[ESI].FMTBcd.iPrecision
  1127.         INC     ECX
  1128.         SHR     ECX,1
  1129. @@8:    MOV     AX,Digits.Word[ECX*2-2]
  1130.         SHL     AL,4
  1131.         OR      AL,AH
  1132.         MOV     [ESI].FMTBcd.iFraction.Byte[ECX-1],AL
  1133.         DEC     ECX
  1134.         JNE     @@8
  1135.         MOV     AL,1
  1136. @@9:    POP     EDI
  1137.         POP     ESI
  1138.         POP     EBX
  1139. end;
  1140.  
  1141. { TIndexDef }
  1142.  
  1143. constructor TIndexDef.Create(Owner: TIndexDefs; const Name, Fields: string;
  1144.   Options: TIndexOptions);
  1145. begin
  1146.   if Owner <> nil then
  1147.   begin
  1148.     Owner.FItems.Add(Self);
  1149.     Owner.FUpdated := False;
  1150.     FOwner := Owner;
  1151.   end;
  1152.   FName := Name;
  1153.   FFields := Fields;
  1154.   FOptions := Options;
  1155. end;
  1156.  
  1157. destructor TIndexDef.Destroy;
  1158. begin
  1159.   if FOwner <> nil then
  1160.   begin
  1161.     FOwner.FItems.Remove(Self);
  1162.     FOwner.FUpdated := False;
  1163.   end;
  1164. end;
  1165.  
  1166. function TIndexDef.GetExpression: string;
  1167. begin
  1168.   if ixExpression in Options then Result := FFields else Result := '';
  1169. end;
  1170.  
  1171. function TIndexDef.GetFields: string;
  1172. begin
  1173.   if ixExpression in Options then Result := '' else Result := FFields;
  1174. end;
  1175.  
  1176. { TIndexDefs }
  1177.  
  1178. constructor TIndexDefs.Create(Table: TTable);
  1179. begin
  1180.   FTable := Table;
  1181.   FItems := TList.Create;
  1182. end;
  1183.  
  1184. destructor TIndexDefs.Destroy;
  1185. begin
  1186.   if FItems <> nil then Clear;
  1187.   FItems.Free;
  1188. end;
  1189.  
  1190. procedure TIndexDefs.Add(const Name, Fields: string;
  1191.   Options: TIndexOptions);
  1192. begin
  1193.   if IndexOf(Name) >= 0 then DBErrorFmt(SDuplicateIndexName, [Name]);
  1194.   TIndexDef.Create(Self, Name, Fields, Options);
  1195. end;
  1196.  
  1197. procedure TIndexDefs.Assign(IndexDefs: TIndexDefs);
  1198. var
  1199.   I: Integer;
  1200. begin
  1201.   Clear;
  1202.   for I := 0 to IndexDefs.Count - 1 do
  1203.     with IndexDefs[I] do Add(Name, Fields, Options);
  1204. end;
  1205.  
  1206. procedure TIndexDefs.Clear;
  1207. begin
  1208.   while FItems.Count > 0 do TIndexDef(FItems.Last).Free;
  1209. end;
  1210.  
  1211. function TIndexDefs.FindIndexForFields(const Fields: string): TIndexDef;
  1212. begin
  1213.   Result := GetIndexForFields(Fields, False);
  1214.   if Result = nil then
  1215.     DBErrorFmt(SNoIndexForFields, [FTable.TableName, Fields]);
  1216. end;
  1217.  
  1218. function TIndexDefs.GetCount: Integer;
  1219. begin
  1220.   Result := FItems.Count;
  1221. end;
  1222.  
  1223. function TIndexDefs.GetIndexForFields(const Fields: string;
  1224.   CaseInsensitive: Boolean): TIndexDef;
  1225. var
  1226.   Exact: Boolean;
  1227.   I, L: Integer;
  1228. begin
  1229.   Update;
  1230.   L := Length(Fields);
  1231.   Exact := True;
  1232.   while True do
  1233.   begin
  1234.     for I := 0 to FItems.Count - 1 do
  1235.     begin
  1236.       Result := FItems[I];
  1237.       if (Result.FOptions * [ixDescending, ixExpression] = []) and
  1238.         (not CaseInsensitive or (ixCaseInsensitive in Result.FOptions)) then
  1239.         if Exact then
  1240.         begin
  1241.           if AnsiCompareText(Fields, Result.Fields) = 0 then Exit;
  1242.         end
  1243.         else begin
  1244.           if (AnsiCompareText(Fields, Copy(Result.Fields, 1, L)) = 0) and
  1245.             ((Length(Result.FFields) = L) or
  1246.             (Result.FFields[L + 1] = ';')) then Exit;
  1247.         end;
  1248.     end;
  1249.     if not Exact then Break;
  1250.     Exact := False;
  1251.   end;
  1252.   Result := nil;
  1253. end;
  1254.  
  1255. function TIndexDefs.GetItem(Index: Integer): TIndexDef;
  1256. begin
  1257.   Result := FItems[Index];
  1258. end;
  1259.  
  1260. function TIndexDefs.IndexOf(const Name: string): Integer;
  1261. begin
  1262.   for Result := 0 to FItems.Count - 1 do
  1263.     if AnsiCompareText(TIndexDef(FItems[Result]).FName, Name) = 0 then Exit;
  1264.   Result := -1;
  1265. end;
  1266.  
  1267. procedure TIndexDefs.Update;
  1268. begin
  1269.   FTable.UpdateIndexDefs;
  1270. end;
  1271.  
  1272. { TBatchMove }
  1273.  
  1274. constructor TBatchMove.Create(AOwner: TComponent);
  1275. begin
  1276.   inherited Create(AOwner);
  1277.   FAbortOnKeyViol := True;
  1278.   FAbortOnProblem := True;
  1279.   FTransliterate := True;
  1280.   FMappings := TStringList.Create;
  1281. end;
  1282.  
  1283. destructor TBatchMove.Destroy;
  1284. begin
  1285.   FMappings.Free;
  1286.   inherited Destroy;
  1287. end;
  1288.  
  1289. function TBatchMove.ConvertName(const Name: string; Buffer: PChar): PChar;
  1290. begin
  1291.   if Name <> '' then
  1292.     Result := AnsiToNative(Destination.DBLocale, Name, Buffer, 255) else
  1293.     Result := nil;
  1294. end;
  1295.  
  1296. procedure TBatchMove.Execute;
  1297. type
  1298.   PFieldMap = ^TFieldMap;
  1299.   TFieldMap = array[1..1024] of Word;
  1300. var
  1301.   SourceActive, DestinationActive: Boolean;
  1302.   BatchMode: TBatchMode;
  1303.   I: Integer;
  1304.   FieldCount: Word;
  1305.   FieldMap: PFieldMap;
  1306.   DestName, SourceName: string;
  1307.   SKeyViolName, SProblemName, SChangedName: DBITBLNAME;
  1308.  
  1309.   procedure GetMappingNames;
  1310.   var
  1311.     P: Integer;
  1312.     Mapping: string;
  1313.   begin
  1314.     Mapping := FMappings[I];
  1315.     P := Pos('=', Mapping);
  1316.     if P > 0 then
  1317.     begin
  1318.       DestName := Copy(Mapping, 1, P - 1);
  1319.       SourceName := Copy(Mapping, P + 1, 255);
  1320.     end else
  1321.     begin
  1322.       DestName := Mapping;
  1323.       SourceName := Mapping;
  1324.     end;
  1325.   end;
  1326.  
  1327. begin
  1328.   if (Destination = nil) or (Source = nil) or (Destination = Source) then
  1329.     DBError(SInvalidBatchMove);
  1330.   SourceActive := Source.Active;
  1331.   DestinationActive := Destination.Active;
  1332.   FieldCount := 0;
  1333.   FieldMap := nil;
  1334.   try
  1335.     Source.DisableControls;
  1336.     Destination.DisableControls;
  1337.     Source.Open;
  1338.     Source.CheckBrowseMode;
  1339.     Source.UpdateCursorPos;
  1340.     BatchMode := FMode;
  1341.     if BatchMode = batCopy then
  1342.     begin
  1343.       Destination.Close;
  1344.       if FMappings.Count = 0 then
  1345.         Destination.FieldDefs := Source.FieldDefs
  1346.       else
  1347.       begin
  1348.         Destination.FieldDefs.Clear;
  1349.         for I := 0 to FMappings.Count - 1 do
  1350.         begin
  1351.           GetMappingNames;
  1352.           with Source.FieldDefs.Find(SourceName) do
  1353.             Destination.FieldDefs.Add(DestName, DataType, Size, Required);
  1354.         end;
  1355.       end;
  1356.       Destination.IndexDefs.Clear;
  1357.       Destination.CreateTable;
  1358.       BatchMode := batAppend;
  1359.     end;
  1360.     Destination.Open;
  1361.     Destination.CheckBrowseMode;
  1362.     if FMappings.Count <> 0 then
  1363.     begin
  1364.       FieldCount := Destination.FieldDefs.Count;
  1365.       FieldMap := AllocMem(FieldCount * SizeOf(Word));
  1366.       for I := 0 to FMappings.Count - 1 do
  1367.       begin
  1368.         GetMappingNames;
  1369.         FieldMap^[Destination.FieldDefs.Find(DestName).FieldNo] :=
  1370.           Source.FieldDefs.Find(SourceName).FieldNo;
  1371.       end;
  1372.     end;
  1373.     if FRecordCount > 0 then
  1374.     begin
  1375.       Source.UpdateCursorPos;
  1376.       FMovedCount := FRecordCount;
  1377.     end else
  1378.     begin
  1379.       Check(DbiSetToBegin(Source.Handle));
  1380.       FMovedCount := MaxLongint;
  1381.     end;
  1382.     Source.CursorPosChanged;
  1383.     try
  1384.       if CommitCount > 0 then
  1385.         Check(DbiSetProp(hDBIObj(Destination.DBHandle), dbBATCHCOUNT, CommitCount));
  1386.       Check(DbiBatchMove(nil, Source.Handle, nil, Destination.Handle,
  1387.         EBATMode(BatchMode), FieldCount, PWord(FieldMap), nil, nil, 0,
  1388.         ConvertName(FKeyViolTableName, SKeyViolName),
  1389.         ConvertName(FProblemTableName, SProblemName),
  1390.         ConvertName(FChangedTableName, SChangedName),
  1391.         @FProblemCount, @FKeyViolCount, @FChangedCount,
  1392.         FAbortOnProblem, FAbortOnKeyViol, FMovedCount, FTransliterate));
  1393.     finally
  1394.       if DestinationActive then Destination.First;
  1395.     end;
  1396.   finally
  1397.     if FieldMap <> nil then FreeMem(FieldMap, FieldCount * SizeOf(Word));
  1398.     if not DestinationActive then Destination.Close;
  1399.     if not SourceActive then Source.Close;
  1400.     Destination.EnableControls;
  1401.     Source.EnableControls;
  1402.   end;
  1403. end;
  1404.  
  1405. procedure TBatchMove.Notification(AComponent: TComponent;
  1406.   Operation: TOperation);
  1407. begin
  1408.   inherited Notification(AComponent, Operation);
  1409.   if Operation = opRemove then
  1410.   begin
  1411.     if Destination = AComponent then Destination := nil;
  1412.     if Source = AComponent then Source := nil;
  1413.   end;
  1414. end;
  1415.  
  1416. procedure TBatchMove.SetDesination(Value: TTable);
  1417. begin
  1418.   FDestination := Value;
  1419.   if Value <> nil then Value.FreeNotification(Self);
  1420. end;
  1421.  
  1422. procedure TBatchMove.SetMappings(Value: TStrings);
  1423. begin
  1424.   FMappings.Assign(Value);
  1425. end;
  1426.  
  1427. procedure TBatchMove.SetSource(Value: TDataSet);
  1428. begin
  1429.   FSource := Value;
  1430.   if Value <> nil then Value.FreeNotification(Self);
  1431. end;
  1432.  
  1433. { TTableDataLink }
  1434.  
  1435. constructor TTableDataLink.Create(Table: TTable);
  1436. begin
  1437.   inherited Create;
  1438.   FTable := Table;
  1439.   FFields := TList.Create;
  1440. end;
  1441.  
  1442. destructor TTableDataLink.Destroy;
  1443. begin
  1444.   FFields.Free;
  1445.   inherited Destroy;
  1446. end;
  1447.  
  1448. procedure TTableDataLink.ActiveChanged;
  1449. begin
  1450.   FFields.Clear;
  1451.   if Active then
  1452.     try
  1453.       DataSet.GetFieldList(FFields, FFieldNames);
  1454.     except
  1455.       FFields.Clear;
  1456.       raise;
  1457.     end;
  1458.   if FTable.Active and not (csDestroying in FTable.ComponentState) then
  1459.     if Active and (FFields.Count > 0) then
  1460.       FTable.MasterChanged else
  1461.       FTable.CancelRange;
  1462. end;
  1463.  
  1464. procedure TTableDataLink.CheckBrowseMode;
  1465. begin
  1466.   if FTable.Active then FTable.CheckBrowseMode;
  1467. end;
  1468.  
  1469. procedure TTableDataLink.LayoutChanged;
  1470. begin
  1471.   ActiveChanged;
  1472. end;
  1473.  
  1474. procedure TTableDataLink.RecordChanged(Field: TField);
  1475. begin
  1476.   if (DataSource.State <> dsSetKey) and FTable.Active and
  1477.     (FFields.Count > 0) and ((Field = nil) or
  1478.     (FFields.IndexOf(Field) >= 0)) then
  1479.     FTable.MasterChanged;
  1480. end;
  1481.  
  1482. procedure TTableDataLink.SetFieldNames(const Value: string);
  1483. begin
  1484.   if FFieldNames <> Value then
  1485.   begin
  1486.     FFieldNames := Value;
  1487.     ActiveChanged;
  1488.   end;
  1489. end;
  1490.  
  1491. { TIndexFiles }
  1492.  
  1493. constructor TIndexFiles.Create(AOwner: TTable);
  1494. begin
  1495.   inherited Create;
  1496.   FOwner := AOwner;
  1497. end;
  1498.  
  1499. function TIndexFiles.Add(const S: string): Integer;
  1500. begin
  1501.   Result := inherited Add(S);
  1502.   with FOwner do
  1503.   begin
  1504.     if Active then OpenIndexFile(S);
  1505.     FIndexDefs.FUpdated := False;
  1506.   end;
  1507. end;
  1508.  
  1509. procedure TIndexFiles.Clear;
  1510. var
  1511.   I: Integer;
  1512. begin
  1513.   with FOwner do
  1514.     if Active then
  1515.       for I := 0 to Count - 1 do CloseIndexFile(Strings[I]);
  1516.   inherited Clear;
  1517. end;
  1518.  
  1519. procedure TIndexFiles.Insert(Index: Integer; const S: string);
  1520. begin
  1521.   inherited Insert(Index, S);
  1522.   with FOwner do
  1523.   begin
  1524.     if Active then OpenIndexFile(S);
  1525.     FIndexDefs.FUpdated := False;
  1526.   end;
  1527. end;
  1528.  
  1529. procedure TIndexFiles.Delete(Index: Integer);
  1530. begin
  1531.   with FOwner do
  1532.   begin
  1533.     if Active then CloseIndexFile(Strings[Index]);
  1534.     FIndexDefs.FUpdated := False;
  1535.   end;
  1536.   inherited Delete(Index);
  1537. end;
  1538.  
  1539. { TTable }
  1540.  
  1541. constructor TTable.Create(AOwner: TComponent);
  1542. begin
  1543.   inherited Create(AOwner);
  1544.   FIndexDefs := TIndexDefs.Create(Self);
  1545.   FDataLink := TTableDataLink.Create(Self);
  1546.   FIndexFiles := TIndexFiles.Create(Self);
  1547. end;
  1548.  
  1549. destructor TTable.Destroy;
  1550. begin
  1551.   FIndexFiles.Free;
  1552.   FDataLink.Free;
  1553.   FIndexDefs.Free;
  1554.   inherited Destroy;
  1555. end;
  1556.  
  1557. procedure TTable.AddIndex(const Name, Fields: string;
  1558.   Options: TIndexOptions);
  1559. var
  1560.   STableName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  1561.   IndexDesc: IDXDesc;
  1562.   OldLocale, CursorLocale: TLocale;
  1563.   LName: string;
  1564. begin
  1565.   CursorLocale := nil;
  1566.   FieldDefs.Update;
  1567.   if Active then
  1568.   begin
  1569.     EncodeIndexDesc(IndexDesc, Name, Fields, Options);
  1570.     CheckBrowseMode;
  1571.     CursorPosChanged;
  1572.     Check(DbiAddIndex(DBHandle, Handle, nil, nil, IndexDesc, nil));
  1573.   end
  1574.   else begin
  1575.     LName := GetLanguageDriverName;
  1576.     if (LName <> '') and (OsLdLoadBySymbName(PChar(LName), CursorLocale) = 0) then
  1577.     begin
  1578.       OldLocale := Locale;
  1579.       SetLocale(CursorLocale);
  1580.     end;
  1581.     try
  1582.       EncodeIndexDesc(IndexDesc, Name, Fields, Options);
  1583.       SetDBFlag(dbfTable, True);
  1584.       try
  1585.         Check(DbiAddIndex(DBHandle, nil, AnsiToNative(DBLocale, TableName,
  1586.           STableName, SizeOf(STableName) - 1), GetTableTypeName,
  1587.           IndexDesc, nil));
  1588.       finally
  1589.         SetDBFlag(dbfTable, False);
  1590.       end;
  1591.     finally
  1592.       if CursorLocale <> nil then
  1593.       begin
  1594.         OsLdUnloadObj(CursorLocale);
  1595.         SetLocale(OldLocale);
  1596.       end;
  1597.     end;
  1598.   end;
  1599.   FIndexDefs.FUpdated := False;
  1600. end;
  1601.  
  1602. procedure TTable.ApplyRange;
  1603. begin
  1604.   CheckBrowseMode;
  1605.   if SetCursorRange then First;
  1606. end;
  1607.  
  1608. function TTable.BatchMove(ASource: TDataSet; AMode: TBatchMode): Longint;
  1609. begin
  1610.   with TBatchMove.Create(nil) do
  1611.   try
  1612.     Destination := Self;
  1613.     Source := ASource;
  1614.     Mode := AMode;
  1615.     Execute;
  1616.     Result := MovedCount;
  1617.   finally
  1618.     Free;
  1619.   end;
  1620. end;
  1621.  
  1622. procedure TTable.CancelRange;
  1623. begin
  1624.   CheckBrowseMode;
  1625.   UpdateCursorPos;
  1626.   if ResetCursorRange then Resync([]);
  1627. end;
  1628.  
  1629. function TTable.GetCanModify: Boolean;
  1630. begin
  1631.   Result := inherited GetCanModify and not ReadOnly;
  1632. end;
  1633.  
  1634. function TTable.GetHandle(const IndexName, IndexTag: string): HDBICur;
  1635. const
  1636.   OpenModes: array[Boolean] of DbiOpenMode = (dbiReadWrite, dbiReadOnly);
  1637.   ShareModes: array[Boolean] of DbiShareMode = (dbiOpenShared, dbiOpenExcl);
  1638. var
  1639.   STableName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  1640.   SIndexName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  1641.   OpenMode: DbiOpenMode;
  1642.   RetCode: DbiResult;
  1643.   I: Integer;
  1644. begin
  1645.   AnsiToNative(DBLocale, FTableName, STableName, SizeOf(STableName) - 1);
  1646.   Result := nil;
  1647.   OpenMode := OpenModes[FReadOnly or ForceUpdateCallback];
  1648.   while True do
  1649.   begin
  1650.     RetCode := DbiOpenTable(DBHandle, STableName, GetTableTypeName,
  1651.       PChar(IndexName), PChar(IndexTag), 0, OpenMode, ShareModes[FExclusive],
  1652.       xltField, False, nil, Result);
  1653.     if RetCode = DBIERR_TABLEREADONLY then
  1654.       OpenMode := dbiReadOnly
  1655.     else if CheckOpen(RetCode) then Break;
  1656.   end;
  1657.   if IsDBaseTable then
  1658.     for I := 0 to IndexFiles.Count - 1 do
  1659.     begin
  1660.       CharToOem(PChar(IndexFiles[I]), SIndexName);
  1661.       CheckIndexOpen(DbiOpenIndex(Result, SIndexName, 0));
  1662.     end;
  1663. end;
  1664.  
  1665. function TTable.CreateHandle: HDBICur;
  1666. var
  1667.   IndexName, IndexTag: string;
  1668. begin
  1669.   if FTableName = '' then DBError(SNoTableName);
  1670.   GetIndexParams(FIndexName, FFieldsIndex, IndexName, IndexTag);
  1671.   if IsProductionIndex(IndexName) then
  1672.     Result := GetHandle(IndexName, IndexTag) else
  1673.     Result := GetHandle('', '');
  1674. end;
  1675.  
  1676. function TTable.GetLanguageDriverName: string;
  1677. const
  1678.   Names: array[TTableType] of string =
  1679.     (szPARADOX, szPARADOX, szDBASE, szASCII);
  1680. var
  1681.   Buffer: array[0..DBIMAXPATHLEN] of char;
  1682.   S, DriverName: string;
  1683.   Database: TDatabase;
  1684. begin
  1685.   Buffer[0] := #0;
  1686.   DriverName := '';
  1687.   Database := DBSession.OpenDatabase(DatabaseName);
  1688.   try
  1689.     if Database.IsSQLBased then
  1690.     begin
  1691.       DriverName := Session.GetAliasDriverName(DatabaseName);
  1692.       FmtStr(S, ':%s:%s', [DatabaseName, TableName]);
  1693.       AnsiToNative(DBLocale, S, Buffer, SizeOf(Buffer) - 1);
  1694.     end
  1695.     else begin
  1696.       AnsiToNative(DBLocale, TableName, Buffer, SizeOf(Buffer) - 1);
  1697.       DbiFormFullName(Database.Handle, Buffer, nil, Buffer);
  1698.       if (TableType <> ttDefault) or
  1699.         (ExtractFileExt(TableName) = '') then
  1700.         DriverName := Names[TableType]
  1701.       else if IsDBaseTable then
  1702.         DriverName := szDBASE else
  1703.         DriverName := szPARADOX;
  1704.     end;
  1705.     if DbiGetLdName(PChar(DriverName), @Buffer, @Buffer) <> 0 then
  1706.       Buffer := #0;
  1707.   finally
  1708.     Session.CloseDatabase(Database);
  1709.   end;
  1710.   Result := Buffer;
  1711. end;
  1712.  
  1713. procedure TTable.CreateTable;
  1714. var
  1715.   I: Integer;
  1716.   FieldDescs: PFLDDesc;
  1717.   ValCheckPtr: PVCHKDesc;
  1718.   DriverTypeName: DBINAME;
  1719.   TableDesc: CRTblDesc;
  1720.   TempLocale, OldLocale: TLocale;
  1721.   LName: string;
  1722.   SQLLName: DBIName;
  1723.   PSQLLName: PChar;
  1724.  
  1725.   function GetStandardLanguageDriver: string;
  1726.   var
  1727.     DriverName: string;
  1728.     Buffer: array[0..DBIMAXNAMELEN - 1] of char;
  1729.   begin
  1730.     if not Database.IsSQLBased then
  1731.     begin
  1732.       DriverName := GetTableTypeName;
  1733.       if DriverName = '' then
  1734.         if IsDBaseTable then
  1735.           DriverName := szDBASE else
  1736.           DriverName := szPARADOX;
  1737.       if DbiGetLdName(PChar(DriverName), nil, Buffer) = 0 then
  1738.         Result := Buffer;
  1739.     end
  1740.     else Result := '';
  1741.   end;
  1742.  
  1743. begin
  1744.   CheckInactive;
  1745.   if FieldDefs.Count = 0 then
  1746.     for I := 0 to FieldCount - 1 do
  1747.       with Fields[I] do
  1748.         if FieldKind = fkData then
  1749.           FieldDefs.Add(FieldName, DataType, Size, Required);
  1750.   FieldDescs := nil;
  1751.   FillChar(TableDesc, SizeOf(TableDesc), 0);
  1752.   with TableDesc do
  1753.   begin
  1754.     SetDBFlag(dbfTable, True);
  1755.     try
  1756.       AnsiToNative(Locale, TableName, szTblName, SizeOf(szTblName) - 1);
  1757.       if GetTableTypeName <> nil then
  1758.         StrCopy(szTblType, GetTableTypeName);
  1759.       iFldCount := FieldDefs.Count;
  1760.       FieldDescs := AllocMem(iFldCount * SizeOf(FLDDesc));
  1761.       TempLocale := nil;
  1762.       LName := GetStandardLanguageDriver;
  1763.       if (LName <> '') and (OsLdLoadBySymbName(PChar(LName), TempLocale) = 0) then
  1764.       begin
  1765.         OldLocale := Locale;
  1766.         SetLocale(TempLocale);
  1767.       end;
  1768.       try
  1769.         for I := 0 to FieldDefs.Count - 1 do
  1770.           with FieldDefs[I] do
  1771.           begin
  1772.             EncodeFieldDesc(PFieldDescList(FieldDescs)^[I], Name,
  1773.               DataType, Size);
  1774.             if Required then Inc(iValChkCount);
  1775.           end;
  1776.       finally
  1777.         if TempLocale <> nil then
  1778.         begin
  1779.           OsLdUnloadObj(TempLocale);
  1780.           SetLocale(OldLocale);
  1781.         end;
  1782.       end;
  1783.       pFldDesc := AllocMem(iFldCount * SizeOf(FLDDesc));
  1784.       PSQLLName := nil;
  1785.       if Database.IsSQLBased then
  1786.         if DbiGetLdNameFromDB(DBHandle, nil, SQLLName) = 0 then
  1787.           PSQLLName := SQLLName;
  1788.       Check(DbiTranslateRecordStructure(nil, iFldCount, FieldDescs,
  1789.         GetDriverTypeName(DriverTypeName), PSQLLName, pFLDDesc, False));
  1790.       iIdxCount := IndexDefs.Count;
  1791.       pIdxDesc := AllocMem(iIdxCount * SizeOf(IDXDesc));
  1792.       for I := 0 to IndexDefs.Count - 1 do
  1793.         with IndexDefs[I] do
  1794.           EncodeIndexDesc(PIndexDescList(pIdxDesc)^[I], Name, Fields,
  1795.             Options);
  1796.       if iValChkCount <> 0 then
  1797.       begin
  1798.         pVChkDesc := AllocMem(iValChkCount * SizeOf(VCHKDesc));
  1799.         ValCheckPtr := pVChkDesc;
  1800.         for I := 0 to FieldDefs.Count - 1 do
  1801.           if FieldDefs[I].Required then
  1802.           begin
  1803.             ValCheckPtr^.iFldNum := I + 1;
  1804.             ValCheckPtr^.bRequired := True;
  1805.             Inc(ValCheckPtr);
  1806.           end;
  1807.       end;
  1808.       Check(DbiCreateTable(DBHandle, True, TableDesc));
  1809.     finally
  1810.       if pVChkDesc <> nil then FreeMem(pVChkDesc, iValChkCount * SizeOf(VCHKDesc));
  1811.       if pIdxDesc <> nil then FreeMem(pIdxDesc, iIdxCount * SizeOf(IDXDesc));
  1812.       if pFldDesc <> nil then FreeMem(pFldDesc, iFldCount * SizeOf(FLDDesc));
  1813.       if FieldDescs <> nil then FreeMem(FieldDescs, iFldCount * SizeOf(FLDDesc));
  1814.       SetDBFlag(dbfTable, False);
  1815.     end;
  1816.   end;
  1817. end;
  1818.  
  1819. procedure TTable.DataEvent(Event: TDataEvent; Info: Longint);
  1820. begin
  1821.   if Event = dePropertyChange then FIndexDefs.FUpdated := False;
  1822.   inherited DataEvent(Event, Info);
  1823. end;
  1824.  
  1825. procedure TTable.DecodeIndexDesc(const IndexDesc: IDXDesc;
  1826.   var Source, Name, Fields: string; var Options: TIndexOptions);
  1827. var
  1828.   IndexOptions: TIndexOptions;
  1829.   I: Integer;
  1830.   SSource, SName: PChar;
  1831. begin
  1832.   with IndexDesc do
  1833.   begin
  1834.     if szTagName[0] = #0 then
  1835.     begin
  1836.       SName := szName;
  1837.       Source := '';
  1838.     end
  1839.     else begin
  1840.       SSource := szName;
  1841.       SName := szTagName;
  1842.       NativeToAnsi(nil, SSource, Source);
  1843.     end;
  1844.     NativeToAnsi(Locale, SName, Name);
  1845.     Name := ExtractFileName(Name);
  1846.     Source := ExtractFileName(Source);
  1847.     IndexOptions := [];
  1848.     if bPrimary then Include(IndexOptions, ixPrimary);
  1849.     if bUnique then Include(IndexOptions, ixUnique);
  1850.     if bDescending then Include(IndexOptions, ixDescending);
  1851.     if bCaseInsensitive then Include(IndexOptions, ixCaseInsensitive);
  1852.     if bExpIdx then
  1853.     begin
  1854.       Include(IndexOptions, ixExpression);
  1855.       NativeToAnsi(Locale, szKeyExp, Fields);
  1856.     end else
  1857.     begin
  1858.       Fields := '';
  1859.       for I := 0 to iFldsInKey - 1 do
  1860.       begin
  1861.         if I <> 0 then Fields := Fields + ';';
  1862.         Fields := Fields + FieldDefs[aiKeyFld[I] - 1].Name;
  1863.       end;
  1864.     end;
  1865.     Options := IndexOptions;
  1866.   end;
  1867. end;
  1868.  
  1869. procedure TTable.DeleteIndex(const Name: string);
  1870. var
  1871.   STableName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  1872.   IndexName, IndexTag: string;
  1873.   OldLocale, CursorLocale: TLocale;
  1874.   LName: string;
  1875. begin
  1876.   if Active then
  1877.   begin
  1878.     GetIndexParams(Name, False, IndexName, IndexTag);
  1879.     CheckBrowseMode;
  1880.     Check(DbiDeleteIndex(DBHandle, Handle, nil, nil, PChar(IndexName),
  1881.       PChar(IndexTag), 0));
  1882.   end
  1883.   else begin
  1884.     CursorLocale := nil;
  1885.     LName := GetLanguageDriverName;
  1886.     if (LName <> '') and (OsLdLoadBySymbName(PChar(LName), CursorLocale) = 0) then
  1887.     begin
  1888.       OldLocale := Locale;
  1889.       SetLocale(CursorLocale);
  1890.     end;
  1891.     try
  1892.       GetIndexParams(Name, False, IndexName, IndexTag);
  1893.       SetDBFlag(dbfTable, True);
  1894.       try
  1895.         Check(DbiDeleteIndex(DBHandle, nil, AnsiToNative(DBLocale, TableName,
  1896.           STableName, SizeOf(STableName) - 1), GetTableTypeName,
  1897.           PChar(IndexName), PChar(IndexTag), 0));
  1898.       finally
  1899.         SetDBFlag(dbfTable, False);
  1900.       end;
  1901.     finally
  1902.       if CursorLocale <> nil then
  1903.       begin
  1904.         OsLdUnloadObj(CursorLocale);
  1905.         SetLocale(OldLocale);
  1906.       end;
  1907.     end;
  1908.   end;
  1909.   FIndexDefs.FUpdated := False;
  1910. end;
  1911.  
  1912. procedure TTable.DeleteTable;
  1913. var
  1914.   STableName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  1915. begin
  1916.   CheckInactive;
  1917.   SetDBFlag(dbfTable, True);
  1918.   try
  1919.     Check(DbiDeleteTable(DBHandle, AnsiToNative(DBLocale, TableName,
  1920.       STableName, SizeOf(STableName) - 1), GetTableTypeName));
  1921.   finally
  1922.     SetDBFlag(dbfTable, False);
  1923.   end;
  1924. end;
  1925.  
  1926. procedure TTable.DestroyHandle;
  1927. begin
  1928.   DestroyLookupCursor;
  1929.   inherited DestroyHandle;
  1930. end;
  1931.  
  1932. procedure TTable.DestroyLookupCursor;
  1933. begin
  1934.   if FLookupHandle <> nil then
  1935.   begin
  1936.     DbiCloseCursor(FLookupHandle);
  1937.     FLookupHandle := nil;
  1938.     FLookupKeyFields := '';
  1939.   end;
  1940. end;
  1941.  
  1942. procedure TTable.DoOnNewRecord;
  1943. var
  1944.   I: Integer;
  1945. begin
  1946.   if FDataLink.Active and (FDataLink.FFields.Count > 0) then
  1947.     for I := 0 to FDataLink.FFields.Count - 1 do
  1948.       IndexFields[I] := TField(FDataLink.FFields[I]);
  1949.   inherited DoOnNewRecord;
  1950. end;
  1951.  
  1952. procedure TTable.EditKey;
  1953. begin
  1954.   SetKeyBuffer(kiLookup, False);
  1955. end;
  1956.  
  1957. procedure TTable.EditRangeEnd;
  1958. begin
  1959.   SetKeyBuffer(kiRangeEnd, False);
  1960. end;
  1961.  
  1962. procedure TTable.EditRangeStart;
  1963. begin
  1964.   SetKeyBuffer(kiRangeStart, False);
  1965. end;
  1966.  
  1967. procedure TTable.EmptyTable;
  1968. var
  1969.   STableName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  1970. begin
  1971.   if Active then
  1972.   begin
  1973.     CheckBrowseMode;
  1974.     Check(DbiEmptyTable(DBHandle, Handle, nil, nil));
  1975.     ClearBuffers;
  1976.     DataEvent(deDataSetChange, 0);
  1977.   end else
  1978.   begin
  1979.     SetDBFlag(dbfTable, True);
  1980.     try
  1981.       Check(DbiEmptyTable(DBHandle, nil, AnsiToNative(DBLocale, TableName,
  1982.         STableName, SizeOf(STableName) - 1), GetTableTypeName));
  1983.     finally
  1984.       SetDBFlag(dbfTable, False);
  1985.     end;
  1986.   end;
  1987. end;
  1988.  
  1989. procedure TTable.EncodeFieldDesc(var FieldDesc: FLDDesc;
  1990.   const Name: string; DataType: TFieldType; Size: Word);
  1991. const
  1992.   TypeMap: array[TFieldType] of Word = (
  1993.     fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
  1994.     fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
  1995.     fldVARBYTES, fldINT32, fldBLOB, fldBLOB, fldBLOB, fldBLOB, fldBLOB,
  1996.     fldBLOB, fldBLOB);
  1997.   SubTypeMap: array[TFieldType] of Word = (
  1998.     0, 0, 0, 0, 0, 0, 0, fldstMONEY, 0, 0, 0, 0, 0, 0, fldstAUTOINC,
  1999.     fldstBINARY, fldstMEMO, fldstGRAPHIC, fldstFMTMEMO, fldstOLEOBJ,
  2000.     fldstDBSOLEOBJ, fldstTYPEDBINARY);
  2001. begin
  2002.   with FieldDesc do
  2003.   begin
  2004.     AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1);
  2005.     iFldType := TypeMap[DataType];
  2006.     iSubType := SubTypeMap[DataType];
  2007.     case DataType of
  2008.       ftString, ftBytes, ftVarBytes, ftBlob, ftMemo, ftGraphic,
  2009.       ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary:
  2010.         iUnits1 := Size;
  2011.       ftBCD:
  2012.         begin
  2013.           iUnits1 := 32;
  2014.           iUnits2 := Size;
  2015.         end;
  2016.     end;
  2017.   end;
  2018. end;
  2019.  
  2020. procedure TTable.EncodeIndexDesc(var IndexDesc: IDXDesc;
  2021.   const Name, Fields: string; Options: TIndexOptions);
  2022. var
  2023.   Pos: Integer;
  2024. begin
  2025.   FillChar(IndexDesc, SizeOf(IndexDesc), 0);
  2026.   with IndexDesc do
  2027.   begin
  2028.     if IsDBaseTable then
  2029.       AnsiToNative(Locale, Name, szTagName, SizeOf(szTagName) - 1)
  2030.     else
  2031.       AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1);
  2032.     bPrimary := ixPrimary in Options;
  2033.     bUnique := ixUnique in Options;
  2034.     bDescending := ixDescending in Options;
  2035.     bMaintained := True;
  2036.     bCaseInsensitive := ixCaseInsensitive in Options;
  2037.     if ixExpression in Options then
  2038.     begin
  2039.       bExpIdx := True;
  2040.       AnsiToNative(Locale, Fields, szKeyExp, SizeOf(szKeyExp) - 1);
  2041.     end else
  2042.     begin
  2043.       Pos := 1;
  2044.       while (Pos <= Length(Fields)) and (iFldsInKey < 16) do
  2045.       begin
  2046.         aiKeyFld[iFldsInKey] :=
  2047.           FieldDefs.Find(ExtractFieldName(Fields, Pos)).FieldNo;
  2048.         Inc(iFldsInKey);
  2049.       end;
  2050.     end;
  2051.   end;
  2052. end;
  2053.  
  2054. function TTable.FindKey(const KeyValues: array of const): Boolean;
  2055. begin
  2056.   CheckBrowseMode;
  2057.   SetKeyFields(kiLookup, KeyValues);
  2058.   Result := GotoKey;
  2059. end;
  2060.  
  2061. procedure TTable.FindNearest(const KeyValues: array of const);
  2062. begin
  2063.   CheckBrowseMode;
  2064.   SetKeyFields(kiLookup, KeyValues);
  2065.   GotoNearest;
  2066. end;
  2067.  
  2068. function TTable.GetDataSource: TDataSource;
  2069. begin
  2070.   Result := FDataLink.DataSource;
  2071. end;
  2072.  
  2073. function TTable.GetDriverTypeName(Buffer: PChar): PChar;
  2074. var
  2075.   Length: Word;
  2076. begin
  2077.   Result := Buffer;
  2078.   Check(DbiGetProp(HDBIOBJ(DBHandle), dbDATABASETYPE, Buffer,
  2079.     SizeOf(DBINAME), Length));
  2080.   if StrIComp(Buffer, 'STANDARD') = 0 then
  2081.   begin
  2082.     Result := GetTableTypeName;
  2083.     if Result <> nil then Result := StrCopy(Buffer, Result);
  2084.   end;
  2085. end;
  2086.  
  2087. function TTable.GetIndexFieldNames: string;
  2088. begin
  2089.   if FFieldsIndex then Result := FIndexName else Result := '';
  2090. end;
  2091.  
  2092. function TTable.GetIndexName: string;
  2093. begin
  2094.   if FFieldsIndex then Result := '' else Result := FIndexName;
  2095. end;
  2096.  
  2097. procedure TTable.GetIndexNames(List: TStrings);
  2098. var
  2099.   I: Integer;
  2100. begin
  2101.   UpdateIndexDefs;
  2102.   for I := 0 to FIndexDefs.Count - 1 do
  2103.     with FIndexDefs[I] do
  2104.       if Name <> '' then List.Add(Name);
  2105. end;
  2106.  
  2107. procedure TTable.GetIndexParams(const IndexName: string;
  2108.   FieldsIndex: Boolean; var IndexedName, IndexTag: string);
  2109. var
  2110.   I: Integer;
  2111.   IndexStr: TIndexName;
  2112.   SIndexName: array[0..127] of Char;
  2113.   SIndexTag: array[0..DBIMAXNAMELEN - 1] of Char;
  2114.   OldLocale, CursorLocale: TLocale;
  2115.   LName: string;
  2116. begin
  2117.   SIndexName[0] := #0;
  2118.   SIndexTag[0] := #0;
  2119.   if (IndexName <> '') and not InfoQueryMode then
  2120.   begin
  2121.     UpdateIndexDefs;
  2122.     IndexStr := IndexName;
  2123.     CursorLocale := nil;
  2124.     if not Active then LName := GetLanguageDriverName;
  2125.     if (LName <> '') and (OsLdLoadBySymbName(PChar(LName), CursorLocale) = 0) then
  2126.     begin
  2127.       OldLocale := Locale;
  2128.       SetLocale(CursorLocale);
  2129.     end;
  2130.     try
  2131.       if FieldsIndex then
  2132.         if Database.IsSQLBased then
  2133.         begin
  2134.           for I := 1 to Length(IndexStr) do
  2135.             if IndexStr[I] = ';' then IndexStr[I] := '@';
  2136.           IndexStr := '@' + IndexStr;
  2137.         end else
  2138.           IndexStr := IndexDefs.FindIndexForFields(IndexName).Name;
  2139.       if IsDBaseTable then
  2140.       begin
  2141.         if UpperCase(ExtractFileExt(IndexStr)) <> '.NDX' then
  2142.         begin
  2143.           AnsiToNative(Locale, IndexStr, SIndexTag, SizeOf(SIndexTag) - 1);
  2144.           with IndexDefs do
  2145.           begin
  2146.             I := IndexOf(IndexStr);
  2147.             if I <> -1 then
  2148.               IndexStr := Items[I].Source else
  2149.               DBErrorFmt(SIndexDoesNotExist, [IndexName]);
  2150.             AnsiToNative(nil, IndexStr, SIndexName, SizeOf(SIndexName) - 1);
  2151.           end;
  2152.         end;
  2153.       end else
  2154.         AnsiToNative(Locale, IndexStr, SIndexName, SizeOf(SIndexName) - 1);
  2155.     finally
  2156.       if CursorLocale <> nil then
  2157.       begin
  2158.         OsLdUnloadObj(CursorLocale);
  2159.         SetLocale(OldLocale);
  2160.       end;
  2161.     end;
  2162.   end;
  2163.   IndexedName := SIndexName;
  2164.   IndexTag := SIndexTag;
  2165. end;
  2166.  
  2167. function TTable.GetLookupCursor(const KeyFields: string;
  2168.   CaseInsensitive: Boolean): HDBICur;
  2169. var
  2170.   FLookupFldLen: Integer;
  2171.   IndexFound, FieldsIndex: Boolean;
  2172.   KeyIndexName, IndexName, IndexTag: string;
  2173.   KeyIndex: TIndexDef;
  2174. begin
  2175.   FLookupFldLen := Length(FLookupKeyFields);
  2176.   if (FLookupFldLen = 0) or
  2177.      (StrComp(PChar(FLookupKeyFields), PChar(KeyFields)) <> 0) or
  2178.      (FLookupKeyFields[FLookupFldLen] <> Char(CaseInsensitive)) then
  2179.   begin
  2180.     DestroyLookupCursor;
  2181.     IndexFound := False;
  2182.     if Database.IsSQLBased then
  2183.     begin
  2184.       if not CaseInsensitive then
  2185.       begin
  2186.         KeyIndexName := KeyFields;
  2187.         FieldsIndex := True;
  2188.         IndexFound := True;
  2189.       end;
  2190.     end else
  2191.     begin
  2192.       KeyIndex := IndexDefs.GetIndexForFields(KeyFields, CaseInsensitive);
  2193.       if KeyIndex <> nil then
  2194.       begin
  2195.         KeyIndexName := KeyIndex.Name;
  2196.         FieldsIndex := False;
  2197.         IndexFound := True;
  2198.       end;
  2199.     end;
  2200.     if IndexFound then
  2201.     begin
  2202.       Check(DbiCloneCursor(Handle, True, False, FLookupHandle));
  2203.       GetIndexParams(KeyIndexName, FieldsIndex, IndexName, IndexTag);
  2204.       Check(DbiSwitchToIndex(FLookupHandle, PChar(IndexName),
  2205.         PChar(IndexTag), 0, False));
  2206.     end;
  2207.     FLookupKeyFields := Format('%s'#0'%s', [KeyFields, Char(CaseInsensitive)]);
  2208.   end;
  2209.   Result := FLookupHandle;
  2210. end;
  2211.  
  2212. function TTable.GetMasterFields: string;
  2213. begin
  2214.   Result := FDataLink.FFieldNames;
  2215. end;
  2216.  
  2217. function TTable.GetTableTypeName: PChar;
  2218. const
  2219.   Names: array[TTableType] of PChar =
  2220.     (szPARADOX, szPARADOX, szDBASE, szASCII);
  2221. var
  2222.   TableType: TTableType;
  2223.   Extension: string;
  2224. begin
  2225.   Result := nil;
  2226.   if not Database.IsSQLBased then
  2227.   begin
  2228.     TableType := FTableType;
  2229.     if TableType = ttDefault then
  2230.     begin
  2231.       Extension := ExtractFileExt(FTableName);
  2232.       if CompareText(Extension, '.DBF') = 0 then TableType := ttDBase;
  2233.       if CompareText(Extension, '.TXT') = 0 then TableType := ttASCII;
  2234.     end;
  2235.     Result := Names[TableType];
  2236.   end;
  2237. end;
  2238.  
  2239. procedure TTable.GotoCurrent(Table: TTable);
  2240. begin
  2241.   CheckBrowseMode;
  2242.   Table.CheckBrowseMode;
  2243.   if (AnsiCompareText(DatabaseName, Table.DatabaseName) <> 0) or
  2244.     (AnsiCompareText(TableName, Table.TableName) <> 0) then
  2245.     DBError(STableMismatch);
  2246.   Table.UpdateCursorPos;
  2247.   Check(DbiSetToCursor(Handle, Table.Handle));
  2248.   Resync([rmExact, rmCenter]);
  2249. end;
  2250.  
  2251. function TTable.GotoKey: Boolean;
  2252. var
  2253.   KeyBuffer: PKeyBuffer;
  2254.   IndexBuffer, RecBuffer: PChar;
  2255.   UseKey: Boolean;
  2256. begin
  2257.   CheckBrowseMode;
  2258.   CursorPosChanged;
  2259.   KeyBuffer := GetKeyBuffer(kiLookup);
  2260.   IndexBuffer := AllocMem(KeySize);
  2261.   try
  2262.     RecBuffer := PChar(KeyBuffer) + SizeOf(TKeyBuffer);
  2263.     UseKey := DbiExtractKey(Handle, RecBuffer, IndexBuffer) = 0;
  2264.     if UseKey then RecBuffer := IndexBuffer;
  2265.     Result := DbiGetRecordForKey(Handle, UseKey, KeyBuffer^.FieldCount, 0,
  2266.       RecBuffer, nil) = 0;
  2267.     if Result then Resync([rmExact, rmCenter]);
  2268.   finally
  2269.     FreeMem(IndexBuffer, KeySize);
  2270.   end;
  2271. end;
  2272.  
  2273. procedure TTable.GotoNearest;
  2274. var
  2275.   SearchCond: DBISearchCond;
  2276.   KeyBuffer: PKeyBuffer;
  2277.   IndexBuffer, RecBuffer: PChar;
  2278.   UseKey: Boolean;
  2279. begin
  2280.   CheckBrowseMode;
  2281.   CursorPosChanged;
  2282.   KeyBuffer := GetKeyBuffer(kiLookup);
  2283.   if KeyBuffer^.Exclusive then
  2284.     SearchCond := keySEARCHGT else
  2285.     SearchCond := keySEARCHGEQ;
  2286.   IndexBuffer := AllocMem(KeySize);
  2287.   try
  2288.     RecBuffer := PChar(KeyBuffer) + SizeOf(TKeyBuffer);
  2289.     UseKey := DbiExtractKey(Handle, RecBuffer, IndexBuffer) = 0;
  2290.     if UseKey then RecBuffer := IndexBuffer;
  2291.     Check(DbiSetToKey(Handle, SearchCond, UseKey, KeyBuffer^.FieldCount, 0,
  2292.       RecBuffer));
  2293.     Resync([rmCenter]);
  2294.   finally
  2295.     FreeMem(IndexBuffer, KeySize);
  2296.   end;
  2297. end;
  2298.  
  2299. procedure TTable.InitFieldDefs;
  2300. var
  2301.   FieldNo: Word;
  2302.   FCursor, VCursor: HDBICur;
  2303.   RequiredFields: set of 0..255;
  2304.   STableName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  2305.   FieldDesc: FLDDesc;
  2306.   ValCheckDesc: VCHKDesc;
  2307.   OldLocale, CursorLocale: TLocale;
  2308.   LName: string;
  2309. begin
  2310.   CursorLocale := nil;
  2311.   SetDBFlag(dbfFieldList, True);
  2312.   try
  2313.     if FTableName = '' then DBError(SNoTableName);
  2314.     AnsiToNative(DBLocale, TableName, STableName, SizeOf(STableName) - 1);
  2315.     RequiredFields := [];
  2316.     if not Active then LName := GetLanguageDriverName;
  2317.     if (LName <> '') and (OsLdLoadBySymbName(PChar(LName), CursorLocale) = 0) then
  2318.     begin
  2319.       OldLocale := Locale;
  2320.       SetLocale(CursorLocale);
  2321.     end;
  2322.     try
  2323.       while not CheckOpen(DbiOpenFieldList(DBHandle, STableName,
  2324.         GetTableTypeName, False, FCursor)) do {Retry};
  2325.       try
  2326.         if DbiOpenVChkList(DBHandle, STableName, GetTableTypeName,
  2327.           VCursor) = 0 then
  2328.         begin
  2329.           while DbiGetNextRecord(VCursor, dbiNoLock, @ValCheckDesc, nil) = 0 do
  2330.             if ValCheckDesc.bRequired then
  2331.               Include(RequiredFields, ValCheckDesc.iFldNum - 1);
  2332.           DbiCloseCursor(VCursor);
  2333.         end;
  2334.         FieldNo := 0;
  2335.         FieldDefs.Clear;
  2336.         while DbiGetNextRecord(FCursor, dbiNoLock, @FieldDesc, nil) = 0 do
  2337.         begin
  2338.           FieldDefs.AddFieldDesc(FieldDesc, FieldNo in RequiredFields,
  2339.             FieldNo + 1);
  2340.           Inc(FieldNo);
  2341.         end;
  2342.       finally
  2343.         DbiCloseCursor(FCursor);
  2344.       end;
  2345.     finally
  2346.       if CursorLocale <> nil then
  2347.       begin
  2348.         OsLdUnloadObj(CursorLocale);
  2349.         SetLocale(OldLocale);
  2350.       end;
  2351.     end;
  2352.   finally
  2353.     SetDBFlag(dbfFieldList, False);
  2354.   end;
  2355. end;
  2356.  
  2357. function TTable.IsDBaseTable: Boolean;
  2358. begin
  2359.   Result := (FTableType = ttDBase) or
  2360.     (CompareText(ExtractFileExt(TableName), '.DBF') = 0);
  2361. end;
  2362.  
  2363. function TTable.IsProductionIndex(const IndexName: string): Boolean;
  2364. begin
  2365.   Result := True;
  2366.   if IsDBaseTable and (IndexName <> '') then
  2367.     if AnsiUpperCase(ExtractFileExt(IndexName)) = '.NDX' then
  2368.       Result := False
  2369.     else Result := AnsiUpperCase(ChangeFileExt(TableName, '')) =
  2370.       AnsiUpperCase(ChangeFileExt(IndexName, ''));
  2371. end;
  2372.  
  2373. procedure TTable.LockTable(LockType: TLockType);
  2374. begin
  2375.   SetTableLock(LockType, True);
  2376. end;
  2377.  
  2378. procedure TTable.MasterChanged;
  2379. begin
  2380.   CheckBrowseMode;
  2381.   UpdateRange;
  2382.   ApplyRange;
  2383. end;
  2384.  
  2385. procedure TTable.PrepareCursor;
  2386. var
  2387.   IndexName, IndexTag: string;
  2388. begin
  2389.   GetIndexParams(FIndexName, FFieldsIndex, IndexName, IndexTag);
  2390.   if not IsProductionIndex(IndexName) then SwitchToIndex(IndexName, IndexTag);
  2391.   if FDataLink.Active and (FDataLink.FFields.Count > 0) then
  2392.   begin
  2393.     UpdateRange;
  2394.     SetCursorRange;
  2395.   end;
  2396. end;
  2397.  
  2398. procedure TTable.RenameTable(const NewTableName: string);
  2399. var
  2400.   SCurTableName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  2401.   SNewTableName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  2402. begin
  2403.   CheckInactive;
  2404.   SetDBFlag(dbfTable, True);
  2405.   try
  2406.     Check(DbiRenameTable(DBHandle, AnsiToNative(DBLocale, TableName,
  2407.       SCurTableName, SizeOf(SCurTableName) - 1), GetTableTypeName,
  2408.       AnsiToNative(DBLocale, NewTableName, SNewTableName,
  2409.       SizeOf(SNewTableName) - 1)));
  2410.   finally
  2411.     SetDBFlag(dbfTable, False);
  2412.   end;
  2413.   TableName := NewTableName;
  2414. end;
  2415.  
  2416. procedure TTable.SetDataSource(Value: TDataSource);
  2417. begin
  2418.   if IsLinkedTo(Value) then DBError(SCircularDataLink);
  2419.   FDataLink.DataSource := Value;
  2420. end;
  2421.  
  2422. procedure TTable.SetExclusive(Value: Boolean);
  2423. begin
  2424.   CheckInactive;
  2425.   FExclusive := Value;
  2426. end;
  2427.  
  2428. procedure TTable.SetIndex(const Value: string; FieldsIndex: Boolean);
  2429. var
  2430.   IndexName, IndexTag: string;
  2431. begin
  2432.   if Active then CheckBrowseMode;
  2433.   if (FIndexName <> Value) or (FFieldsIndex <> FieldsIndex) then
  2434.   begin
  2435.     if Active then
  2436.     begin
  2437.       GetIndexParams(Value, FieldsIndex, IndexName, IndexTag);
  2438.       SwitchToIndex(IndexName, IndexTag);
  2439.       if FDataLink.Active and (FDataLink.FFields.Count > 0) then
  2440.       begin
  2441.         UpdateRange;
  2442.         SetCursorRange;
  2443.       end;
  2444.     end;
  2445.     FIndexName := Value;
  2446.     FFieldsIndex := FieldsIndex;
  2447.     if Active then Resync([]);
  2448.   end;
  2449. end;
  2450.  
  2451. procedure TTable.SetIndexFieldNames(const Value: string);
  2452. begin
  2453.   SetIndex(Value, Value <> '');
  2454. end;
  2455.  
  2456. procedure TTable.SetIndexName(const Value: string);
  2457. begin
  2458.   SetIndex(Value, False);
  2459. end;
  2460.  
  2461. procedure TTable.SetIndexFiles(Value: TStrings);
  2462. begin
  2463.   FIndexFiles.Assign(Value);
  2464. end;
  2465.  
  2466. procedure TTable.SetKey;
  2467. begin
  2468.   SetKeyBuffer(kiLookup, True);
  2469. end;
  2470.  
  2471. procedure TTable.SetMasterFields(const Value: string);
  2472. begin
  2473.   FDataLink.SetFieldNames(Value);
  2474. end;
  2475.  
  2476. procedure TTable.SetRange(const StartValues, EndValues: array of const);
  2477. begin
  2478.   CheckBrowseMode;
  2479.   SetKeyFields(kiRangeStart, StartValues);
  2480.   SetKeyFields(kiRangeEnd, EndValues);
  2481.   ApplyRange;
  2482. end;
  2483.  
  2484. procedure TTable.SetRangeEnd;
  2485. begin
  2486.   SetKeyBuffer(kiRangeEnd, True);
  2487. end;
  2488.  
  2489. procedure TTable.SetRangeStart;
  2490. begin
  2491.   SetKeyBuffer(kiRangeStart, True);
  2492. end;
  2493.  
  2494. procedure TTable.SetReadOnly(Value: Boolean);
  2495. begin
  2496.   CheckInactive;
  2497.   FReadOnly := Value;
  2498. end;
  2499.  
  2500. procedure TTable.SetTableLock(LockType: TLockType; Lock: Boolean);
  2501. var
  2502.   L: DBILockType;
  2503. begin
  2504.   if State = dsInactive then DBError(SDataSetClosed);
  2505.   if LockType = ltReadLock then L := dbiREADLOCK else L := dbiWRITELOCK;
  2506.   if Lock then
  2507.     Check(DbiAcqTableLock(Handle, L)) else
  2508.     Check(DbiRelTableLock(Handle, False, L));
  2509. end;
  2510.  
  2511. procedure TTable.SetTableName(const Value: TFileName);
  2512. begin
  2513.   CheckInactive;
  2514.   if not (csReading in ComponentState) and
  2515.     (FTableName <> Value) then IndexFiles.Clear;
  2516.   FTableName := Value;
  2517.   DataEvent(dePropertyChange, 0);
  2518. end;
  2519.  
  2520. procedure TTable.SetTableType(Value: TTableType);
  2521. begin
  2522.   CheckInactive;
  2523.   FTableType := Value;
  2524. end;
  2525.  
  2526. procedure TTable.OpenIndexFile(const IndexName: string);
  2527. var
  2528.   Buffer: array[0..DBIMAXNAMELEN - 1] of char;
  2529. begin
  2530.   CheckIndexOpen(DbiOpenIndex(Handle,
  2531.     AnsiToNative(Locale, IndexName, Buffer, SizeOf(Buffer) - 1), 0));
  2532. end;
  2533.  
  2534. procedure TTable.CloseIndexFile(const IndexFileName: string);
  2535. var
  2536.   IndexName, IndexTag: string;
  2537.   Buffer: array[0..DBIMAXNAMELEN - 1] of char;
  2538. begin
  2539.   GetIndexParams(FIndexName, FFieldsIndex, IndexName, IndexTag);
  2540.   if AnsiUpperCase(IndexName) = AnsiUpperCase(IndexFileName) then
  2541.     Self.IndexName := '';
  2542.   Check(DbiCloseIndex(Handle,
  2543.     AnsiToNative(Locale, IndexFileName, Buffer, SizeOf(Buffer) - 1), 0));
  2544. end;
  2545.  
  2546. procedure TTable.UpdateIndexDefs;
  2547. var
  2548.   Options: TIndexOptions;
  2549.   Name, Source, Fields: string;
  2550.   CursorProps: CurProps;
  2551.   Cursor: HDBICur;
  2552.   IndexBuff: PIndexDescList;
  2553.   I: Integer;
  2554.   NumIndexes: Word;
  2555.   OldLocale, CursorLocale: TLocale;
  2556. begin
  2557.   if not FIndexDefs.FUpdated then
  2558.   begin
  2559.     SetDBFlag(dbfIndexList, True);
  2560.     try
  2561.       FieldDefs.Update;
  2562.       if Handle = nil then
  2563.       begin
  2564.         Cursor := GetHandle('', '');
  2565.         if DbiGetLdObj(Cursor, CursorLocale) = 0 then
  2566.         begin
  2567.           OldLocale := Locale;
  2568.           SetLocale(CursorLocale);
  2569.         end;
  2570.       end
  2571.       else Cursor := Handle;
  2572.       try
  2573.         DbiGetCursorProps(Cursor, CursorProps);
  2574.         NumIndexes := CursorProps.iIndexes;
  2575.         IndexBuff := AllocMem(NumIndexes * SizeOf(IDXDesc));
  2576.         try
  2577.           IndexDefs.Clear;
  2578.           DbiGetIndexDescs(Cursor, PIDXDesc(IndexBuff));
  2579.           for I := 0 to NumIndexes - 1 do
  2580.           begin
  2581.             DecodeIndexDesc(IndexBuff^[I], Source, Name, Fields, Options);
  2582.             with IndexDefs do
  2583.             begin
  2584.               Add(Name, Fields, Options);
  2585.               if Source <> '' then Items[Count - 1].FSource := Source;
  2586.             end;
  2587.           end;
  2588.           IndexDefs.FUpdated := True;
  2589.         finally
  2590.           FreeMem(IndexBuff, NumIndexes * SizeOf(IDXDesc));
  2591.         end;
  2592.       finally
  2593.         if (Cursor <> nil) and (Cursor <> Handle) then
  2594.         begin
  2595.           SetLocale(OldLocale);
  2596.           DbiCloseCursor(Cursor);
  2597.         end;
  2598.       end;
  2599.     finally
  2600.       SetDBFlag(dbfIndexList, False);
  2601.     end;
  2602.   end;
  2603. end;
  2604.  
  2605. procedure TTable.UpdateRange;
  2606. begin
  2607.   SetLinkRanges(FDataLink.FFields);
  2608. end;
  2609.  
  2610. procedure TTable.UnlockTable(LockType: TLockType);
  2611. begin
  2612.   SetTableLock(LockType, False);
  2613. end;
  2614.  
  2615. { TParams }
  2616.  
  2617. constructor TParams.Create;
  2618. begin
  2619.   FItems := TList.Create;
  2620. end;
  2621.  
  2622. destructor TParams.Destroy;
  2623. begin
  2624.   Clear;
  2625.   FItems.Free;
  2626.   inherited Destroy;
  2627. end;
  2628.  
  2629. procedure TParams.Assign(Source: TPersistent);
  2630. var
  2631.   I: Integer;
  2632. begin
  2633.   if Source is TParams then
  2634.   begin
  2635.     Clear;
  2636.     for I := 0 to TParams(Source).Count - 1 do
  2637.       with TParam.Create(Self, ptUnknown) do
  2638.         Assign(TParams(Source)[I]);
  2639.   end
  2640.   else inherited Assign(Source);
  2641. end;
  2642.  
  2643. procedure TParams.AssignTo(Dest: TPersistent);
  2644. begin
  2645.   if Dest is TParams then TParams(Dest).Assign(Self)
  2646.   else inherited AssignTo(Dest);
  2647. end;
  2648.  
  2649. procedure TParams.AssignValues(Value: TParams);
  2650. var
  2651.   I, J: Integer;
  2652. begin
  2653.   for I := 0 to Count - 1 do
  2654.     for J := 0 to Value.Count - 1 do
  2655.       if Items[I].Name = Value[J].Name then
  2656.       begin
  2657.         Items[I].Assign(Value[J]);
  2658.         Break;
  2659.       end;
  2660. end;
  2661.  
  2662. procedure TParams.AddParam(Value: TParam);
  2663. begin
  2664.   FItems.Add(Value);
  2665.   Value.FParamList := Self;
  2666. end;
  2667.  
  2668. procedure TParams.RemoveParam(Value: TParam);
  2669. begin
  2670.   FItems.Remove(Value);
  2671.   Value.FParamList := nil;
  2672. end;
  2673.  
  2674. function TParams.CreateParam(FldType: TFieldType; const ParamName: string;
  2675.   ParamType: TParamType): TParam;
  2676. begin
  2677.   Result := TParam.Create(Self, ParamType);
  2678.   with Result do
  2679.   begin
  2680.     Name := ParamName;
  2681.     DataType :=  FldType;
  2682.   end;
  2683. end;
  2684.  
  2685. function TParams.Count: Integer;
  2686. begin
  2687.   Result := FItems.Count;
  2688. end;
  2689.  
  2690. function TParams.IsEqual(Value: TParams): Boolean;
  2691. var
  2692.   I: Integer;
  2693. begin
  2694.   Result := Count = Value.Count;
  2695.   if Result then
  2696.     for I := 0 to Count - 1 do
  2697.     begin
  2698.       Result := Items[I].IsEqual(Value.Items[I]);
  2699.       if not Result then Break;
  2700.     end
  2701. end;
  2702.  
  2703. procedure TParams.Clear;
  2704. begin
  2705.   while FItems.Count > 0 do TParam(FItems.Last).Free;
  2706. end;
  2707.  
  2708. function TParams.GetParam(Index: Word): TParam;
  2709. begin
  2710.   Result := ParamByName(TParam(FItems[Index]).Name);
  2711. end;
  2712.  
  2713. function TParams.ParamByName(const Value: string): TParam;
  2714. var
  2715.   I: Integer;
  2716. begin
  2717.   for I := 0 to FItems.Count - 1 do
  2718.   begin
  2719.     Result := FItems[I];
  2720.     if AnsiCompareText(Result.Name, Value) = 0 then Exit;
  2721.   end;
  2722.   DBErrorFmt(SParameterNotFound, [Value]);
  2723. end;
  2724.  
  2725. procedure TParams.DefineProperties(Filer: TFiler);
  2726. begin
  2727.   inherited DefineProperties(Filer);
  2728.   Filer.DefineBinaryProperty('Data', ReadBinaryData, WriteBinaryData, Count > 0);
  2729. end;
  2730.  
  2731. procedure TParams.ReadBinaryData(Stream: TStream);
  2732. var
  2733.   I, Temp, NumItems: Integer;
  2734.   Buffer: array[0..255] of Char;
  2735.   TempStr: string;
  2736.   Version: Word;
  2737. begin
  2738.   Clear;
  2739.   with Stream do
  2740.   begin
  2741.     ReadBuffer(Version, SizeOf(Version));
  2742.     if Version > 2 then DBError(SInvalidVersion);
  2743.     NumItems := 0;
  2744.     if Version = 2 then ReadBuffer(NumItems, SizeOf(NumItems))
  2745.     else ReadBuffer(NumItems, 2);
  2746.     for I := 0 to NumItems - 1 do
  2747.       with TParam.Create(Self, ptUnknown) do
  2748.       begin
  2749.         Temp := 0;
  2750.         if Version = 2 then ReadBuffer(Temp, SizeOf(Temp))
  2751.         else ReadBuffer(Temp, 1);
  2752.         SetLength(TempStr, Temp);
  2753.         ReadBuffer(PChar(TempStr)^, Temp);
  2754.         Name := TempStr;
  2755.         ReadBuffer(FParamType, SizeOf(FParamType));
  2756.         ReadBuffer(FDataType, SizeOf(FDataType));
  2757.         if DataType <> ftUnknown then
  2758.         begin
  2759.           Temp := 0;
  2760.           if Version = 2 then ReadBuffer(Temp, SizeOf(Temp))
  2761.           else ReadBuffer(Temp, 2);
  2762.           ReadBuffer(Buffer, Temp);
  2763.           SetData(@Buffer);
  2764.         end;
  2765.         ReadBuffer(FNull, SizeOf(FNull));
  2766.         ReadBuffer(FBound, SizeOf(FBound));
  2767.       end;
  2768.   end;
  2769. end;
  2770.  
  2771. procedure TParams.WriteBinaryData(Stream: TStream);
  2772. var
  2773.   I: Integer;
  2774.   Temp: SmallInt;
  2775.   Version: Word;
  2776.   Buffer: array[0..255] of Char;
  2777. begin
  2778.   with Stream do
  2779.   begin
  2780.     Version := GetVersion;
  2781.     WriteBuffer(Version, SizeOf(Version));
  2782.     Temp := Count;
  2783.     WriteBuffer(Temp, SizeOf(Temp));
  2784.     for I := 0 to Count - 1 do
  2785.       with Items[I] do
  2786.       begin
  2787.         Temp := Length(FName);
  2788.         WriteBuffer(Temp, 1);
  2789.         WriteBuffer(PChar(FName)^, Length(FName));
  2790.         WriteBuffer(FParamType, SizeOf(FParamType));
  2791.         WriteBuffer(FDataType, SizeOf(FDataType));
  2792.         if DataType <> ftUnknown then
  2793.         begin
  2794.           GetData(@Buffer);
  2795.           Temp := GetDataSize;
  2796.           WriteBuffer(Temp, SizeOf(Temp));
  2797.           WriteBuffer(Buffer, Temp);
  2798.         end;
  2799.         WriteBuffer(FNull, SizeOf(FNull));
  2800.         WriteBuffer(FBound, SizeOf(FBound));
  2801.       end;
  2802.   end;
  2803. end;
  2804.  
  2805. function TParams.GetVersion: Word;
  2806. begin
  2807.   Result := 1;
  2808. end;
  2809.  
  2810. function TParams.GetParamValue(const ParamName: string): Variant;
  2811. var
  2812.   I: Integer;
  2813.   Params: TList;
  2814. begin
  2815.   if Pos(';', ParamName) <> 0 then
  2816.   begin
  2817.     Params := TList.Create;
  2818.     try
  2819.       GetParamList(Params, ParamName);
  2820.       Result := VarArrayCreate([0, Params.Count - 1], varVariant);
  2821.       for I := 0 to Params.Count - 1 do
  2822.         Result[I] := TParam(Params[I]).Value;
  2823.     finally
  2824.       Params.Free;
  2825.     end;
  2826.   end else
  2827.     Result := ParamByName(ParamName).Value
  2828. end;
  2829.  
  2830. procedure TParams.SetParamValue(const ParamName: string;
  2831.   const Value: Variant);
  2832. var
  2833.   I: Integer;
  2834.   Params: TList;
  2835. begin
  2836.   if Pos(';', ParamName) <> 0 then
  2837.   begin
  2838.     Params := TList.Create;
  2839.     try
  2840.       GetParamList(Params, ParamName);
  2841.       for I := 0 to Params.Count - 1 do
  2842.         TParam(Params[I]).Value := Value[I];
  2843.     finally
  2844.       Params.Free;
  2845.     end;
  2846.   end else
  2847.     ParamByName(ParamName).Value := Value;
  2848. end;
  2849.  
  2850. procedure TParams.GetParamList(List: TList; const ParamNames: string);
  2851. var
  2852.   Pos: Integer;
  2853. begin
  2854.   Pos := 1;
  2855.   while Pos <= Length(ParamNames) do
  2856.     List.Add(ParamByName(ExtractFieldName(ParamNames, Pos)));
  2857. end;
  2858.  
  2859. { TParam }
  2860.  
  2861. constructor TParam.Create(AParamList: TParams; AParamType: TParamType);
  2862. begin
  2863.   if AParamList <> nil then AParamList.AddParam(Self);
  2864.   ParamType := AParamType;
  2865.   DataType := ftUnknown;
  2866.   FBound := False;
  2867. end;
  2868.  
  2869. destructor TParam.Destroy;
  2870. begin
  2871.   if FParamList <> nil then FParamList.RemoveParam(Self);
  2872. end;
  2873.  
  2874. function TParam.IsEqual(Value: TParam): Boolean;
  2875. begin
  2876.   Result := (VarType(FData) = VarType(Value.FData)) and
  2877.     (FData = Value.FData) and (Name = Value.Name) and
  2878.     (DataType = Value.DataType) and (IsNull = Value.IsNull) and
  2879.     (Bound = Value.Bound) and (ParamType = Value.ParamType);
  2880. end;
  2881.  
  2882. procedure TParam.SetDataType(Value: TFieldType);
  2883. begin
  2884.   FData := 0;
  2885.   FDataType := Value;
  2886. end;
  2887.  
  2888. function TParam.GetDataSize: Word;
  2889. begin
  2890.   case DataType of
  2891.     ftUnknown: DBErrorFmt(SFieldUndefinedType, [Name]);
  2892.     ftString: Result := Length(FData) + 1;
  2893.     ftBoolean: Result := SizeOf(WordBool);
  2894.     ftBCD: Result := SizeOf(FMTBcd);
  2895.     ftDateTime,
  2896.     ftCurrency,
  2897.     ftFloat: Result := SizeOf(Double);
  2898.     ftTime,
  2899.     ftDate,
  2900.     ftAutoInc,
  2901.     ftInteger: Result := SizeOf(Integer);
  2902.     ftSmallint: Result := SizeOf(SmallInt);
  2903.     ftWord: Result := SizeOf(Word);
  2904.   else
  2905.     DBErrorFmt(SFieldUnsupportedType, [Name]);
  2906.   end;
  2907. end;
  2908.  
  2909. procedure TParam.GetData(Buffer: Pointer);
  2910. begin
  2911.   case DataType of
  2912.     ftUnknown: DBErrorFmt(SFieldUndefinedType, [Name]);
  2913.     ftString:
  2914.       begin
  2915.         StrMove(Buffer, PChar(string(FData)), Length(FData));
  2916.         (PChar(Buffer) + Length(FData))^ := #0;
  2917.       end;
  2918.     ftSmallint: SmallInt(Buffer^) := FData;
  2919.     ftWord: Word(Buffer^) := FData;
  2920.     ftAutoInc,
  2921.     ftInteger: Integer(Buffer^) := FData;
  2922.     ftTime: Integer(Buffer^) := DateTimeToTimeStamp(AsDateTime).Time;
  2923.     ftDate: Integer(Buffer^) := DateTimeToTimeStamp(AsDateTime).Date;
  2924.     ftDateTime:  Double(Buffer^) := TimeStampToMSecs(DateTimeToTimeStamp(AsDateTime));
  2925.     ftBCD: CurrToBCD(AsBCD, FMTBcd(Buffer^), 32, 4);
  2926.     ftCurrency,
  2927.     ftFloat: Double(Buffer^) := FData;
  2928.     ftBoolean: WordBool(Buffer^) := FData;
  2929.   else
  2930.     DBErrorFmt(SFieldUnsupportedType, [Name]);
  2931.   end;
  2932. end;
  2933.  
  2934. procedure TParam.SetData(Buffer: Pointer);
  2935. var
  2936.   Value: Currency;
  2937.   TimeStamp: TTimeStamp;
  2938. begin
  2939.   case DataType of
  2940.     ftUnknown: DBErrorFmt(SFieldUndefinedType, [Name]);
  2941.     ftString: AsString := StrPas(Buffer);
  2942.     ftWord: AsWord := Word(Buffer^);
  2943.     ftSmallint: AsSmallInt := Smallint(Buffer^);
  2944.     ftInteger: AsInteger := Integer(Buffer^);
  2945.     ftTime:
  2946.       begin
  2947.         TimeStamp.Time := LongInt(Buffer^);
  2948.         TimeStamp.Date := DateDelta;
  2949.         AsTime := TimeStampToDateTime(TimeStamp);
  2950.       end;
  2951.     ftDate:
  2952.       begin
  2953.         TimeStamp.Time := 0;
  2954.         TimeStamp.Date := Integer(Buffer^);
  2955.         AsDate := TimeStampToDateTime(TimeStamp);
  2956.       end;
  2957.     ftDateTime:
  2958.       begin
  2959.         TimeStamp.Time := 0;
  2960.         TimeStamp.Date := Integer(Buffer^);
  2961.         AsDateTime := TimeStampToDateTime(MSecsToTimeStamp(Double(Buffer^)));
  2962.       end;
  2963.     ftBCD:
  2964.       begin
  2965.         BCDToCurr(FMTBcd(Buffer^), Value);
  2966.         AsBCD := Value;
  2967.       end;
  2968.     ftCurrency: AsCurrency := Double(Buffer^);
  2969.     ftFloat: AsFloat := Double(Buffer^);
  2970.     ftBoolean: AsBoolean := WordBool(Buffer^);
  2971.   else
  2972.     DBErrorFmt(SFieldUnsupportedType, [Name]);
  2973.   end;
  2974. end;
  2975.  
  2976. procedure TParam.SetText(const Value: string);
  2977. begin
  2978.   InitValue;
  2979.   if DataType = ftUnknown then DataType := ftString;
  2980.   FData := Value;
  2981.   case DataType of
  2982.     ftDateTime, ftTime, ftDate: FData := VarToDateTime(FData);
  2983.     ftBCD: FData := Currency(FData);
  2984.     ftCurrency, ftFloat: FData := Single(FData);
  2985.     ftInteger, ftSmallInt, ftWord: FData := Integer(FData);
  2986.     ftBoolean: FData := Boolean(FData);
  2987.   end;
  2988. end;
  2989.  
  2990. procedure TParam.Assign(Param: TParam);
  2991. begin
  2992.   if Param <> nil then
  2993.   begin
  2994.     DataType := Param.DataType;
  2995.     if Param.IsNull then Clear
  2996.     else begin
  2997.       InitValue;
  2998.       FData := Param.FData;
  2999.     end;
  3000.     FBound := Param.Bound;
  3001.     Name := Param.Name;
  3002.     if ParamType = ptUnknown then ParamType := Param.ParamType;
  3003.   end;
  3004. end;
  3005.  
  3006. procedure TParam.AssignFieldValue(Field: TField; const Value: Variant);
  3007. begin
  3008.   if Field <> nil then
  3009.   begin
  3010.     DataType := Field.DataType;
  3011.     if VarIsNull(Value) then Clear
  3012.     else begin
  3013.       InitValue;
  3014.       FData := Value;
  3015.     end;
  3016.     FBound := True;
  3017.   end;
  3018. end;
  3019.  
  3020. procedure TParam.AssignField(Field: TField);
  3021. begin
  3022.   if Field <> nil then
  3023.   begin
  3024.     DataType := Field.DataType;
  3025.     if Field.IsNull then Clear
  3026.     else begin
  3027.       InitValue;
  3028.       FData := Field.Value;
  3029.     end;
  3030.     FBound := True;
  3031.     Name := Field.FieldName;
  3032.   end;
  3033. end;
  3034.  
  3035. procedure TParam.AccessError;
  3036. begin
  3037.   DBErrorFmt(SParamAccessError, [Name]);
  3038. end;
  3039.  
  3040. procedure TParam.Clear;
  3041. begin
  3042.   FNull := True;
  3043.   FData := 0;
  3044. end;
  3045.  
  3046. procedure TParam.InitValue;
  3047. begin
  3048.   FBound := True;
  3049.   FNull := False;
  3050. end;
  3051.  
  3052. procedure TParam.SetAsBoolean(Value: Boolean);
  3053. begin
  3054.   InitValue;
  3055.   DataType := ftBoolean;
  3056.   FData := Value;
  3057. end;
  3058.  
  3059. function TParam.GetAsBoolean: Boolean;
  3060. begin
  3061.   Result := FData;
  3062. end;
  3063.  
  3064. procedure TParam.SetAsFloat(Value: Double);
  3065. begin
  3066.   InitValue;
  3067.   DataType := ftFloat;
  3068.   FData := Value;
  3069. end;
  3070.  
  3071. procedure TParam.SetAsCurrency(Value: Double);
  3072. begin
  3073.   SetAsFloat(Value);
  3074.   FDataType := ftCurrency;
  3075. end;
  3076.  
  3077. procedure TParam.SetAsBCD(Value: Currency);
  3078. begin
  3079.   InitValue;
  3080.   FData := Value;
  3081.   FDataType := ftBCD;
  3082. end;
  3083.  
  3084. function TParam.GetAsFloat: Double;
  3085. begin
  3086.   Result := FData;
  3087. end;
  3088.  
  3089. function TParam.GetAsBCD: Currency;
  3090. begin
  3091.   Result := FData;
  3092. end;
  3093.  
  3094. procedure TParam.SetAsInteger(Value: Longint);
  3095. begin
  3096.   InitValue;
  3097.   DataType := ftInteger;
  3098.   FData := Value;
  3099. end;
  3100.  
  3101. procedure TParam.SetAsWord(Value: LongInt);
  3102. begin
  3103.   SetAsInteger(Value);
  3104.   FDataType := ftWord;
  3105. end;
  3106.  
  3107. procedure TParam.SetAsSmallInt(Value: LongInt);
  3108. begin
  3109.   SetAsInteger(Value);
  3110.   FDataType := ftSmallint;
  3111. end;
  3112.  
  3113. function TParam.GetAsInteger: Longint;
  3114. begin
  3115.   Result := FData;
  3116. end;
  3117.  
  3118. procedure TParam.SetAsString(const Value: string);
  3119. begin
  3120.   InitValue;
  3121.   DataType := ftString;
  3122.   FData := Value;
  3123. end;
  3124.  
  3125. function TParam.GetAsString: string;
  3126. begin
  3127.   if not IsNull then
  3128.     case DataType of
  3129.       ftBoolean:
  3130.         if FData then Result := LoadStr(STextTrue)
  3131.         else Result := LoadStr(STextFalse);
  3132.       ftDateTime, ftDate, ftTime: Result := VarFromDateTime(FData)
  3133.       else Result := FData;
  3134.     end
  3135.   else Result := ''
  3136. end;
  3137.  
  3138. procedure TParam.SetAsDate(Value: TDateTime);
  3139. begin
  3140.   InitValue;
  3141.   DataType := ftDate;
  3142.   FData := VarFromDateTime(Value);
  3143. end;
  3144.  
  3145. procedure TParam.SetAsTime(Value: TDateTime);
  3146. begin
  3147.   SetAsDate(Value);
  3148.   FDataType := ftTime;
  3149. end;
  3150.  
  3151. procedure TParam.SetAsDateTime(Value: TDateTime);
  3152. begin
  3153.   SetAsDate(Value);
  3154.   FDataType := ftDateTime;
  3155. end;
  3156.  
  3157. function TParam.GetAsDateTime: TDateTime;
  3158. begin
  3159.   if IsNull then
  3160.     Result := 0 else
  3161.     Result := VarToDateTime(FData);
  3162. end;
  3163.  
  3164. procedure TParam.SetAsVariant(Value: Variant);
  3165. begin
  3166.   InitValue;
  3167.   case VarType(Value) of
  3168.     varSmallint: DataType := ftSmallInt;
  3169.     varInteger: DataType := ftInteger;
  3170.     varCurrency: DataType := ftBCD;
  3171.     varSingle,
  3172.     varDouble: DataType := ftFloat;
  3173.     varDate: DataType := ftDateTime;
  3174.     varBoolean: DataType := ftBoolean;
  3175.     varString: DataType := ftString;
  3176.     else DataType := ftUnknown;
  3177.   end;
  3178.   FData := Value;
  3179. end;
  3180.  
  3181. function TParam.GetAsVariant: Variant;
  3182. begin
  3183.   Result := FData;
  3184. end;
  3185.  
  3186. { TQueryDataLink }
  3187.  
  3188. constructor TQueryDataLink.Create(AQuery: TQuery);
  3189. begin
  3190.   inherited Create;
  3191.   FQuery := AQuery;
  3192. end;
  3193.  
  3194. procedure TQueryDataLink.ActiveChanged;
  3195. begin
  3196.   if FQuery.Active then FQuery.RefreshParams;
  3197. end;
  3198.  
  3199. procedure TQueryDataLink.RecordChanged(Field: TField);
  3200. begin
  3201.   if (Field = nil) and FQuery.Active then FQuery.RefreshParams;
  3202. end;
  3203.  
  3204. procedure TQueryDataLink.CheckBrowseMode;
  3205. begin
  3206.   if FQuery.Active then FQuery.CheckBrowseMode;
  3207. end;
  3208.  
  3209. { TStoredProc }
  3210.  
  3211. constructor TStoredProc.Create(AOwner: TComponent);
  3212. begin
  3213.   inherited Create(AOwner);
  3214.   FParams := TParams.Create;
  3215.   FParamDesc := nil;
  3216.   FRecordBuffer := nil;
  3217.   FServerDescs := nil;
  3218. end;
  3219.  
  3220. destructor TStoredProc.Destroy;
  3221. begin
  3222.   Destroying;
  3223.   Disconnect;
  3224.   FParams.Free;
  3225.   inherited Destroy;
  3226. end;
  3227.  
  3228. procedure TStoredProc.Disconnect;
  3229. begin
  3230.   Close;
  3231.   UnPrepare;
  3232. end;
  3233.  
  3234. function TStoredProc.CreateCursor(GenHandle: Boolean): HDBICur;
  3235. begin
  3236.   if StoredProcName <> '' then
  3237.   begin
  3238.     SetPrepared(True);
  3239.     Result := GetCursor(GenHandle);
  3240.   end
  3241.   else Result := nil;
  3242. end;
  3243.  
  3244. function TStoredProc.CreateHandle: HDBICur;
  3245. begin
  3246.   Result := CreateCursor(True);
  3247. end;
  3248.  
  3249. function TStoredProc.GetCursor(GenHandle: Boolean): HDBICur;
  3250. var
  3251.   PCursor: phDBICur;
  3252. begin
  3253.   Result := nil;
  3254.   if GenHandle then PCursor := @Result
  3255.   else PCursor := nil;
  3256.   BindParams;
  3257.   Check(DbiQExec(StmtHandle, PCursor));
  3258.   GetResults;
  3259. end;
  3260.  
  3261. procedure TStoredProc.ExecProc;
  3262. begin
  3263.   CheckInActive;
  3264.   SetDBFlag(dbfExecProc, True);
  3265.   try
  3266.     CreateCursor(False);
  3267.   finally
  3268.     SetDBFlag(dbfExecProc, False);
  3269.   end;
  3270. end;
  3271.  
  3272. procedure TStoredProc.SetProcName(const Value: string);
  3273. begin
  3274.   if not (csReading in ComponentState) then
  3275.   begin
  3276.     CheckInactive;
  3277.     if Value <> FProcName then
  3278.     begin
  3279.       FProcName := Value;
  3280.       FreeStatement;
  3281.       FParams.Clear;
  3282.     end;
  3283.   end else
  3284.     FProcName := Value;
  3285. end;
  3286.  
  3287. procedure TStoredProc.SetOverLoad(Value: Word);
  3288. begin
  3289.   if not (csReading in ComponentState) then
  3290.   begin
  3291.     CheckInactive;
  3292.     if Value <> OverLoad then
  3293.     begin
  3294.       FOverLoad := Value;
  3295.       FreeStatement;
  3296.       FParams.Clear;
  3297.     end
  3298.   end else
  3299.     FOverLoad := Value;
  3300. end;
  3301.  
  3302. function TStoredProc.GetParamsCount: Word;
  3303. begin
  3304.   Result := FParams.Count;
  3305. end;
  3306.  
  3307. procedure TStoredProc.CreateParamDesc;
  3308. const
  3309.   TypeMap: array[0..MAXLOGFLDTYPES - 1] of TFieldType = (
  3310.     ftUnknown, ftString, ftDate, ftBlob, ftBoolean, ftSmallint,
  3311.     ftInteger, ftFloat, ftBCD, ftBytes, ftTime, ftDateTime,
  3312.     ftWord, ftUnknown, ftUnknown, ftVarBytes, ftUnknown);
  3313. var
  3314.   Desc: SPParamDesc;
  3315.   Cursor: HDBICur;
  3316.   Buffer: array[0..DBIMAXSPNAMELEN] of Char;
  3317.   Name: string;
  3318.   DataType: TFieldType;
  3319. begin
  3320.   AnsiToNative(DBLocale, StoredProcName, Buffer, DBIMAXSPNAMELEN);
  3321.   if DbiOpenSPParamList(DBHandle, Buffer, False, OverLoad, Cursor) = 0 then
  3322.   try
  3323.     while DbiGetNextRecord(Cursor, dbiNOLOCK, @Desc, nil) = 0 do
  3324.       with Desc do
  3325.       begin
  3326.         NativeToAnsi(DBLocale, szName, Name);
  3327.         if (TParamType(eParamType) = ptResult) and (Name = '') then
  3328.           Name := LoadStr(SResultName);
  3329.         if uFldType < MAXLOGFLDTYPES then DataType := TypeMap[uFldType]
  3330.         else DataType := ftUnknown;
  3331.         if (uFldType = fldFLOAT) and (uSubType = fldstMONEY) then
  3332.           DataType := ftCurrency;
  3333.         FParams.CreateParam(DataType, Name, TParamType(eParamType));
  3334.       end;
  3335.     SetServerParams;
  3336.   finally
  3337.     DbiCloseCursor(Cursor);
  3338.   end;
  3339. end;
  3340.  
  3341. procedure TStoredProc.SetServerParams;
  3342. var
  3343.   I: Integer;
  3344.   DescPtr: PServerDesc;
  3345. begin
  3346.   FServerDescs := StrAlloc(Params.Count * SizeOf(TServerDesc));
  3347.   DescPtr := PServerDesc(FServerDescs);
  3348.   for I := 0 to Params.Count - 1 do
  3349.     with Params[I], DescPtr^ do
  3350.     begin
  3351.       ParamName := Name;
  3352.       BindType := DataType;
  3353.       Inc(DescPtr);
  3354.     end;
  3355. end;
  3356.  
  3357. function TStoredProc.CheckServerParams: Boolean;
  3358. var
  3359.   I, J: Integer;
  3360.   DescPtr: PServerDesc;
  3361. begin
  3362.   if FServerDescs = nil then
  3363.   begin
  3364.     SetServerParams;
  3365.     Result := False;
  3366.   end else
  3367.   begin
  3368.     DescPtr := PServerDesc(FServerDescs);
  3369.     for I := 0 to StrBufSize(FServerDescs) div SizeOf(TServerDesc) - 1 do
  3370.     begin
  3371.       for J := 0 to Params.Count - 1 do
  3372.         with Params.Items[J], DescPtr^ do
  3373.           if (Name = ParamName) and (DataType <> BindType) then
  3374.           begin
  3375.             Result := False;
  3376.             Exit;
  3377.           end;
  3378.       Inc(DescPtr);
  3379.     end;
  3380.     Result := True;
  3381.   end;
  3382. end;
  3383.  
  3384. function TStoredProc.DescriptionsAvailable: Boolean;
  3385. var
  3386.   Cursor: HDBICur;
  3387.   Buffer: array[0..DBIMAXSPNAMELEN] of Char;
  3388. begin
  3389.   SetDBFlag(dbfProcDesc, True);
  3390.   try
  3391.     AnsiToNative(DBLocale, StoredProcName, Buffer, DBIMAXSPNAMELEN);
  3392.     Result := DbiOpenSPParamList(DBHandle, Buffer, False, OverLoad, Cursor) = 0;
  3393.     if Result then DbiCloseCursor(Cursor);
  3394.   finally
  3395.     SetDBFlag(dbfProcDesc, False);
  3396.   end;
  3397. end;
  3398.  
  3399. procedure TStoredProc.PrepareProc;
  3400. const
  3401.   TypeMap: array[TFieldType] of Byte = (
  3402.     fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
  3403.     fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
  3404.     fldVARBYTES, fldINT32, fldBLOB, fldBLOB, fldBLOB, fldBLOB, fldBLOB,
  3405.     fldBLOB, fldBLOB);
  3406. var
  3407.   I: Integer;
  3408.   Desc: PSPParamDesc;
  3409.   NumBytes, Offset: Word;
  3410.   Buffer: array[0..DBIMAXSPNAMELEN] of Char;
  3411. begin
  3412.   FParamDesc := StrAlloc(FParams.Count * SizeOf(SPParamDesc));
  3413.   FillChar(FParamDesc^, StrBufSize(FParamDesc), 0);
  3414.   Desc := PSPParamDesc(FParamDesc);
  3415.   NumBytes := 0;
  3416.   for I := 0 to FParams.Count - 1 do
  3417.     with Params[I] do
  3418.       if DataType = ftString then Inc(NumBytes, 255 + 2)
  3419.       else Inc(NumBytes, GetDataSize + 2);
  3420.   FRecordBuffer := StrAlloc(NumBytes);
  3421.   FillChar(FRecordBuffer^, NumBytes, 0);
  3422.   Offset := 0;
  3423.   for I := 0 to FParams.Count - 1 do
  3424.   begin
  3425.     with Params[I] do
  3426.     begin
  3427.       with Desc^ do
  3428.       begin
  3429.         if DataType = ftUnknown then
  3430.           DBErrorFmt(SNoParameterValue, [Name]);
  3431.         if ParamType = ptUnknown then
  3432.           DBErrorFmt(SNoParameterType, [Name]);
  3433.         if FBindMode = pbByName then
  3434.           AnsiToNative(Locale, Name, szName, DBIMAXNAMELEN)
  3435.         else uParamNum := I + 1;
  3436.         eParamType := STMTParamType(ParamType);
  3437.         uFldType := TypeMap[DataType];
  3438.         if DataType = ftCurrency then uSubType := fldstMONEY;
  3439.         if uFldType = fldZString then
  3440.         begin
  3441.           uLen := 255;
  3442.           iUnits1 := uLen - 1;
  3443.         end else
  3444.           uLen := GetDataSize;
  3445.         uOffset := Offset;
  3446.         Inc(Offset, uLen);
  3447.         uNullOffset := NumBytes - 2 * (I + 1);
  3448.       end;
  3449.       if ParamType in [ptInput, ptInputOutput] then
  3450.         SmallInt(Pointer(FRecordBuffer + NumBytes - 2 * (I + 1))^) := IndNull;
  3451.       Inc(Desc);
  3452.     end;
  3453.   end;
  3454.   AnsiToNative(Locale, StoredProcName, Buffer, DBIMAXSPNAMELEN);
  3455.   Check(DbiQPrepareProc(DBHandle, Buffer, FParams.Count,
  3456.     PSPParamDesc(FParamDesc), nil, FStmtHandle));
  3457. end;
  3458.  
  3459. procedure TStoredProc.GetResults;
  3460. var
  3461.   I: Integer;
  3462.   CurPtr: PChar;
  3463.   IntPtr: ^SmallInt;
  3464.   NumBytes: Word;
  3465. begin
  3466.   if FRecordBuffer <> nil then
  3467.   begin
  3468.     CurPtr := FRecordBuffer;
  3469.     NumBytes := StrBufSize(FRecordBuffer);
  3470.     for I := 0 to FParams.Count - 1 do
  3471.       with Params[I] do
  3472.       begin
  3473.         if ParamType in [ptOutput, ptInputOutput, ptResult] then
  3474.         begin
  3475.           if DataType = ftString then
  3476.             NativeToAnsiBuf(Locale, CurPtr, CurPtr, StrLen(CurPtr));
  3477.           IntPtr := Pointer(FRecordBuffer + NumBytes - 2 * (I + 1));
  3478.           if IntPtr^ = IndNull then Clear
  3479.           else if IntPtr^ = IndTrunc then DBErrorFmt(STruncationError, [Name])
  3480.           else SetData(CurPtr);
  3481.         end;
  3482.         if DataType = ftString then Inc(CurPtr, 255)
  3483.         else Inc(CurPtr, GetDataSize);
  3484.       end;
  3485.   end;
  3486. end;
  3487.  
  3488. procedure TStoredProc.BindParams;
  3489. var
  3490.   I: Integer;
  3491.   CurPtr: PChar;
  3492.   NumBytes: Word;
  3493.   IntPtr: ^SmallInt;
  3494.   DrvName: array[0..DBIMAXNAMELEN - 1] of Char;
  3495.   DrvLocale: TLocale;
  3496. begin
  3497.   if FRecordBuffer = nil then Exit;
  3498.   if not CheckServerParams then
  3499.   begin
  3500.     SetPrepared(False);
  3501.     SetPrepared(True);
  3502.   end;
  3503.   DrvName[0] := #0;
  3504.   DrvLocale := nil;
  3505.   DbiGetProp(HDBIOBJ(StmtHandle), stmtLANGDRVNAME, @DrvName, SizeOf(DrvName), NumBytes);
  3506.   if StrLen(DrvName) > 0 then OsLdLoadBySymbName(DrvName, DrvLocale);
  3507.   try
  3508.     NumBytes := StrBufSize(FRecordBuffer);
  3509.     CurPtr := FRecordBuffer;
  3510.     for I := 0 to FParams.Count - 1 do
  3511.     begin
  3512.       with Params[I] do
  3513.       begin
  3514.         if ParamType in [ptInput, ptInputOutput] then
  3515.         begin
  3516.           GetData(CurPtr);
  3517.           IntPtr := Pointer(FRecordBuffer + NumBytes - 2 * (I + 1));
  3518.           if IsNull then IntPtr^ := IndNull
  3519.           else IntPtr^ := 0;
  3520.         end;
  3521.         if DataType = ftString then
  3522.         begin
  3523.           if DrvLocale <> nil then
  3524.             AnsiToNativeBuf(DrvLocale, CurPtr, CurPtr, GetDataSize);
  3525.           Inc(CurPtr, 255);
  3526.         end
  3527.         else Inc(CurPtr, GetDataSize);
  3528.       end;
  3529.     end;
  3530.     Check(DbiQSetProcParams(StmtHandle, FParams.Count,
  3531.       PSPParamDesc(FParamDesc), FRecordBuffer));
  3532.   finally
  3533.     if DrvLocale <> nil then OsLdUnloadObj(DrvLocale);
  3534.   end;
  3535. end;
  3536.  
  3537. procedure TStoredProc.SetPrepared(Value: Boolean);
  3538. begin
  3539.   if Handle <> nil then DBError(SDataSetOpen);
  3540.   if Prepared <> Value then
  3541.   begin
  3542.     if Value then
  3543.       try
  3544.         if FParams.Count = 0 then CreateParamDesc
  3545.         else SetServerParams;
  3546.         if not FQueryMode then PrepareProc;
  3547.         FPrepared := True;
  3548.       except
  3549.         FreeStatement;
  3550.         raise;
  3551.       end
  3552.     else FreeStatement;
  3553.   end;
  3554. end;
  3555.  
  3556. procedure TStoredProc.Prepare;
  3557. begin
  3558.   SetDBFlag(dbfStoredProc, True);
  3559.   SetPrepared(True);
  3560. end;
  3561.  
  3562. procedure TStoredProc.UnPrepare;
  3563. begin
  3564.   SetPrepared(False);
  3565.   SetDBFlag(dbfStoredProc, False);
  3566. end;
  3567.  
  3568. procedure TStoredProc.FreeStatement;
  3569. begin
  3570.   if StmtHandle <> nil then DbiQFree(FStmtHandle);
  3571.   StrDispose(FParamDesc);
  3572.   FParamDesc := nil;
  3573.   StrDispose(FRecordBuffer);
  3574.   FRecordBuffer := nil;
  3575.   StrDispose(FServerDescs);
  3576.   FServerDescs := nil;
  3577.   FPrepared := False;
  3578. end;
  3579.  
  3580. procedure TStoredProc.SetPrepare(Value: Boolean);
  3581. begin
  3582.   if Value then Prepare
  3583.   else UnPrepare;
  3584. end;
  3585.  
  3586. procedure TStoredProc.SetDBFlag(Flag: Integer; Value: Boolean);
  3587. begin
  3588.   if not Value and (DBFlags - [Flag] = []) then SetPrepared(False);
  3589.   inherited SetDBFlag(Flag, Value);
  3590. end;
  3591.  
  3592. procedure TStoredProc.CopyParams(Value: TParams);
  3593. begin
  3594.   if not Prepared and (FParams.Count = 0) then
  3595.   try
  3596.     FQueryMode := True;
  3597.     Prepare;
  3598.     Value.Assign(FParams);
  3599.   finally
  3600.     UnPrepare;
  3601.     FQueryMode := False;
  3602.   end else
  3603.     Value.Assign(FParams);
  3604. end;
  3605.  
  3606. procedure TStoredProc.SetParamsList(Value: TParams);
  3607. begin
  3608.   CheckInactive;
  3609.   if Prepared then
  3610.   begin
  3611.     SetPrepared(False);
  3612.     FParams.Assign(Value);
  3613.     SetPrepared(True);
  3614.   end else
  3615.     FParams.Assign(Value);
  3616. end;
  3617.  
  3618. function TStoredProc.ParamByName(const Value: string): TParam;
  3619. begin
  3620.   Result := FParams.ParamByName(Value);
  3621. end;
  3622.  
  3623. { TQuery }
  3624.  
  3625. constructor TQuery.Create(AOwner: TComponent);
  3626. begin
  3627.   inherited Create(AOwner);
  3628.   FSQL := TStringList.Create;
  3629.   TStringList(SQL).OnChange := QueryChanged;
  3630.   FParams := TParams.Create;
  3631.   FDataLink := TQueryDataLink.Create(Self);
  3632.   RequestLive := False;
  3633.   ParamCheck := True;
  3634.   FRowsAffected := -1;
  3635. end;
  3636.  
  3637. destructor TQuery.Destroy;
  3638. begin
  3639.   Destroying;
  3640.   Disconnect;
  3641.   SQL.Free;
  3642.   FParams.Free;
  3643.   FDataLink.Free;
  3644.   StrDispose(SQLBinary);
  3645.   inherited Destroy;
  3646. end;
  3647.  
  3648. procedure TQuery.Disconnect;
  3649. begin
  3650.   Close;
  3651.   UnPrepare;
  3652. end;
  3653.  
  3654. procedure TQuery.SetPrepare(Value: Boolean);
  3655. begin
  3656.   if Value then Prepare
  3657.   else UnPrepare;
  3658. end;
  3659.  
  3660. procedure TQuery.Prepare;
  3661. begin
  3662.   SetDBFlag(dbfPrepared, True);
  3663.   SetPrepared(True);
  3664. end;
  3665.  
  3666. procedure TQuery.UnPrepare;
  3667. begin
  3668.   SetPrepared(False);
  3669.   SetDBFlag(dbfPrepared, False);
  3670. end;
  3671.  
  3672. procedure TQuery.SetDataSource(Value: TDataSource);
  3673. begin
  3674.   if IsLinkedTo(Value) then DBError(SCircularDataLink);
  3675.   FDataLink.DataSource := Value;
  3676. end;
  3677.  
  3678. function TQuery.GetDataSource: TDataSource;
  3679. begin
  3680.   Result := FDataLink.DataSource;
  3681. end;
  3682.  
  3683. procedure TQuery.SetQuery(Value: TStrings);
  3684. begin
  3685.   if SQL.Text <> Value.Text then
  3686.   begin
  3687.     Disconnect;
  3688.     SQL.BeginUpdate;
  3689.     try
  3690.       SQL.Assign(Value);
  3691.     finally
  3692.       SQL.EndUpdate;
  3693.     end;
  3694.   end;
  3695. end;
  3696.  
  3697. procedure TQuery.QueryChanged(Sender: TObject);
  3698. var
  3699.   List: TParams;
  3700. begin
  3701.   FText := SQL.Text;
  3702.   if not (csLoading in ComponentState) then
  3703.   begin
  3704.     Disconnect;
  3705.     StrDispose(SQLBinary);
  3706.     SQLBinary := nil;
  3707.     if ParamCheck or (csDesigning in ComponentState) then
  3708.     begin
  3709.       List := TParams.Create;
  3710.       try
  3711.         CreateParams(List, PChar(Text));
  3712.         List.AssignValues(FParams);
  3713.         FParams.Free;
  3714.         FParams := List;
  3715.       except
  3716.         List.Free;
  3717.       end;
  3718.     end;
  3719.     DataEvent(dePropertyChange, 0);
  3720.   end else
  3721.     CreateParams(nil, PChar(Text));
  3722. end;
  3723.  
  3724. procedure TQuery.SetParamsList(Value: TParams);
  3725. begin
  3726.   FParams.AssignValues(Value);
  3727. end;
  3728.  
  3729. function TQuery.GetParamsCount: Word;
  3730. begin
  3731.   Result := FParams.Count;
  3732. end;
  3733.  
  3734. procedure TQuery.DefineProperties(Filer: TFiler);
  3735. begin
  3736.   inherited DefineProperties(Filer);
  3737.   Filer.DefineBinaryProperty('Data', ReadBinaryData, WriteBinaryData, SQLBinary <> nil);
  3738. end;
  3739.  
  3740. procedure TQuery.ReadBinaryData(Stream: TStream);
  3741. begin
  3742.   SQLBinary := StrAlloc(Stream.Size);
  3743.   Stream.ReadBuffer(SQLBinary^, Stream.Size);
  3744. end;
  3745.  
  3746. procedure TQuery.WriteBinaryData(Stream: TStream);
  3747. begin
  3748.   Stream.WriteBuffer(SQLBinary^, StrBufSize(SQLBinary));
  3749. end;
  3750.  
  3751. procedure TQuery.SetPrepared(Value: Boolean);
  3752. begin
  3753.   if Handle <> nil then DBError(SDataSetOpen);
  3754.   if Value <> Prepared then
  3755.   begin
  3756.     if Value then
  3757.     begin
  3758.       FRowsAffected := -1;
  3759.       if Length(Text) > 1 then PrepareSQL(PChar(Text))
  3760.       else DBError(SEmptySQLStatement);
  3761.     end
  3762.     else
  3763.     begin
  3764.       FRowsAffected := RowsAffected;
  3765.       FreeStatement;
  3766.     end;
  3767.     FPrepared := Value;
  3768.   end;
  3769. end;
  3770.  
  3771. procedure TQuery.FreeStatement;
  3772. begin
  3773.   if StmtHandle <> nil then DbiQFree(FStmtHandle);
  3774. end;
  3775.  
  3776. procedure TQuery.SetParamsFromCursor;
  3777. var
  3778.   I: Integer;
  3779.   DataSet: TDataSet;
  3780. begin
  3781.   if FDataLink.DataSource <> nil then
  3782.   begin
  3783.     DataSet := FDataLink.DataSource.DataSet;
  3784.     if DataSet <> nil then
  3785.     begin
  3786.       DataSet.FieldDefs.Update;
  3787.       for I := 0 to FParams.Count - 1 do
  3788.         with FParams[I] do
  3789.           if not Bound then
  3790.           begin
  3791.             AssignField(DataSet.FieldByName(Name));
  3792.             Bound := False;
  3793.           end;
  3794.     end;
  3795.   end;
  3796. end;
  3797.  
  3798. procedure TQuery.RefreshParams;
  3799. var
  3800.   DataSet: TDataSet;
  3801. begin
  3802.   DisableControls;
  3803.   try
  3804.     if FDataLink.DataSource <> nil then
  3805.     begin
  3806.       DataSet := FDataLink.DataSource.DataSet;
  3807.       if DataSet <> nil then
  3808.         if DataSet.Active and (DataSet.State <> dsSetKey) then
  3809.         begin
  3810.           Close;
  3811.           Open;
  3812.         end;
  3813.     end;
  3814.   finally
  3815.     EnableControls;
  3816.   end;
  3817. end;
  3818.  
  3819. function TQuery.ParamByName(const Value: string): TParam;
  3820. begin
  3821.   Result := FParams.ParamByName(Value);
  3822. end;
  3823.  
  3824. procedure TQuery.CreateParams(List: TParams; const Value: PChar);
  3825. var
  3826.   CurPos, StartPos: PChar;
  3827.   CurChar: Char;
  3828.   Literal: Boolean;
  3829.   EmbeddedLiteral: Boolean;
  3830.   Name: string;
  3831.  
  3832.   function NameDelimiter: Boolean;
  3833.   begin
  3834.     Result := CurChar in [' ', ',', ';', ')', #13, #10];
  3835.   end;
  3836.  
  3837.   function IsLiteral: Boolean;
  3838.   begin
  3839.     Result := CurChar in ['''', '"'];
  3840.   end;
  3841.  
  3842.   function StripLiterals(Buffer: PChar): string;
  3843.   var
  3844.     Len: Word;
  3845.     TempBuf: PChar;
  3846.  
  3847.     procedure StripChar(Value: Char);
  3848.     begin
  3849.       if TempBuf^ = Value then
  3850.         StrMove(TempBuf, TempBuf + 1, Len - 1);
  3851.       if TempBuf[StrLen(TempBuf) - 1] = Value then
  3852.         TempBuf[StrLen(TempBuf) - 1] := #0;
  3853.     end;
  3854.  
  3855.   begin
  3856.     Len := StrLen(Buffer) + 1;
  3857.     TempBuf := AllocMem(Len);
  3858.     Result := '';
  3859.     try
  3860.       StrCopy(TempBuf, Buffer);
  3861.       StripChar('''');
  3862.       StripChar('"');
  3863.       Result := StrPas(TempBuf);
  3864.     finally
  3865.       FreeMem(TempBuf, Len);
  3866.     end;
  3867.   end;
  3868.  
  3869. begin
  3870.   CurPos := Value;
  3871.   Literal := False;
  3872.   EmbeddedLiteral := False;
  3873.   repeat
  3874.     CurChar := CurPos^;
  3875.     if (CurChar = ':') and not Literal and ((CurPos + 1)^ <> ':') then
  3876.     begin
  3877.       StartPos := CurPos;
  3878.       while (CurChar <> #0) and (Literal or not NameDelimiter) do
  3879.       begin
  3880.         Inc(CurPos);
  3881.         CurChar := CurPos^;
  3882.         if IsLiteral then
  3883.         begin
  3884.           Literal := Literal xor True;
  3885.           if CurPos = StartPos + 1 then EmbeddedLiteral := True;
  3886.         end;
  3887.       end;
  3888.       CurPos^ := #0;
  3889.       if EmbeddedLiteral then
  3890.       begin
  3891.         Name := StripLiterals(StartPos + 1);
  3892.         EmbeddedLiteral := False;
  3893.       end
  3894.       else Name := StrPas(StartPos + 1);
  3895.       if Assigned(List) then
  3896.         List.CreateParam(ftUnknown, Name, ptUnknown);
  3897.       CurPos^ := CurChar;
  3898.       StartPos^ := '?';
  3899.       Inc(StartPos);
  3900.       StrMove(StartPos, CurPos, StrLen(CurPos) + 1);
  3901.       CurPos := StartPos;
  3902.     end
  3903.     else if (CurChar = ':') and not Literal and ((CurPos + 1)^ = ':') then
  3904.       StrMove(CurPos, CurPos + 1, StrLen(CurPos) + 1)
  3905.     else if IsLiteral then Literal := Literal xor True;
  3906.     Inc(CurPos);
  3907.   until CurChar = #0;
  3908. end;
  3909.  
  3910. function TQuery.CreateCursor(GenHandle: Boolean): HDBICur;
  3911. begin
  3912.   if SQL.Count > 0 then
  3913.   begin
  3914.     SetPrepared(True);
  3915.     if FDataLink.DataSource <> nil then SetParamsFromCursor;
  3916.     Result := GetQueryCursor(GenHandle);
  3917.   end
  3918.   else DBError(SEmptySQLStatement);
  3919. end;
  3920.  
  3921. function TQuery.CreateHandle: HDBICur;
  3922. begin
  3923.   Result := CreateCursor(True)
  3924. end;
  3925.  
  3926. procedure TQuery.ExecSQL;
  3927. begin
  3928.   CheckInActive;
  3929.   SetDBFlag(dbfExecSQL, True);
  3930.   try
  3931.     CreateCursor(False);
  3932.   finally
  3933.     SetDBFlag(dbfExecSQL, False);
  3934.   end;
  3935. end;
  3936.  
  3937. function TQuery.GetQueryCursor(GenHandle: Boolean): HDBICur;
  3938. var
  3939.   PCursor: phDBICur;
  3940. begin
  3941.   Result := nil;
  3942.   if GenHandle then PCursor := @Result
  3943.   else PCursor := nil;
  3944.   if FParams.Count > 0 then SetParams;
  3945.   Check(DbiQExec(StmtHandle, PCursor));
  3946. end;
  3947.  
  3948. procedure TQuery.SetParams;
  3949. const
  3950.   TypeMap: array[TFieldType] of Byte = (
  3951.     fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
  3952.     fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
  3953.     fldVARBYTES, fldINT32, fldBLOB, fldBLOB, fldBLOB, fldBLOB, fldBLOB,
  3954.     fldBLOB, fldBLOB);
  3955. var
  3956.   DescBuffer: PFieldDescList;
  3957.   I: Integer;
  3958.   NumBytes: Word;
  3959.   Param: TParam;
  3960.   FieldDesc: PFLDDesc;
  3961.   RecBuffer: PChar;
  3962.   CurPtr, NullPtr: PChar;
  3963.   DrvName: array[0..DBIMAXNAMELEN - 1] of Char;
  3964.   DrvLocale: TLocale;
  3965. begin
  3966.   DescBuffer := AllocMem(FParams.Count * SizeOf(FLDDesc));
  3967.   FieldDesc := PFLDDesc(DescBuffer);
  3968.   NumBytes := 2;
  3969.   DrvName[0] := #0;
  3970.   DrvLocale := nil;
  3971.   DbiGetProp(HDBIOBJ(StmtHandle), stmtLANGDRVNAME, @DrvName, SizeOf(DrvName), NumBytes);
  3972.   if StrLen(DrvName) > 0 then OsLdLoadBySymbName(DrvName, DrvLocale);
  3973.   try
  3974.     for I := 0 to FParams.Count - 1 do
  3975.       Inc(NumBytes, Params[I].GetDataSize);
  3976.     RecBuffer := AllocMem(NumBytes);
  3977.     NullPtr := RecBuffer + NumBytes - 2;
  3978.     Smallint(Pointer(NullPtr)^) := -1;
  3979.     CurPtr := RecBuffer;
  3980.     try
  3981.       for I := 0 to FParams.Count - 1 do
  3982.       begin
  3983.         Param := Params[I];
  3984.         with FieldDesc^ do
  3985.         begin
  3986.           iFldType := TypeMap[Param.DataType];
  3987.           if iFldType = fldUNKNOWN then
  3988.             DBErrorFmt(SNoParameterValue, [Param.Name]);
  3989.           iFldNum := I + 1;
  3990.           iLen := Param.GetDataSize;
  3991.           if iFldType = fldZString then iUnits1 := iLen - 1;
  3992.           iOffset := CurPtr - RecBuffer;
  3993.           if Param.IsNull then iNullOffset := NullPtr - RecBuffer;
  3994.         end;
  3995.         with Param do
  3996.         begin
  3997.           GetData(CurPtr);
  3998.           if (FieldDesc^.iFldType = fldZString) and (DrvLocale <> nil) then
  3999.             AnsiToNativeBuf(DrvLocale, CurPtr, CurPtr, GetDataSize);
  4000.           Inc(CurPtr, GetDataSize);
  4001.           Inc(FieldDesc);
  4002.         end;
  4003.       end;
  4004.       Check(DbiQSetParams(StmtHandle, FParams.Count,
  4005.         PFLDDesc(DescBuffer), RecBuffer));
  4006.     finally
  4007.       FreeMem(RecBuffer, NumBytes);
  4008.     end;
  4009.   finally
  4010.     FreeMem(DescBuffer, FParams.Count * SizeOf(FLDDesc));
  4011.     if DrvLocale <> nil then OsLdUnloadObj(DrvLocale);
  4012.   end;
  4013. end;
  4014.  
  4015. procedure TQuery.SetDBFlag(Flag: Integer; Value: Boolean);
  4016. var
  4017.   NewConnection: Boolean;
  4018. begin
  4019.   if Value then
  4020.   begin
  4021.     NewConnection := DBFlags = [];
  4022.     inherited SetDBFlag(Flag, Value);
  4023.     if not (csReading in ComponentState) and NewConnection then
  4024.       FLocal := not Database.IsSQLBased;
  4025.   end
  4026.   else begin
  4027.     if DBFlags - [Flag] = [] then SetPrepared(False);
  4028.     inherited SetDBFlag(Flag, Value);
  4029.   end;
  4030. end;
  4031.  
  4032. procedure TQuery.PrepareSQL(Value: PChar);
  4033. begin
  4034.   GetStatementHandle(Value);
  4035.   if not Local then
  4036.     Check(DBiSetProp(hDbiObj(StmtHandle), stmtUNIDIRECTIONAL, LongInt(FUniDirectional)));
  4037. end;
  4038.  
  4039. procedure TQuery.GetStatementHandle(SQLText: PChar);
  4040. const
  4041.   DataType: array[Boolean] of LongInt = (Ord(wantCanned), Ord(wantLive));
  4042. begin
  4043.   Check(DbiQAlloc(DBHandle, qrylangSQL, FStmtHandle));
  4044.   try
  4045.     Check(DBiSetProp(hDbiObj(StmtHandle), stmtLIVENESS,
  4046.       DataType[RequestLive and not ForceUpdateCallback]));
  4047.     if Local then
  4048.     begin
  4049.       Check(DBiSetProp(hDbiObj(StmtHandle), stmtAUXTBLS, LongInt(False)));
  4050.       if RequestLive and Constrained then
  4051.         Check(DBiSetProp(hDbiObj(StmtHandle), stmtCONSTRAINED, LongInt(True)));
  4052.       Check(DbiSetProp(hDbiObj(StmtHandle), stmtCANNEDREADONLY, LongInt(True)));
  4053.     end;
  4054.     while not CheckOpen(DbiQPrepare(FStmtHandle, SQLText)) do
  4055.       {Retry};
  4056.   except
  4057.     DbiQFree(FStmtHandle);
  4058.     FStmtHandle := nil;
  4059.     raise;
  4060.   end;
  4061. end;
  4062.  
  4063. function TQuery.GetSQLText: PChar;
  4064. var
  4065.   BufLen: Word;
  4066.   I: Integer;
  4067.   StrEnd: PChar;
  4068.   StrBuf: array[0..255] of Char;
  4069. begin
  4070.   BufLen := 1;
  4071.   for I := 0 to SQL.Count - 1 do
  4072.     Inc(BufLen, Length(SQL.Strings[I]) + 1);
  4073.   Result := StrAlloc(BufLen);
  4074.   try
  4075.     StrEnd := Result;
  4076.     for I := 0 to SQL.Count - 1 do
  4077.     begin
  4078.       StrCopy(StrBuf, PChar(SQL.Strings[I]));
  4079.       StrEnd := StrECopy(StrEnd, StrBuf);
  4080.       StrEnd := StrECopy(StrEnd, ' ');
  4081.     end;
  4082.   except
  4083.     StrDispose(Result);
  4084.     raise;
  4085.   end;
  4086. end;
  4087.  
  4088. function TQuery.GetRowsAffected: Integer;
  4089. var
  4090.   Length: Word;
  4091. begin
  4092.   if Prepared then
  4093.     if DbiGetProp(hDBIObj(StmtHandle), stmtROWCOUNT, @Result, SizeOf(Result),
  4094.       Length) <> 0 then
  4095.       Result := -1
  4096.     else
  4097.   else Result := FRowsAffected;
  4098. end;
  4099.  
  4100. { TUpdateSQL }
  4101.  
  4102. constructor TUpdateSQL.Create(AOwner: TComponent);
  4103. var
  4104.   UpdateKind: TUpdateKind;
  4105. begin
  4106.   inherited Create(AOwner);
  4107.   for UpdateKind := Low(TUpdateKind) to High(TUpdateKind) do
  4108.     FSQLText[UpdateKind] := TStringList.Create;
  4109. end;
  4110.  
  4111. destructor TUpdateSQL.Destroy;
  4112. var
  4113.   UpdateKind: TUpdateKind;
  4114. begin
  4115.   if Assigned(FDataSet) and (FDataSet.UpdateObject = Self) then
  4116.     FDataSet.UpdateObject := nil;
  4117.   for UpdateKind := Low(TUpdateKind) to High(TUpdateKind) do
  4118.     FSQLText[UpdateKind].Free;
  4119.   inherited Destroy;
  4120. end;
  4121.  
  4122. procedure TUpdateSQL.ExecSQL(UpdateKind: TUpdateKind);
  4123. begin
  4124.   with Query[UpdateKind] do
  4125.   begin
  4126.     Prepare;
  4127.     ExecSQL;
  4128.     if RowsAffected <> 1 then DBError(SUpdateFailed);
  4129.   end;
  4130. end;
  4131.  
  4132. function TUpdateSQL.GetQuery(UpdateKind: TUpdateKind): TQuery;
  4133. begin
  4134.   if not Assigned(FQueries[UpdateKind]) then
  4135.   begin
  4136.     FQueries[UpdateKind] := TQuery.Create(Self);
  4137.     FQueries[UpdateKind].SQL.Assign(FSQLText[UpdateKind]);
  4138.     if (FDataSet is TDBDataSet) then
  4139.     begin
  4140.       FQueries[UpdateKind].SessionName := TDBDataSet(FDataSet).SessionName;
  4141.       FQueries[UpdateKind].DatabaseName := TDBDataSet(FDataSet).DataBaseName;
  4142.     end;
  4143.   end;
  4144.   Result := FQueries[UpdateKind];
  4145. end;
  4146.  
  4147. function TUpdateSQL.GetSQL(UpdateKind: TUpdateKind): TStrings;
  4148. begin
  4149.   Result := FSQLText[UpdateKind];
  4150. end;
  4151.  
  4152. function TUpdateSQL.GetSQLIndex(Index: Integer): TStrings;
  4153. begin
  4154.   Result := FSQLText[TUpdateKind(Index)];
  4155. end;
  4156.  
  4157. function TUpdateSQL.GetDataSet: TDataSet;
  4158. begin
  4159.   Result := FDataSet;
  4160. end;
  4161.  
  4162. procedure TUpdateSQL.SetDataSet(ADataSet: TDataSet);
  4163. begin
  4164.   FDataSet := ADataSet;
  4165. end;
  4166.  
  4167. procedure TUpdateSQL.SetSQL(UpdateKind: TUpdateKind; Value: TStrings);
  4168. begin
  4169.   FSQLText[UpdateKind].Assign(Value);
  4170.   if Assigned(FQueries[UpdateKind]) then
  4171.   begin
  4172.     FQueries[UpdateKind].Params.Clear;
  4173.     FQueries[UpdateKind].SQL.Assign(Value);
  4174.   end;
  4175. end;
  4176.  
  4177. procedure TUpdateSQL.SetSQLIndex(Index: Integer; Value: TStrings);
  4178. begin
  4179.   SetSQL(TUpdateKind(Index), Value);
  4180. end;
  4181.  
  4182. procedure TUpdateSQL.SetParams(UpdateKind: TUpdateKind);
  4183. var
  4184.   I: Integer;
  4185.   Old: Boolean;
  4186.   Param: TParam;
  4187.   PName: string;
  4188.   Field: TField;
  4189. begin
  4190.   if not Assigned(FDataSet) then Exit;
  4191.   with Query[UpdateKind] do
  4192.   begin
  4193.     if FSQLText[UpdateKind].Text <> Query[UpdateKind].SQL.Text then
  4194.       Query[UpdateKind].SQL.Assign(FSQLText[UpdateKind]);
  4195.     for I := 0 to Params.Count - 1 do
  4196.     begin
  4197.       Param := Params[I];
  4198.       PName := Param.Name;
  4199.       Old := CompareText(Copy(PName, 1, 4), 'OLD_') = 0;
  4200.       if Old then System.Delete(PName, 1, 4);
  4201.       Field := FDataSet.FindField(PName);
  4202.       if not Assigned(Field) then Continue;
  4203.       if Old then
  4204.         Param.AssignFieldValue(Field, Field.OldValue) else
  4205.         Param.AssignFieldValue(Field, Field.NewValue);
  4206.       Param.GetDataSize;
  4207.     end;
  4208.   end;
  4209. end;
  4210.  
  4211. procedure TUpdateSQL.Apply(UpdateKind: TUpdateKind);
  4212. begin
  4213.   SetParams(UpdateKind);
  4214.   ExecSQL(UpdateKind);
  4215. end;
  4216.  
  4217. { TStringField }
  4218.  
  4219. constructor TStringField.Create(AOwner: TComponent);
  4220. begin
  4221.   inherited Create(AOwner);
  4222.   SetDataType(ftString);
  4223.   Size := 20;
  4224.   Transliterate := True;
  4225. end;
  4226.  
  4227. function TStringField.GetAsBoolean: Boolean;
  4228. var
  4229.   S: string;
  4230. begin
  4231.   S := GetAsString;
  4232.   Result := (Length(S) > 0) and (S[1] in ['T', 't', 'Y', 'y']);
  4233. end;
  4234.  
  4235. function TStringField.GetAsDateTime: TDateTime;
  4236. begin
  4237.   Result := StrToDateTime(GetAsString);
  4238. end;
  4239.  
  4240. function TStringField.GetAsFloat: Double;
  4241. begin
  4242.   Result := StrToFloat(GetAsString);
  4243. end;
  4244.  
  4245. function TStringField.GetAsInteger: Longint;
  4246. begin
  4247.   Result := StrToInt(GetAsString);
  4248. end;
  4249.  
  4250. function TStringField.GetAsString: string;
  4251. begin
  4252.   if not GetValue(Result) then Result := '';
  4253. end;
  4254.  
  4255. function TStringField.GetAsVariant: Variant;
  4256. var
  4257.   S: string;
  4258. begin
  4259.   if GetValue(S) then Result := S else Result := Null;
  4260. end;
  4261.  
  4262. function TStringField.GetDefaultWidth: Integer;
  4263. begin
  4264.   Result := Size;
  4265. end;
  4266.  
  4267. procedure TStringField.GetText(var Text: string; DisplayText: Boolean);
  4268. begin
  4269.   if DisplayText and (EditMaskPtr <> '') then
  4270.     Text := FormatMaskText(EditMaskPtr, GetAsString) else
  4271.     Text := GetAsString;
  4272. end;
  4273.  
  4274. function TStringField.GetValue(var Value: string): Boolean;
  4275. var
  4276.   Buffer: array[0..dsMaxStringSize] of Char;
  4277. begin
  4278.   Result := GetData(@Buffer);
  4279.   if Result then
  4280.     if Transliterate then
  4281.       NativeToAnsi(DataSet.Locale, Buffer, Value) else
  4282.       Value := Buffer;
  4283. end;
  4284.  
  4285. procedure TStringField.SetAsBoolean(Value: Boolean);
  4286. const
  4287.   Values: array[Boolean] of string[1] = ('F', 'T');
  4288. begin
  4289.   SetAsString(Values[Value]);
  4290. end;
  4291.  
  4292. procedure TStringField.SetAsDateTime(Value: TDateTime);
  4293. begin
  4294.   SetAsString(DateTimeToStr(Value));
  4295. end;
  4296.  
  4297. procedure TStringField.SetAsFloat(Value: Double);
  4298. begin
  4299.   SetAsString(FloatToStr(Value));
  4300. end;
  4301.  
  4302. procedure TStringField.SetAsInteger(Value: Longint);
  4303. begin
  4304.   SetAsString(IntToStr(Value));
  4305. end;
  4306.  
  4307. procedure TStringField.SetAsString(const Value: string);
  4308. var
  4309.   Buffer: array[0..dsMaxStringSize] of Char;
  4310. begin
  4311.   if Transliterate then
  4312.     AnsiToNative(DataSet.Locale, Value, Buffer, Size) else
  4313.     StrLCopy(Buffer, PChar(Value), Size);
  4314.   SetData(@Buffer);
  4315. end;
  4316.  
  4317. procedure TStringField.SetVarValue(const Value: Variant);
  4318. begin
  4319.   SetAsString(Value);
  4320. end;
  4321.  
  4322. { TNumericField }
  4323.  
  4324. constructor TNumericField.Create(AOwner: TComponent);
  4325. begin
  4326.   inherited Create(AOwner);
  4327.   Alignment := taRightJustify;
  4328. end;
  4329.  
  4330. procedure TNumericField.RangeError(Value, Min, Max: Extended);
  4331. begin
  4332.   DBErrorFmt(SFieldRangeError, [Value, DisplayName, Min, Max]);
  4333. end;
  4334.  
  4335. procedure TNumericField.SetDisplayFormat(const Value: string);
  4336. begin
  4337.   if FDisplayFormat <> Value then
  4338.   begin
  4339.     FDisplayFormat := Value;
  4340.     PropertyChanged(False);
  4341.   end;
  4342. end;
  4343.  
  4344. procedure TNumericField.SetEditFormat(const Value: string);
  4345. begin
  4346.   if FEditFormat <> Value then
  4347.   begin
  4348.     FEditFormat := Value;
  4349.     PropertyChanged(False);
  4350.   end;
  4351. end;
  4352.  
  4353. { TIntegerField }
  4354.  
  4355. constructor TIntegerField.Create(AOwner: TComponent);
  4356. begin
  4357.   inherited Create(AOwner);
  4358.   SetDataType(ftInteger);
  4359.   FMinRange := Low(Longint);
  4360.   FMaxRange := High(Longint);
  4361. end;
  4362.  
  4363. procedure TIntegerField.CheckRange(Value, Min, Max: Longint);
  4364. begin
  4365.   if (Value < Min) or (Value > Max) then RangeError(Value, Min, Max);
  4366. end;
  4367.  
  4368. function TIntegerField.GetAsFloat: Double;
  4369. begin
  4370.   Result := GetAsInteger;
  4371. end;
  4372.  
  4373. function TIntegerField.GetAsInteger: Longint;
  4374. begin
  4375.   if not GetValue(Result) then Result := 0;
  4376. end;
  4377.  
  4378. function TIntegerField.GetAsString: string;
  4379. var
  4380.   L: Longint;
  4381. begin
  4382.   if GetValue(L) then Str(L, Result) else Result := '';
  4383. end;
  4384.  
  4385. function TIntegerField.GetAsVariant: Variant;
  4386. var
  4387.   L: Longint;
  4388. begin
  4389.   if GetValue(L) then Result := L else Result := Null;
  4390. end;
  4391.  
  4392. procedure TIntegerField.GetText(var Text: string; DisplayText: Boolean);
  4393. var
  4394.   L: Longint;
  4395.   FmtStr: string;
  4396. begin
  4397.   if GetValue(L) then
  4398.   begin
  4399.     if DisplayText or (FEditFormat = '') then
  4400.       FmtStr := FDisplayFormat else
  4401.       FmtStr := FEditFormat;
  4402.     if FmtStr = '' then Str(L, Text) else Text := FormatFloat(FmtStr, L);
  4403.   end else
  4404.     Text := '';
  4405. end;
  4406.  
  4407. function TIntegerField.GetValue(var Value: Longint): Boolean;
  4408. var
  4409.   Data: record
  4410.     case Integer of
  4411.       0: (I: Smallint);
  4412.       1: (W: Word);
  4413.       2: (L: Longint);
  4414.   end;
  4415. begin
  4416.   Result := GetData(@Data);
  4417.   if Result then
  4418.     case DataType of
  4419.       ftSmallint: Value := Data.I;
  4420.       ftWord: Value := Data.W;
  4421.     else
  4422.       Value := Data.L;
  4423.     end;
  4424. end;
  4425.  
  4426. function TIntegerField.IsValidChar(Ch: Char): Boolean;
  4427. begin
  4428.   Result := Ch in ['+', '-', '0'..'9'];
  4429. end;
  4430.  
  4431. procedure TIntegerField.SetAsFloat(Value: Double);
  4432. begin
  4433.   SetAsInteger(Round(Value));
  4434. end;
  4435.  
  4436. procedure TIntegerField.SetAsInteger(Value: Longint);
  4437. begin
  4438.   if (FMinValue <> 0) or (FMaxValue <> 0) then
  4439.     CheckRange(Value, FMinValue, FMaxValue) else
  4440.     CheckRange(Value, FMinRange, FMaxRange);
  4441.   SetData(@Value);
  4442. end;
  4443.  
  4444. procedure TIntegerField.SetAsString(const Value: string);
  4445. var
  4446.   E: Integer;
  4447.   L: Longint;
  4448. begin
  4449.   if Value = '' then Clear else
  4450.   begin
  4451.     Val(Value, L, E);
  4452.     if E <> 0 then DBErrorFmt(SInvalidIntegerValue, [Value, DisplayName]);
  4453.     SetAsInteger(L);
  4454.   end;
  4455. end;
  4456.  
  4457. procedure TIntegerField.SetMaxValue(Value: Longint);
  4458. begin
  4459.   CheckRange(Value, FMinRange, FMaxRange);
  4460.   FMaxValue := Value;
  4461. end;
  4462.  
  4463. procedure TIntegerField.SetMinValue(Value: Longint);
  4464. begin
  4465.   CheckRange(Value, FMinRange, FMaxRange);
  4466.   FMinValue := Value;
  4467. end;
  4468.  
  4469. procedure TIntegerField.SetVarValue(const Value: Variant);
  4470. begin
  4471.   SetAsInteger(Value);
  4472. end;
  4473.  
  4474. { TSmallintField }
  4475.  
  4476. constructor TSmallintField.Create(AOwner: TComponent);
  4477. begin
  4478.   inherited Create(AOwner);
  4479.   SetDataType(ftSmallint);
  4480.   FMinRange := Low(Smallint);
  4481.   FMaxRange := High(Smallint);
  4482. end;
  4483.  
  4484. { TWordField }
  4485.  
  4486. constructor TWordField.Create(AOwner: TComponent);
  4487. begin
  4488.   inherited Create(AOwner);
  4489.   SetDataType(ftWord);
  4490.   FMinRange := Low(Word);
  4491.   FMaxRange := High(Word);
  4492. end;
  4493.  
  4494. { TAutoIncField }
  4495.  
  4496. constructor TAutoIncField.Create(AOwner: TComponent);
  4497. begin
  4498.   inherited Create(AOwner);
  4499.   SetDataType(ftAutoInc);
  4500. end;
  4501.  
  4502. { TFloatField }
  4503.  
  4504. constructor TFloatField.Create(AOwner: TComponent);
  4505. begin
  4506.   inherited Create(AOwner);
  4507.   SetDataType(ftFloat);
  4508.   FPrecision := 15;
  4509. end;
  4510.  
  4511. function TFloatField.GetAsFloat: Double;
  4512. begin
  4513.   if not GetData(@Result) then Result := 0;
  4514. end;
  4515.  
  4516. function TFloatField.GetAsInteger: Longint;
  4517. begin
  4518.   Result := Round(GetAsFloat);
  4519. end;
  4520.  
  4521. function TFloatField.GetAsString: string;
  4522. var
  4523.   F: Double;
  4524. begin
  4525.   if GetData(@F) then Result := FloatToStr(F) else Result := '';
  4526. end;
  4527.  
  4528. function TFloatField.GetAsVariant: Variant;
  4529. var
  4530.   F: Double;
  4531. begin
  4532.   if GetData(@F) then Result := F else Result := Null;
  4533. end;
  4534.  
  4535. procedure TFloatField.GetText(var Text: string; DisplayText: Boolean);
  4536. var
  4537.   Format: TFloatFormat;
  4538.   Digits: Integer;
  4539.   FmtStr: string;
  4540.   F: Double;
  4541. begin
  4542.   if GetData(@F) then
  4543.   begin
  4544.     if DisplayText or (FEditFormat = '') then
  4545.       FmtStr := FDisplayFormat else
  4546.       FmtStr := FEditFormat;
  4547.     if FmtStr = '' then
  4548.     begin
  4549.       if FCurrency then
  4550.       begin
  4551.         if DisplayText then Format := ffCurrency else Format := ffFixed;
  4552.         Digits := CurrencyDecimals;
  4553.       end
  4554.       else begin
  4555.         Format := ffGeneral;
  4556.         Digits := 0;
  4557.       end;
  4558.       Text := FloatToStrF(F, Format, FPrecision, Digits);
  4559.     end else
  4560.       Text := FormatFloat(FmtStr, F);
  4561.   end else
  4562.     Text := '';
  4563. end;
  4564.  
  4565. function TFloatField.IsValidChar(Ch: Char): Boolean;
  4566. begin
  4567.   Result := Ch in [DecimalSeparator, '+', '-', '0'..'9', 'E', 'e'];
  4568. end;
  4569.  
  4570. procedure TFloatField.SetAsFloat(Value: Double);
  4571. begin
  4572.   if FCheckRange and ((Value < FMinValue) or (Value > FMaxValue)) then
  4573.     RangeError(Value, FMinValue, FMaxValue);
  4574.   SetData(@Value);
  4575. end;
  4576.  
  4577. procedure TFloatField.SetAsInteger(Value: Longint);
  4578. begin
  4579.   SetAsFloat(Value);
  4580. end;
  4581.  
  4582. procedure TFloatField.SetAsString(const Value: string);
  4583. var
  4584.   F: Extended;
  4585. begin
  4586.   if Value = '' then Clear else
  4587.   begin
  4588.     if not TextToFloat(PChar(Value), F, fvExtended) then
  4589.       DBErrorFmt(SInvalidFloatValue, [Value, DisplayName]);
  4590.     SetAsFloat(F);
  4591.   end;
  4592. end;
  4593.  
  4594. procedure TFloatField.SetCurrency(Value: Boolean);
  4595. begin
  4596.   if FCurrency <> Value then
  4597.   begin
  4598.     FCurrency := Value;
  4599.     PropertyChanged(False);
  4600.   end;
  4601. end;
  4602.  
  4603. procedure TFloatField.SetMaxValue(Value: Double);
  4604. begin
  4605.   FMaxValue := Value;
  4606.   UpdateCheckRange;
  4607. end;
  4608.  
  4609. procedure TFloatField.SetMinValue(Value: Double);
  4610. begin
  4611.   FMinValue := Value;
  4612.   UpdateCheckRange;
  4613. end;
  4614.  
  4615. procedure TFloatField.SetPrecision(Value: Integer);
  4616. begin
  4617.   if Value < 2 then Value := 2;
  4618.   if Value > 15 then Value := 15;
  4619.   if FPrecision <> Value then
  4620.   begin
  4621.     FPrecision := Value;
  4622.     PropertyChanged(False);
  4623.   end;
  4624. end;
  4625.  
  4626. procedure TFloatField.SetVarValue(const Value: Variant);
  4627. begin
  4628.   SetAsFloat(Value);
  4629. end;
  4630.  
  4631. procedure TFloatField.UpdateCheckRange;
  4632. begin
  4633.   FCheckRange := (FMinValue <> 0) or (FMaxValue <> 0);
  4634. end;
  4635.  
  4636. { TCurrencyField }
  4637.  
  4638. constructor TCurrencyField.Create(AOwner: TComponent);
  4639. begin
  4640.   inherited Create(AOwner);
  4641.   SetDataType(ftCurrency);
  4642.   FCurrency := True;
  4643. end;
  4644.  
  4645. { TBCDField }
  4646.  
  4647. constructor TBCDField.Create(AOwner: TComponent);
  4648. begin
  4649.   inherited Create(AOwner);
  4650.   SetDataType(ftBCD);
  4651.   Size := 4;
  4652. end;
  4653.  
  4654. function TBCDField.GetAsCurrency: Currency;
  4655. begin
  4656.   if not GetValue(Result) then Result := 0;
  4657. end;
  4658.  
  4659. function TBCDField.GetAsFloat: Double;
  4660. begin
  4661.   Result := GetAsCurrency;
  4662. end;
  4663.  
  4664. function TBCDField.GetAsInteger: Longint;
  4665. begin
  4666.   Result := Round(GetAsCurrency);
  4667. end;
  4668.  
  4669. function TBCDField.GetAsString: string;
  4670. var
  4671.   C: System.Currency;
  4672. begin
  4673.   if GetValue(C) then Result := CurrToStr(C) else Result := '';
  4674. end;
  4675.  
  4676. function TBCDField.GetAsVariant: Variant;
  4677. var
  4678.   C: System.Currency;
  4679. begin
  4680.   if GetValue(C) then Result := C else Result := Null;
  4681. end;
  4682.  
  4683. procedure TBCDField.GetText(var Text: string; DisplayText: Boolean);
  4684. var
  4685.   Format: TFloatFormat;
  4686.   Digits: Integer;
  4687.   FmtStr: string;
  4688.   BCD: FMTBcd;
  4689.   C: System.Currency;
  4690. begin
  4691.   if GetData(@BCD) then
  4692.     if BCDToCurr(BCD, C) then
  4693.     begin
  4694.       if DisplayText or (FEditFormat = '') then
  4695.         FmtStr := FDisplayFormat else
  4696.         FmtStr := FEditFormat;
  4697.       if FmtStr = '' then
  4698.       begin
  4699.         if FCurrency then
  4700.         begin
  4701.           if DisplayText then Format := ffCurrency else Format := ffFixed;
  4702.           Digits := CurrencyDecimals;
  4703.         end
  4704.         else begin
  4705.           Format := ffGeneral;
  4706.           Digits := 0;
  4707.         end;
  4708.         Text := CurrToStrF(C, Format, Digits);
  4709.       end else
  4710.         Text := FormatCurr(FmtStr, C);
  4711.     end else
  4712.       Text := LoadStr(SBCDOverflow)
  4713.   else
  4714.     Text := '';
  4715. end;
  4716.  
  4717. function TBCDField.GetValue(var Value: Currency): Boolean;
  4718. var
  4719.   BCD: FMTBcd;
  4720. begin
  4721.   Result := GetData(@BCD);
  4722.   if Result then
  4723.     if not BCDToCurr(BCD, Value) then
  4724.       DBErrorFmt(SFieldOutOfRange, [DisplayName]);
  4725. end;
  4726.  
  4727. function TBCDField.IsValidChar(Ch: Char): Boolean;
  4728. begin
  4729.   Result := Ch in [DecimalSeparator, '+', '-', '0'..'9'];
  4730. end;
  4731.  
  4732. procedure TBCDField.SetAsCurrency(Value: Currency);
  4733. var
  4734.   BCD: FMTBcd;
  4735. begin
  4736.   if FCheckRange and ((Value < FMinValue) or (Value > FMaxValue)) then
  4737.     RangeError(Value, FMinValue, FMaxValue);
  4738.   CurrToBCD(Value, BCD, 32, Size);
  4739.   SetData(@BCD);
  4740. end;
  4741.  
  4742. procedure TBCDField.SetAsFloat(Value: Double);
  4743. begin
  4744.   SetAsCurrency(Value);
  4745. end;
  4746.  
  4747. procedure TBCDField.SetAsInteger(Value: Longint);
  4748. begin
  4749.   SetAsCurrency(Value);
  4750. end;
  4751.  
  4752. procedure TBCDField.SetAsString(const Value: string);
  4753. var
  4754.   C: System.Currency;
  4755. begin
  4756.   if Value = '' then Clear else
  4757.   begin
  4758.     if not TextToFloat(PChar(Value), C, fvCurrency) then
  4759.       DBErrorFmt(SInvalidFloatValue, [Value, DisplayName]);
  4760.     SetAsCurrency(C);
  4761.   end;
  4762. end;
  4763.  
  4764. procedure TBCDField.SetCurrency(Value: Boolean);
  4765. begin
  4766.   if FCurrency <> Value then
  4767.   begin
  4768.     FCurrency := Value;
  4769.     PropertyChanged(False);
  4770.   end;
  4771. end;
  4772.  
  4773. procedure TBCDField.SetMaxValue(Value: Currency);
  4774. begin
  4775.   FMaxValue := Value;
  4776.   UpdateCheckRange;
  4777. end;
  4778.  
  4779. procedure TBCDField.SetMinValue(Value: Currency);
  4780. begin
  4781.   FMinValue := Value;
  4782.   UpdateCheckRange;
  4783. end;
  4784.  
  4785. procedure TBCDField.SetVarValue(const Value: Variant);
  4786. begin
  4787.   SetAsCurrency(Value);
  4788. end;
  4789.  
  4790. procedure TBCDField.UpdateCheckRange;
  4791. begin
  4792.   FCheckRange := (FMinValue <> 0) or (FMaxValue <> 0);
  4793. end;
  4794.  
  4795. { TBooleanField }
  4796.  
  4797. constructor TBooleanField.Create(AOwner: TComponent);
  4798. begin
  4799.   inherited Create(AOwner);
  4800.   SetDataType(ftBoolean);
  4801.   LoadTextValues;
  4802. end;
  4803.  
  4804. function TBooleanField.GetAsBoolean: Boolean;
  4805. var
  4806.   B: WordBool;
  4807. begin
  4808.   if GetData(@B) then Result := B else Result := False;
  4809. end;
  4810.  
  4811. function TBooleanField.GetAsString: string;
  4812. var
  4813.   B: WordBool;
  4814. begin
  4815.   if GetData(@B) then Result := FTextValues[B] else Result := '';
  4816. end;
  4817.  
  4818. function TBooleanField.GetAsVariant: Variant;
  4819. var
  4820.   B: WordBool;
  4821. begin
  4822.   if GetData(@B) then Result := B else Result := Null;
  4823. end;
  4824.  
  4825. function TBooleanField.GetDefaultWidth: Integer;
  4826. begin
  4827.   if Length(FTextValues[False]) > Length(FTextValues[True]) then
  4828.     Result := Length(FTextValues[False]) else
  4829.     Result := Length(FTextValues[True]);
  4830. end;
  4831.  
  4832. procedure TBooleanField.LoadTextValues;
  4833. begin
  4834.   FTextValues[False] := LoadStr(STextFalse);
  4835.   FTextValues[True] := LoadStr(STextTrue);
  4836. end;
  4837.  
  4838. procedure TBooleanField.SetAsBoolean(Value: Boolean);
  4839. var
  4840.   B: WordBool;
  4841. begin
  4842.   B := Value;
  4843.   SetData(@B);
  4844. end;
  4845.  
  4846. procedure TBooleanField.SetAsString(const Value: string);
  4847. var
  4848.   L: Integer;
  4849. begin
  4850.   L := Length(Value);
  4851.   if L = 0 then
  4852.   begin
  4853.     if Length(FTextValues[False]) = 0 then SetAsBoolean(False) else
  4854.       if Length(FTextValues[True]) = 0 then SetAsBoolean(True) else
  4855.         Clear;
  4856.   end else
  4857.   begin
  4858.     if AnsiCompareText(Value, Copy(FTextValues[False], 1, L)) = 0 then
  4859.       SetAsBoolean(False)
  4860.     else
  4861.       if AnsiCompareText(Value, Copy(FTextValues[True], 1, L)) = 0 then
  4862.         SetAsBoolean(True)
  4863.       else
  4864.         DBErrorFmt(SInvalidBoolValue, [Value, DisplayName]);
  4865.   end;
  4866. end;
  4867.  
  4868. procedure TBooleanField.SetDisplayValues(const Value: string);
  4869. var
  4870.   P: Integer;
  4871. begin
  4872.   if FDisplayValues <> Value then
  4873.   begin
  4874.     FDisplayValues := Value;
  4875.     if Value = '' then LoadTextValues else
  4876.     begin
  4877.       P := Pos(';', Value);
  4878.       if P = 0 then P := 256;
  4879.       FTextValues[False] := Copy(Value, P + 1, 255);
  4880.       FTextValues[True] := Copy(Value, 1, P - 1);
  4881.     end;
  4882.     PropertyChanged(True);
  4883.   end;
  4884. end;
  4885.  
  4886. procedure TBooleanField.SetVarValue(const Value: Variant);
  4887. begin
  4888.   SetAsBoolean(Value);
  4889. end;
  4890.  
  4891. { TDateTimeField }
  4892.  
  4893. constructor TDateTimeField.Create(AOwner: TComponent);
  4894. begin
  4895.   inherited Create(AOwner);
  4896.   SetDataType(ftDateTime);
  4897. end;
  4898.  
  4899. function TDateTimeField.GetAsDateTime: TDateTime;
  4900. begin
  4901.   if not GetValue(Result) then Result := 0;
  4902. end;
  4903.  
  4904. function TDateTimeField.GetAsFloat: Double;
  4905. begin
  4906.   Result := GetAsDateTime;
  4907. end;
  4908.  
  4909. function TDateTimeField.GetAsString: string;
  4910. begin
  4911.   GetText(Result, False);
  4912. end;
  4913.  
  4914. function TDateTimeField.GetAsVariant: Variant;
  4915. var
  4916.   D: TDateTime;
  4917. begin
  4918.   if GetValue(D) then Result := VarFromDateTime(D) else Result := Null;
  4919. end;
  4920.  
  4921. procedure TDateTimeField.GetText(var Text: string; DisplayText: Boolean);
  4922. var
  4923.   F: string;
  4924.   D: TDateTime;
  4925. begin
  4926.   if GetValue(D) then
  4927.   begin
  4928.     if DisplayText and (FDisplayFormat <> '') then
  4929.       F := FDisplayFormat
  4930.     else
  4931.       case DataType of
  4932.         ftDate: F := ShortDateFormat;
  4933.         ftTime: F := LongTimeFormat;
  4934.       end;
  4935.     DateTimeToString(Text, F, D);
  4936.   end else
  4937.     Text := '';
  4938. end;
  4939.  
  4940. function TDateTimeField.GetValue(var Value: TDateTime): Boolean;
  4941. var
  4942.   TimeStamp: TTimeStamp;
  4943.   Data: TDateTimeRec;
  4944. begin
  4945.   Result := GetData(@Data);
  4946.   if Result then
  4947.   begin
  4948.     case DataType of
  4949.       ftDate:
  4950.         begin
  4951.           TimeStamp.Time := 0;
  4952.           TimeStamp.Date := Data.Date;
  4953.         end;
  4954.       ftTime:
  4955.         begin
  4956.           TimeStamp.Time := Data.Time;
  4957.           TimeStamp.Date := DateDelta;
  4958.         end;
  4959.     else
  4960.       try
  4961.         TimeStamp := MSecsToTimeStamp(Data.DateTime);
  4962.       except
  4963.         TimeStamp.Time := 0;
  4964.         TimeStamp.Date := 0;
  4965.       end;
  4966.     end;
  4967.     Value := TimeStampToDateTime(TimeStamp);
  4968.   end;
  4969. end;
  4970.  
  4971. procedure TDateTimeField.SetAsDateTime(Value: TDateTime);
  4972. var
  4973.   TimeStamp: TTimeStamp;
  4974.   Data: TDateTimeRec;
  4975. begin
  4976.   TimeStamp := DateTimeToTimeStamp(Value);
  4977.   case DataType of
  4978.     ftDate: Data.Date := TimeStamp.Date;
  4979.     ftTime: Data.Time := TimeStamp.Time;
  4980.   else
  4981.     Data.DateTime := TimeStampToMSecs(TimeStamp);
  4982.   end;
  4983.   SetData(@Data);
  4984. end;
  4985.  
  4986. procedure TDateTimeField.SetAsFloat(Value: Double);
  4987. begin
  4988.   SetAsDateTime(Value);
  4989. end;
  4990.  
  4991. procedure TDateTimeField.SetAsString(const Value: string);
  4992. var
  4993.   DateTime: TDateTime;
  4994. begin
  4995.   if Value = '' then Clear else
  4996.   begin
  4997.     case DataType of
  4998.       ftDate: DateTime := StrToDate(Value);
  4999.       ftTime: DateTime := StrToTime(Value);
  5000.     else
  5001.       DateTime := StrToDateTime(Value);
  5002.     end;
  5003.     SetAsDateTime(DateTime);
  5004.   end;
  5005. end;
  5006.  
  5007. procedure TDateTimeField.SetDisplayFormat(const Value: string);
  5008. begin
  5009.   if FDisplayFormat <> Value then
  5010.   begin
  5011.     FDisplayFormat := Value;
  5012.     PropertyChanged(False);
  5013.   end;
  5014. end;
  5015.  
  5016. procedure TDateTimeField.SetVarValue(const Value: Variant);
  5017. begin
  5018.   SetAsDateTime(VarToDateTime(Value));
  5019. end;
  5020.  
  5021. { TDateField }
  5022.  
  5023. constructor TDateField.Create(AOwner: TComponent);
  5024. begin
  5025.   inherited Create(AOwner);
  5026.   SetDataType(ftDate);
  5027. end;
  5028.  
  5029. { TTimeField }
  5030.  
  5031. constructor TTimeField.Create(AOwner: TComponent);
  5032. begin
  5033.   inherited Create(AOwner);
  5034.   SetDataType(ftTime);
  5035. end;
  5036.  
  5037. { TBinaryField }
  5038.  
  5039. constructor TBinaryField.Create(AOwner: TComponent);
  5040. begin
  5041.   inherited Create(AOwner);
  5042. end;
  5043.  
  5044. function TBinaryField.GetAsVariant: Variant;
  5045. var
  5046.   Data: Pointer;
  5047. begin
  5048.   Result := VarArrayCreate([0, DataSize - 1], varByte);
  5049.   Data := VarArrayLock(Result);
  5050.   try
  5051.     GetData(Data);
  5052.   finally
  5053.     VarArrayUnlock(Result);
  5054.   end;
  5055. end;
  5056.  
  5057. procedure TBinaryField.SetVarValue(const Value: Variant);
  5058. var
  5059.   Data: Pointer;
  5060. begin
  5061.   if not (VarIsArray(Value) and (VarArrayDimCount(Value) = 1) and
  5062.     ((VarType(Value) and VarTypeMask) = varByte) and
  5063.     ((VarArrayHighBound(Value, 1) - VarArrayLowBound(Value, 1) + 1) = DataSize)) then
  5064.     DBError(SInvalidVarByteArray);
  5065.   Data := VarArrayLock(Value);
  5066.   try
  5067.     SetData(Data);
  5068.   finally
  5069.     VarArrayUnlock(Value);
  5070.   end;
  5071. end;
  5072.  
  5073. { TBytesField }
  5074.  
  5075. constructor TBytesField.Create(AOwner: TComponent);
  5076. begin
  5077.   inherited Create(AOwner);
  5078.   SetDataType(ftBytes);
  5079.   Size := 16;
  5080. end;
  5081.  
  5082. { TVarBytesField }
  5083.  
  5084. constructor TVarBytesField.Create(AOwner: TComponent);
  5085. begin
  5086.   inherited Create(AOwner);
  5087.   SetDataType(ftVarBytes);
  5088.   Size := 16;
  5089. end;
  5090.  
  5091. { TBlobField }
  5092.  
  5093. constructor TBlobField.Create(AOwner: TComponent);
  5094. begin
  5095.   inherited Create(AOwner);
  5096.   SetDataType(ftBlob);
  5097. end;
  5098.  
  5099. procedure TBlobField.Assign(Source: TPersistent);
  5100. begin
  5101.   if Source is TBlobField then
  5102.   begin
  5103.     LoadFromBlob(TBlobField(Source));
  5104.     Exit;
  5105.   end;
  5106.   if Source is TStrings then
  5107.   begin
  5108.     LoadFromStrings(TStrings(Source));
  5109.     Exit;
  5110.   end;
  5111.   if Source is TBitmap then
  5112.   begin
  5113.     LoadFromBitmap(TBitmap(Source));
  5114.     Exit;
  5115.   end;
  5116.   if (Source is TPicture) and (TPicture(Source).Graphic is TBitmap) then
  5117.   begin
  5118.     LoadFromBitmap(TBitmap(TPicture(Source).Graphic));
  5119.     Exit;
  5120.   end;
  5121.   inherited Assign(Source);
  5122. end;
  5123.  
  5124. procedure TBlobField.AssignTo(Dest: TPersistent);
  5125. begin
  5126.   if Dest is TStrings then
  5127.   begin
  5128.     SaveToStrings(TStrings(Dest));
  5129.     Exit;
  5130.   end;
  5131.   if Dest is TBitmap then
  5132.   begin
  5133.     SaveToBitmap(TBitmap(Dest));
  5134.     Exit;
  5135.   end;
  5136.   if Dest is TPicture then
  5137.   begin
  5138.     SaveToBitmap(TPicture(Dest).Bitmap);
  5139.     Exit;
  5140.   end;
  5141.   inherited AssignTo(Dest);
  5142. end;
  5143.  
  5144. procedure TBlobField.Clear;
  5145. begin
  5146.   TBlobStream.Create(Self, bmWrite).Free;
  5147. end;
  5148.  
  5149. procedure TBlobField.FreeBuffers;
  5150. begin
  5151.   if FModified then
  5152.   begin
  5153.     DbiFreeBlob(DataSet.Handle, DataSet.ActiveBuffer, FieldNo);
  5154.     FModified := False;
  5155.   end;
  5156. end;
  5157.  
  5158. function TBlobField.GetAsString: string;
  5159. var
  5160.   Len: Integer;
  5161. begin
  5162.   with TBlobStream.Create(Self, bmRead) do
  5163.     try
  5164.       Len := Size;
  5165.       SetString(Result, nil, Len);
  5166.       ReadBuffer(Pointer(Result)^, Len);
  5167.     finally
  5168.       Free;
  5169.     end;
  5170. end;
  5171.  
  5172. function TBlobField.GetAsVariant: Variant;
  5173. begin
  5174.   Result := GetAsString;
  5175. end;
  5176.  
  5177. function TBlobField.GetBlobType: TBlobType;
  5178. begin
  5179.   Result := TBlobType(DataType);
  5180. end;
  5181.  
  5182. procedure TBlobField.GetText(var Text: string; DisplayText: Boolean);
  5183. begin
  5184.   Text := inherited GetAsString;
  5185. end;
  5186.  
  5187. procedure TBlobField.LoadFromBitmap(Bitmap: TBitmap);
  5188. var
  5189.   BlobStream: TBlobStream;
  5190.   Header: TGraphicHeader;
  5191. begin
  5192.   BlobStream := TBlobStream.Create(Self, bmWrite);
  5193.   try
  5194.     if (DataType = ftGraphic) or (DataType = ftTypedBinary) then
  5195.     begin
  5196.       Header.Count := 1;
  5197.       Header.HType := $0100;
  5198.       Header.Size := 0;
  5199.       BlobStream.Write(Header, SizeOf(Header));
  5200.       Bitmap.SaveToStream(BlobStream);
  5201.       Header.Size := BlobStream.Position - SizeOf(Header);
  5202.       BlobStream.Position := 0;
  5203.       BlobStream.Write(Header, SizeOf(Header));
  5204.     end else
  5205.       Bitmap.SaveToStream(BlobStream);
  5206.   finally
  5207.     BlobStream.Free;
  5208.   end;
  5209. end;
  5210.  
  5211. procedure TBlobField.LoadFromBlob(Blob: TBlobField);
  5212. var
  5213.   BlobStream: TBlobStream;
  5214. begin
  5215.   BlobStream := TBlobStream.Create(Self, bmWrite);
  5216.   try
  5217.     Blob.SaveToStream(BlobStream);
  5218.   finally
  5219.     BlobStream.Free;
  5220.   end;
  5221. end;
  5222.  
  5223. procedure TBlobField.LoadFromFile(const FileName: string);
  5224. var
  5225.   Stream: TStream;
  5226. begin
  5227.   Stream := TFileStream.Create(FileName, fmOpenRead);
  5228.   try
  5229.     LoadFromStream(Stream);
  5230.   finally
  5231.     Stream.Free;
  5232.   end;
  5233. end;
  5234.  
  5235. procedure TBlobField.LoadFromStream(Stream: TStream);
  5236. var
  5237.   BlobStream: TBlobStream;
  5238. begin
  5239.   BlobStream := TBlobStream.Create(Self, bmWrite);
  5240.   try
  5241.     BlobStream.CopyFrom(Stream, 0);
  5242.   finally
  5243.     BlobStream.Free;
  5244.   end;
  5245. end;
  5246.  
  5247. procedure TBlobField.LoadFromStrings(Strings: TStrings);
  5248. var
  5249.   BlobStream: TBlobStream;
  5250. begin
  5251.   BlobStream := TBlobStream.Create(Self, bmWrite);
  5252.   try
  5253.     Strings.SaveToStream(BlobStream);
  5254.   finally
  5255.     BlobStream.Free;
  5256.   end;
  5257. end;
  5258.  
  5259. procedure TBlobField.SaveToBitmap(Bitmap: TBitmap);
  5260. var
  5261.   BlobStream: TBlobStream;
  5262.   Size: Longint;
  5263.   Header: TGraphicHeader;
  5264. begin
  5265.   BlobStream := TBlobStream.Create(Self, bmRead);
  5266.   try
  5267.     Size := BlobStream.Size;
  5268.     if Size >= SizeOf(TGraphicHeader) then
  5269.     begin
  5270.       BlobStream.Read(Header, SizeOf(Header));
  5271.       if (Header.Count <> 1) or (Header.HType <> $0100) or
  5272.         (Header.Size <> Size - SizeOf(Header)) then
  5273.         BlobStream.Position := 0;
  5274.     end;
  5275.     Bitmap.LoadFromStream(BlobStream);
  5276.   finally
  5277.     BlobStream.Free;
  5278.   end;
  5279. end;
  5280.  
  5281. procedure TBlobField.SaveToFile(const FileName: string);
  5282. var
  5283.   Stream: TStream;
  5284. begin
  5285.   Stream := TFileStream.Create(FileName, fmCreate);
  5286.   try
  5287.     SaveToStream(Stream);
  5288.   finally
  5289.     Stream.Free;
  5290.   end;
  5291. end;
  5292.  
  5293. procedure TBlobField.SaveToStream(Stream: TStream);
  5294. var
  5295.   BlobStream: TBlobStream;
  5296. begin
  5297.   BlobStream := TBlobStream.Create(Self, bmRead);
  5298.   try
  5299.     Stream.CopyFrom(BlobStream, 0);
  5300.   finally
  5301.     BlobStream.Free;
  5302.   end;
  5303. end;
  5304.  
  5305. procedure TBlobField.SaveToStrings(Strings: TStrings);
  5306. var
  5307.   BlobStream: TBlobStream;
  5308. begin
  5309.   BlobStream := TBlobStream.Create(Self, bmRead);
  5310.   try
  5311.     Strings.LoadFromStream(BlobStream);
  5312.   finally
  5313.     BlobStream.Free;
  5314.   end;
  5315. end;
  5316.  
  5317. procedure TBlobField.SetAsString(const Value: string);
  5318. begin
  5319.   with TBlobStream.Create(Self, bmWrite) do
  5320.     try
  5321.       WriteBuffer(Pointer(Value)^, Length(Value));
  5322.     finally
  5323.       Free;
  5324.     end;
  5325. end;
  5326.  
  5327. procedure TBlobField.SetBlobType(Value: TBlobType);
  5328. begin
  5329.   SetFieldType(Value);
  5330. end;
  5331.  
  5332. procedure TBlobField.SetFieldType(Value: TFieldType);
  5333. begin
  5334.   if Value in [Low(TBlobType)..High(TBlobType)] then SetDataType(Value);
  5335. end;
  5336.  
  5337. procedure TBlobField.SetText(const Value: string);
  5338. begin
  5339.   AccessError('Text');
  5340. end;
  5341.  
  5342. procedure TBlobField.SetVarValue(const Value: Variant);
  5343. begin
  5344.   SetAsString(Value);
  5345. end;
  5346.  
  5347. { TMemoField }
  5348.  
  5349. constructor TMemoField.Create(AOwner: TComponent);
  5350. begin
  5351.   inherited Create(AOwner);
  5352.   SetDataType(ftMemo);
  5353.   Transliterate := True;
  5354. end;
  5355.  
  5356. { TGraphicField }
  5357.  
  5358. constructor TGraphicField.Create(AOwner: TComponent);
  5359. begin
  5360.   inherited Create(AOwner);
  5361.   SetDataType(ftGraphic);
  5362. end;
  5363.  
  5364. { TBlobStream }
  5365.  
  5366. constructor TBlobStream.Create(Field: TBlobField; Mode: TBlobStreamMode);
  5367. var
  5368.   OpenMode: DbiOpenMode;
  5369. begin
  5370.   FField := Field;
  5371.   FDataSet := Field.DataSet;
  5372.   FRecord := FDataSet.ActiveBuffer;
  5373.   FFieldNo := Field.FieldNo;
  5374.   if FDataSet.State = dsFilter then
  5375.     DBErrorFmt(SNoFieldAccess, [FField.DisplayName]);
  5376.   if not FField.FModified then
  5377.   begin
  5378.     if Mode = bmRead then
  5379.     begin
  5380.       FBuffer := AllocMem(FDataSet.RecordSize);
  5381.       FRecord := FBuffer;
  5382.       if not FDataSet.GetCurrentRecord(FBuffer) then Exit;
  5383.       OpenMode := dbiReadOnly;
  5384.     end else
  5385.     begin
  5386.       if not (FDataSet.State in [dsEdit, dsInsert]) then DBError(SNotEditing);
  5387.       OpenMode := dbiReadWrite;
  5388.     end;
  5389.     Check(DbiOpenBlob(FDataSet.Handle, FRecord, FFieldNo, OpenMode));
  5390.   end;
  5391.   FOpened := True;
  5392.   if Mode = bmWrite then Truncate;
  5393. end;
  5394.  
  5395. destructor TBlobStream.Destroy;
  5396. begin
  5397.   if FOpened then
  5398.   begin
  5399.     if FModified then FField.FModified := True;
  5400.     if not FField.FModified then
  5401.       DbiFreeBlob(FDataSet.Handle, FRecord, FFieldNo);
  5402.   end;
  5403.   if FBuffer <> nil then FreeMem(FBuffer, FDataSet.RecordSize);
  5404.   if FModified then
  5405.   try
  5406.     FField.DataChanged;
  5407.   except
  5408.     Application.HandleException(Self);
  5409.   end;
  5410. end;
  5411.  
  5412. function TBlobStream.Read(var Buffer; Count: Longint): Longint;
  5413. var
  5414.   Status: DBIResult;
  5415. begin
  5416.   Result := 0;
  5417.   if FOpened then
  5418.   begin
  5419.     Status := DbiGetBlob(FDataSet.Handle, FRecord, FFieldNo, FPosition,
  5420.       Count, @Buffer, Result);
  5421.     case Status of
  5422.       DBIERR_NONE, DBIERR_ENDOFBLOB:
  5423.         begin
  5424.           if FField.FTransliterate then
  5425.             NativeToAnsiBuf(FDataSet.Locale, @Buffer, @Buffer, Result);
  5426.           Inc(FPosition, Result);
  5427.         end;
  5428.       DBIERR_INVALIDBLOBOFFSET:
  5429.         {Nothing};
  5430.     else
  5431.       DbiError(Status);
  5432.     end;
  5433.   end;
  5434. end;
  5435.  
  5436. function TBlobStream.Write(const Buffer; Count: Longint): Longint;
  5437. var
  5438.   Temp: Pointer;
  5439. begin
  5440.   Result := 0;
  5441.   if FOpened then
  5442.   begin
  5443.     if FField.FTransliterate then
  5444.     begin
  5445.       GetMem(Temp, Count);
  5446.       try
  5447.         AnsiToNativeBuf(FDataSet.Locale, @Buffer, Temp, Count);
  5448.         Check(DbiPutBlob(FDataSet.Handle, FRecord, FFieldNo, FPosition,
  5449.           Count, Temp));
  5450.       finally
  5451.         FreeMem(Temp, Count);
  5452.       end;
  5453.     end else
  5454.       Check(DbiPutBlob(FDataSet.Handle, FRecord, FFieldNo, FPosition,
  5455.         Count, @Buffer));
  5456.     Inc(FPosition, Count);
  5457.     Result := Count;
  5458.     FModified := True;
  5459.   end;
  5460. end;
  5461.  
  5462. function TBlobStream.Seek(Offset: Longint; Origin: Word): Longint;
  5463. begin
  5464.   case Origin of
  5465.     0: FPosition := Offset;
  5466.     1: Inc(FPosition, Offset);
  5467.     2: FPosition := GetBlobSize + Offset;
  5468.   end;
  5469.   Result := FPosition;
  5470. end;
  5471.  
  5472. procedure TBlobStream.Truncate;
  5473. begin
  5474.   if FOpened then
  5475.   begin
  5476.     Check(DbiTruncateBlob(FDataSet.Handle, FRecord, FFieldNo, FPosition));
  5477.     FModified := True;
  5478.   end;
  5479. end;
  5480.  
  5481. function TBlobStream.GetBlobSize: Longint;
  5482. begin
  5483.   Result := 0;
  5484.   if FOpened then
  5485.     Check(DbiGetBlobSize(FDataSet.Handle, FRecord, FFieldNo, Result));
  5486. end;
  5487.  
  5488. { TFieldDataLink }
  5489.  
  5490. procedure TFieldDataLink.SetEditing(Value: Boolean);
  5491. begin
  5492.   if FEditing <> Value then
  5493.   begin
  5494.     FEditing := Value;
  5495.     FModified := False;
  5496.     if Assigned(FOnEditingChange) then FOnEditingChange(Self);
  5497.   end;
  5498. end;
  5499.  
  5500. procedure TFieldDataLink.SetFieldName(const Value: string);
  5501. begin
  5502.   if FFieldName <> Value then
  5503.   begin
  5504.     FFieldName :=  Value;
  5505.     UpdateField;
  5506.   end;
  5507. end;
  5508.  
  5509. procedure TFieldDataLink.SetField(Value: TField);
  5510. begin
  5511.   if FField <> Value then
  5512.   begin
  5513.     FField := Value;
  5514.     EditingChanged;
  5515.     RecordChanged(nil);
  5516.   end;
  5517. end;
  5518.  
  5519. procedure TFieldDataLink.UpdateField;
  5520. begin
  5521.   SetField(nil);
  5522.   if Active and (FFieldName <> '') then
  5523.     SetField(DataSource.DataSet.FieldByName(FFieldName));
  5524. end;
  5525.  
  5526. function TFieldDataLink.Edit: Boolean;
  5527. begin
  5528.   if CanModify then inherited Edit;
  5529.   Result := FEditing;
  5530. end;
  5531.  
  5532. function TFieldDataLink.GetCanModify: Boolean;
  5533. begin
  5534.   Result := not ReadOnly and (Field <> nil) and Field.CanModify;
  5535. end;
  5536.  
  5537. procedure TFieldDataLink.Modified;
  5538. begin
  5539.   FModified := True;
  5540. end;
  5541.  
  5542. procedure TFieldDataLink.Reset;
  5543. begin
  5544.   RecordChanged(nil);
  5545. end;
  5546.  
  5547. procedure TFieldDataLink.ActiveChanged;
  5548. begin
  5549.   UpdateField;
  5550.   if Assigned(FOnActiveChange) then FOnActiveChange(Self);
  5551. end;
  5552.  
  5553. procedure TFieldDataLink.EditingChanged;
  5554. begin
  5555.   SetEditing(inherited Editing and CanModify);
  5556. end;
  5557.  
  5558. procedure TFieldDataLink.FocusControl(Field: TFieldRef);
  5559. begin
  5560.   if (Field^ <> nil) and (Field^ = FField) and (FControl <> nil) and
  5561.     FControl.CanFocus then
  5562.   begin
  5563.     Field^ := nil;
  5564.     FControl.SetFocus;
  5565.   end;
  5566. end;
  5567.  
  5568. procedure TFieldDataLink.RecordChanged(Field: TField);
  5569. begin
  5570.   if (Field = nil) or (Field = FField) then
  5571.   begin
  5572.     if Assigned(FOnDataChange) then FOnDataChange(Self);
  5573.     FModified := False;
  5574.   end;
  5575. end;
  5576.  
  5577. procedure TFieldDataLink.LayoutChanged;
  5578. begin
  5579.   UpdateField;
  5580. end;
  5581.  
  5582. procedure TFieldDataLink.UpdateData;
  5583. begin
  5584.   if FModified then
  5585.   begin
  5586.     if (Field <> nil) and Assigned(FOnUpdateData) then FOnUpdateData(Self);
  5587.     FModified := False;
  5588.   end;
  5589. end;
  5590.  
  5591. end.
  5592.