mirror of
https://gitlab.com/freepascal.org/fpc/pas2js.git
synced 2025-04-21 01:09:21 +02:00
9194 lines
220 KiB
ObjectPascal
9194 lines
220 KiB
ObjectPascal
{
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 1999-2017 by Michael Van Canneyt, member of the
|
|
Free Pascal development team
|
|
|
|
DB database unit
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************}
|
|
unit DB;
|
|
|
|
{$mode objfpc}
|
|
|
|
{ $define dsdebug}
|
|
interface
|
|
|
|
uses Classes, SysUtils, JS, Types, DateUtils;
|
|
|
|
const
|
|
dsMaxBufferCount = MAXINT div 8;
|
|
dsMaxStringSize = 8192;
|
|
|
|
// Used in AsBoolean for string fields to determine
|
|
// whether it's true or false.
|
|
YesNoChars : Array[Boolean] of char = ('N', 'Y');
|
|
|
|
SQLDelimiterCharacters = [';',',',' ','(',')',#13,#10,#9];
|
|
|
|
type
|
|
{ Misc Dataset types }
|
|
|
|
TDataSetState = (dsInactive, dsBrowse, dsEdit, dsInsert, dsSetKey,
|
|
dsCalcFields, dsFilter, dsNewValue, dsOldValue, dsCurValue, dsBlockRead,
|
|
dsInternalCalc, dsOpening, dsRefreshFields);
|
|
|
|
TDataEvent = (deFieldChange, deRecordChange, deDataSetChange,
|
|
deDataSetScroll, deLayoutChange, deUpdateRecord, deUpdateState,
|
|
deCheckBrowseMode, dePropertyChange, deFieldListChange, deFocusControl,
|
|
deParentScroll,deConnectChange,deReconcileError,deDisabledStateChange);
|
|
|
|
TUpdateStatus = (usModified, usInserted, usDeleted);
|
|
TUpdateStatusSet = Set of TUpdateStatus;
|
|
|
|
TResolveStatus = (rsUnresolved, rsResolving, rsResolved, rsResolveFailed);
|
|
TResolveStatusSet = Set of TResolveStatus;
|
|
|
|
TUpdateMode = (upWhereAll, upWhereChanged, upWhereKeyOnly);
|
|
TResolverResponse = (rrSkip, rrAbort, rrMerge, rrApply, rrIgnore);
|
|
|
|
TProviderFlag = (pfInUpdate, pfInWhere, pfInKey, pfHidden, pfRefreshOnInsert,pfRefreshOnUpdate);
|
|
TProviderFlags = set of TProviderFlag;
|
|
|
|
{ Forward declarations }
|
|
|
|
TFieldDef = class;
|
|
TFieldDefs = class;
|
|
TField = class;
|
|
TFields = Class;
|
|
TDataSet = class;
|
|
TDataSource = Class;
|
|
TDataLink = Class;
|
|
TDataProxy = Class;
|
|
TDataRequest = class;
|
|
TRecordUpdateDescriptor = class;
|
|
TRecordUpdateDescriptorList = class;
|
|
TRecordUpdateBatch = class;
|
|
|
|
{ Exception classes }
|
|
|
|
EDatabaseError = class(Exception);
|
|
|
|
EUpdateError = class(EDatabaseError)
|
|
private
|
|
FContext : String;
|
|
FErrorCode : integer;
|
|
FOriginalException : Exception;
|
|
FPreviousError : Integer;
|
|
public
|
|
constructor Create(NativeError, Context : String;
|
|
ErrCode, PrevError : integer; E: Exception); reintroduce;
|
|
Destructor Destroy; override;
|
|
property Context : String read FContext;
|
|
property ErrorCode : integer read FErrorcode;
|
|
property OriginalException : Exception read FOriginalException;
|
|
property PreviousError : Integer read FPreviousError;
|
|
end;
|
|
|
|
|
|
{ TFieldDef }
|
|
|
|
TFieldClass = class of TField;
|
|
|
|
// Data type for field.
|
|
TFieldType = (
|
|
ftUnknown, ftString, ftInteger, ftLargeInt, ftBoolean, ftFloat, ftDate,
|
|
ftTime, ftDateTime, ftAutoInc, ftBlob, ftMemo, ftFixedChar,
|
|
ftVariant,ftDataset
|
|
);
|
|
|
|
{ TDateTimeRec }
|
|
|
|
TFieldAttribute = (faHiddenCol, faReadonly, faRequired, faLink, faUnNamed, faFixed);
|
|
TFieldAttributes = set of TFieldAttribute;
|
|
|
|
{ TNamedItem }
|
|
|
|
TNamedItem = class(TCollectionItem)
|
|
private
|
|
FName: string;
|
|
protected
|
|
function GetDisplayName: string; override;
|
|
procedure SetDisplayName(const Value: string); override;
|
|
Public
|
|
property DisplayName : string read GetDisplayName write SetDisplayName;
|
|
published
|
|
property Name : string read FName write SetDisplayName;
|
|
end;
|
|
|
|
{ TDefCollection }
|
|
|
|
TDefCollection = class(TOwnedCollection)
|
|
private
|
|
FDataset: TDataset;
|
|
FUpdated: boolean;
|
|
protected
|
|
procedure SetItemName(Item: TCollectionItem); override;
|
|
public
|
|
constructor create(ADataset: TDataset; AOwner: TPersistent; AClass: TCollectionItemClass); reintroduce;
|
|
function Find(const AName: string): TNamedItem;
|
|
procedure GetItemNames(List: TStrings);
|
|
function IndexOf(const AName: string): Longint;
|
|
property Dataset: TDataset read FDataset;
|
|
property Updated: boolean read FUpdated write FUpdated;
|
|
end;
|
|
|
|
{ TFieldDef }
|
|
|
|
TFieldDef = class(TNamedItem)
|
|
Private
|
|
FAttributes : TFieldAttributes;
|
|
FDataType : TFieldType;
|
|
FFieldNo : Longint;
|
|
FInternalCalcField : Boolean;
|
|
FPrecision : Longint;
|
|
FRequired : Boolean;
|
|
FSize : Integer;
|
|
Function GetFieldClass : TFieldClass;
|
|
procedure SetAttributes(AValue: TFieldAttributes);
|
|
procedure SetDataType(AValue: TFieldType);
|
|
procedure SetPrecision(const AValue: Longint);
|
|
procedure SetSize(const AValue: Integer);
|
|
procedure SetRequired(const AValue: Boolean);
|
|
public
|
|
constructor Create(ACollection : TCollection); override;
|
|
constructor Create(AOwner: TFieldDefs; const AName: string; ADataType: TFieldType; ASize: Integer; ARequired: Boolean; AFieldNo: Longint); overload;
|
|
destructor Destroy; override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
function CreateField(AOwner: TComponent): TField;
|
|
property FieldClass: TFieldClass read GetFieldClass;
|
|
property FieldNo: Longint read FFieldNo;
|
|
property InternalCalcField: Boolean read FInternalCalcField write FInternalCalcField;
|
|
property Required: Boolean read FRequired write SetRequired;
|
|
Published
|
|
property Attributes: TFieldAttributes read FAttributes write SetAttributes default [];
|
|
property DataType: TFieldType read FDataType write SetDataType;
|
|
property Precision: Longint read FPrecision write SetPrecision default 0;
|
|
property Size: Integer read FSize write SetSize default 0;
|
|
end;
|
|
TFieldDefClass = Class of TFieldDef;
|
|
|
|
{ TFieldDefs }
|
|
|
|
TFieldDefs = class(TDefCollection)
|
|
private
|
|
FHiddenFields : Boolean;
|
|
function GetItem(Index: Longint): TFieldDef; reintroduce;
|
|
procedure SetItem(Index: Longint; const AValue: TFieldDef); reintroduce;
|
|
Protected
|
|
Class Function FieldDefClass : TFieldDefClass; virtual;
|
|
public
|
|
constructor Create(ADataSet: TDataSet); reintroduce;
|
|
// destructor Destroy; override;
|
|
Function Add(const AName: string; ADataType: TFieldType; ASize, APrecision{%H-}: Integer; ARequired, AReadOnly: Boolean; AFieldNo : Integer) : TFieldDef; overload;
|
|
Function Add(const AName: string; ADataType: TFieldType; ASize: Word; ARequired: Boolean; AFieldNo : Integer) : TFieldDef; overload;
|
|
procedure Add(const AName: string; ADataType: TFieldType; ASize: Word; ARequired: Boolean); overload;
|
|
procedure Add(const AName: string; ADataType: TFieldType; ASize: Word); overload;
|
|
procedure Add(const AName: string; ADataType: TFieldType); overload;
|
|
Function AddFieldDef : TFieldDef;
|
|
procedure Assign(FieldDefs: TFieldDefs); overload;
|
|
function Find(const AName: string): TFieldDef; reintroduce;
|
|
// procedure Clear;
|
|
// procedure Delete(Index: Longint);
|
|
procedure Update; overload;
|
|
Function MakeNameUnique(const AName : String) : string; virtual;
|
|
Property HiddenFields : Boolean Read FHiddenFields Write FHiddenFields;
|
|
property Items[Index: Longint]: TFieldDef read GetItem write SetItem; default;
|
|
end;
|
|
TFieldDefsClass = Class of TFieldDefs;
|
|
|
|
{ TField }
|
|
|
|
TFieldKind = (fkData, fkCalculated, fkLookup, fkInternalCalc);
|
|
TFieldKinds = Set of TFieldKind;
|
|
|
|
TFieldNotifyEvent = procedure(Sender: TField) of object;
|
|
TFieldGetTextEvent = procedure(Sender: TField; var aText: string;
|
|
DisplayText: Boolean) of object;
|
|
TFieldSetTextEvent = procedure(Sender: TField; const aText: string) of object;
|
|
TFieldChars = Array of Char;
|
|
|
|
{ TLookupList }
|
|
|
|
TLookupList = class(TObject)
|
|
private
|
|
FList: TFPList;
|
|
public
|
|
constructor Create; reintroduce;
|
|
destructor Destroy; override;
|
|
procedure Add(const AKey, AValue: JSValue);
|
|
procedure Clear;
|
|
function FirstKeyByValue(const AValue: JSValue): JSValue;
|
|
function ValueOfKey(const AKey: JSValue): JSValue;
|
|
procedure ValuesToStrings(AStrings: TStrings);
|
|
end;
|
|
|
|
{ TField }
|
|
|
|
TField = class(TComponent)
|
|
private
|
|
FAlignment : TAlignment;
|
|
FAttributeSet : String;
|
|
FCalculated : Boolean;
|
|
FConstraintErrorMessage : String;
|
|
FCustomConstraint : String;
|
|
FDataSet : TDataSet;
|
|
// FDataSize : Word;
|
|
FDataType : TFieldType;
|
|
FDefaultExpression : String;
|
|
FDisplayLabel : String;
|
|
FDisplayWidth : Longint;
|
|
// FEditMask: TEditMask;
|
|
FFieldDef: TFieldDef;
|
|
FFieldKind : TFieldKind;
|
|
FFieldName : String;
|
|
FFieldNo : Longint;
|
|
FFields : TFields;
|
|
FHasConstraints : Boolean;
|
|
FImportedConstraint : String;
|
|
FIsIndexField : Boolean;
|
|
FKeyFields : String;
|
|
FLookupCache : Boolean;
|
|
FLookupDataSet : TDataSet;
|
|
FLookupKeyfields : String;
|
|
FLookupresultField : String;
|
|
FLookupList: TLookupList;
|
|
FOnChange : TFieldNotifyEvent;
|
|
FOnGetText: TFieldGetTextEvent;
|
|
FOnSetText: TFieldSetTextEvent;
|
|
FOnValidate: TFieldNotifyEvent;
|
|
FOrigin : String;
|
|
FReadOnly : Boolean;
|
|
FRequired : Boolean;
|
|
FSize : integer;
|
|
FValidChars : TFieldChars;
|
|
FValueBuffer : JSValue;
|
|
FValidating : Boolean;
|
|
FVisible : Boolean;
|
|
FProviderFlags : TProviderFlags;
|
|
function GetIndex : longint;
|
|
function GetLookup: Boolean;
|
|
procedure SetAlignment(const AValue: TAlignMent);
|
|
procedure SetIndex(const AValue: Longint);
|
|
function GetDisplayText: String;
|
|
function GetEditText: String;
|
|
procedure SetEditText(const AValue: string);
|
|
procedure SetDisplayLabel(const AValue: string);
|
|
procedure SetDisplayWidth(const AValue: Longint);
|
|
function GetDisplayWidth: integer;
|
|
procedure SetLookup(const AValue: Boolean);
|
|
procedure SetReadOnly(const AValue: Boolean);
|
|
procedure SetVisible(const AValue: Boolean);
|
|
function IsDisplayLabelStored : Boolean;
|
|
function IsDisplayWidthStored: Boolean;
|
|
function GetLookupList: TLookupList;
|
|
procedure CalcLookupValue;
|
|
protected
|
|
Procedure RaiseAccessError(const TypeName: string);
|
|
function AccessError(const TypeName: string): EDatabaseError;
|
|
procedure CheckInactive;
|
|
class procedure CheckTypeSize(AValue: Longint); virtual;
|
|
procedure Change; virtual;
|
|
procedure Bind(Binding: Boolean); virtual;
|
|
procedure DataChanged;
|
|
function GetAsBoolean: Boolean; virtual;
|
|
function GetAsBytes: TBytes; virtual;
|
|
function GetAsLargeInt: NativeInt; virtual;
|
|
function GetAsDateTime: TDateTime; virtual;
|
|
function GetAsFloat: Double; virtual;
|
|
function GetAsLongint: Longint; virtual;
|
|
function GetAsInteger: Longint; virtual;
|
|
function GetAsJSValue: JSValue; virtual;
|
|
function GetOldValue: JSValue; virtual;
|
|
function GetAsString: string; virtual;
|
|
function GetCanModify: Boolean; virtual;
|
|
function GetClassDesc: String; virtual;
|
|
function GetDataSize: Integer; virtual;
|
|
function GetDefaultWidth: Longint; virtual;
|
|
function GetDisplayName : String;
|
|
function GetCurValue: JSValue; virtual;
|
|
function GetNewValue: JSValue; virtual;
|
|
function GetIsNull: Boolean; virtual;
|
|
procedure GetText(var AText: string; ADisplayText{%H-}: Boolean); virtual;
|
|
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
|
procedure PropertyChanged(LayoutAffected: Boolean);
|
|
procedure SetAsBoolean(AValue{%H-}: Boolean); virtual;
|
|
procedure SetAsDateTime(AValue{%H-}: TDateTime); virtual;
|
|
procedure SetAsFloat(AValue{%H-}: Double); virtual;
|
|
procedure SetAsLongint(AValue: Longint); virtual;
|
|
procedure SetAsInteger(AValue{%H-}: Longint); virtual;
|
|
procedure SetAsLargeInt(AValue{%H-}: NativeInt); virtual;
|
|
procedure SetAsJSValue(const AValue: JSValue); virtual;
|
|
procedure SetAsString(const AValue{%H-}: string); virtual;
|
|
procedure SetDataset(AValue : TDataset); virtual;
|
|
procedure SetDataType(AValue: TFieldType);
|
|
procedure SetNewValue(const AValue: JSValue);
|
|
procedure SetSize(AValue: Integer); virtual;
|
|
procedure SetParentComponent(Value: TComponent); override;
|
|
procedure SetText(const AValue: string); virtual;
|
|
procedure SetVarValue(const AValue{%H-}: JSValue); virtual;
|
|
procedure SetAsBytes(const AValue{%H-}: TBytes); virtual;
|
|
procedure DefineProperties(Filer: TFiler); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
function GetParentComponent: TComponent; override;
|
|
function HasParent: Boolean; override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
procedure AssignValue(const AValue: JSValue);
|
|
procedure Clear; virtual;
|
|
procedure FocusControl;
|
|
function GetData : JSValue;
|
|
class function IsBlob: Boolean; virtual;
|
|
function IsValidChar(InputChar: Char): Boolean; virtual;
|
|
procedure RefreshLookupList;
|
|
procedure SetData(Buffer: JSValue); overload;
|
|
procedure SetFieldType(AValue{%H-}: TFieldType); virtual;
|
|
procedure Validate(Buffer: Pointer);
|
|
property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;
|
|
property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
|
|
property AsFloat: Double read GetAsFloat write SetAsFloat;
|
|
property AsLongint: Longint read GetAsLongint write SetAsLongint;
|
|
property AsLargeInt: NativeInt read GetAsLargeInt write SetAsLargeInt;
|
|
property AsInteger: Longint read GetAsInteger write SetAsInteger;
|
|
property AsString: string read GetAsString write SetAsString;
|
|
property AsJSValue: JSValue read GetAsJSValue write SetAsJSValue;
|
|
property AttributeSet: string read FAttributeSet write FAttributeSet;
|
|
property Calculated: Boolean read FCalculated write FCalculated;
|
|
property CanModify: Boolean read GetCanModify;
|
|
property CurValue: JSValue read GetCurValue;
|
|
property DataSet: TDataSet read FDataSet write SetDataSet;
|
|
property DataSize: Integer read GetDataSize;
|
|
property DataType: TFieldType read FDataType;
|
|
property DisplayName: String Read GetDisplayName;
|
|
property DisplayText: String read GetDisplayText;
|
|
property FieldNo: Longint read FFieldNo;
|
|
property IsIndexField: Boolean read FIsIndexField;
|
|
property IsNull: Boolean read GetIsNull;
|
|
property Lookup: Boolean read GetLookup write SetLookup; deprecated;
|
|
property NewValue: JSValue read GetNewValue write SetNewValue;
|
|
property Size: Integer read FSize write SetSize;
|
|
property Text: string read GetEditText write SetEditText;
|
|
property ValidChars : TFieldChars read FValidChars write FValidChars;
|
|
property Value: JSValue read GetAsJSValue write SetAsJSValue;
|
|
property OldValue: JSValue read GetOldValue;
|
|
property LookupList: TLookupList read GetLookupList;
|
|
Property FieldDef : TFieldDef Read FFieldDef;
|
|
published
|
|
property Alignment : TAlignment read FAlignment write SetAlignment default taLeftJustify;
|
|
property CustomConstraint: string read FCustomConstraint write FCustomConstraint;
|
|
property ConstraintErrorMessage: string read FConstraintErrorMessage write FConstraintErrorMessage;
|
|
property DefaultExpression: string read FDefaultExpression write FDefaultExpression;
|
|
property DisplayLabel : string read GetDisplayName write SetDisplayLabel stored IsDisplayLabelStored;
|
|
property DisplayWidth: Longint read GetDisplayWidth write SetDisplayWidth stored IsDisplayWidthStored;
|
|
property FieldKind: TFieldKind read FFieldKind write FFieldKind;
|
|
property FieldName: string read FFieldName write FFieldName;
|
|
property HasConstraints: Boolean read FHasConstraints;
|
|
property Index: Longint read GetIndex write SetIndex;
|
|
property ImportedConstraint: string read FImportedConstraint write FImportedConstraint;
|
|
property KeyFields: string read FKeyFields write FKeyFields;
|
|
property LookupCache: Boolean read FLookupCache write FLookupCache;
|
|
property LookupDataSet: TDataSet read FLookupDataSet write FLookupDataSet;
|
|
property LookupKeyFields: string read FLookupKeyFields write FLookupKeyFields;
|
|
property LookupResultField: string read FLookupResultField write FLookupResultField;
|
|
property Origin: string read FOrigin write FOrigin;
|
|
property ProviderFlags : TProviderFlags read FProviderFlags write FProviderFlags;
|
|
property ReadOnly: Boolean read FReadOnly write SetReadOnly;
|
|
property Required: Boolean read FRequired write FRequired;
|
|
property Visible: Boolean read FVisible write SetVisible default True;
|
|
property OnChange: TFieldNotifyEvent read FOnChange write FOnChange;
|
|
property OnGetText: TFieldGetTextEvent read FOnGetText write FOnGetText;
|
|
property OnSetText: TFieldSetTextEvent read FOnSetText write FOnSetText;
|
|
property OnValidate: TFieldNotifyEvent read FOnValidate write FOnValidate;
|
|
end;
|
|
|
|
{ TStringField }
|
|
|
|
TStringField = class(TField)
|
|
private
|
|
FFixedChar : boolean;
|
|
FTransliterate : Boolean;
|
|
protected
|
|
class procedure CheckTypeSize(AValue: Longint); override;
|
|
function GetAsBoolean: Boolean; override;
|
|
function GetAsDateTime: TDateTime; override;
|
|
function GetAsFloat: Double; override;
|
|
function GetAsInteger: Longint; override;
|
|
function GetAsLargeInt: NativeInt; override;
|
|
function GetAsString: String; override;
|
|
function GetAsJSValue: JSValue; override;
|
|
function GetDefaultWidth: Longint; override;
|
|
procedure GetText(var AText: string; ADisplayText{%H-}: Boolean); override;
|
|
procedure SetAsBoolean(AValue: Boolean); override;
|
|
procedure SetAsDateTime(AValue: TDateTime); override;
|
|
procedure SetAsFloat(AValue: Double); override;
|
|
procedure SetAsInteger(AValue: Longint); override;
|
|
procedure SetAsLargeInt(AValue: NativeInt); override;
|
|
procedure SetAsString(const AValue: String); override;
|
|
procedure SetVarValue(const AValue: JSValue); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
procedure SetFieldType(AValue: TFieldType); override;
|
|
property FixedChar : Boolean read FFixedChar write FFixedChar;
|
|
property Transliterate: Boolean read FTransliterate write FTransliterate;
|
|
property Value: String read GetAsString write SetAsString;
|
|
published
|
|
property Size default 20;
|
|
end;
|
|
|
|
|
|
{ TNumericField }
|
|
|
|
TNumericField = class(TField)
|
|
Private
|
|
FDisplayFormat : String;
|
|
FEditFormat : String;
|
|
protected
|
|
class procedure CheckTypeSize(AValue: Longint); override;
|
|
procedure RangeError(AValue, Min, Max: Double);
|
|
procedure SetDisplayFormat(const AValue: string);
|
|
procedure SetEditFormat(const AValue: string);
|
|
function GetAsBoolean: Boolean; override;
|
|
Procedure SetAsBoolean(AValue: Boolean); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
published
|
|
property Alignment default taRightJustify;
|
|
property DisplayFormat: string read FDisplayFormat write SetDisplayFormat;
|
|
property EditFormat: string read FEditFormat write SetEditFormat;
|
|
end;
|
|
|
|
{ TLongintField }
|
|
|
|
TIntegerField = class(TNumericField)
|
|
private
|
|
FMinValue,
|
|
FMaxValue,
|
|
FMinRange,
|
|
FMaxRange : Longint;
|
|
Procedure SetMinValue (AValue : longint);
|
|
Procedure SetMaxValue (AValue : longint);
|
|
protected
|
|
function GetAsFloat: Double; override;
|
|
function GetAsInteger: Longint; override;
|
|
function GetAsString: string; override;
|
|
function GetAsJSValue: JSValue; override;
|
|
procedure GetText(var AText: string; ADisplayText: Boolean); override;
|
|
function GetValue(var AValue: Longint): Boolean;
|
|
procedure SetAsFloat(AValue: Double); override;
|
|
procedure SetAsInteger(AValue: Longint); override;
|
|
procedure SetAsString(const AValue: string); override;
|
|
procedure SetVarValue(const AValue: JSValue); override;
|
|
function GetAsLargeInt: NativeInt; override;
|
|
procedure SetAsLargeInt(AValue: NativeInt); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
Function CheckRange(AValue : Longint) : Boolean;
|
|
property Value: Longint read GetAsInteger write SetAsInteger;
|
|
published
|
|
property MaxValue: Longint read FMaxValue write SetMaxValue default 0;
|
|
property MinValue: Longint read FMinValue write SetMinValue default 0;
|
|
end;
|
|
|
|
{ TLargeintField }
|
|
|
|
TLargeintField = class(TNumericField)
|
|
private
|
|
FMinValue,
|
|
FMaxValue,
|
|
FMinRange,
|
|
FMaxRange : NativeInt;
|
|
Procedure SetMinValue (AValue : NativeInt);
|
|
Procedure SetMaxValue (AValue : NativeInt);
|
|
protected
|
|
function GetAsFloat: Double; override;
|
|
function GetAsInteger: Longint; override;
|
|
function GetAsLargeInt: NativeInt; override;
|
|
function GetAsString: string; override;
|
|
function GetAsJSValue: JSValue; override;
|
|
procedure GetText(var AText: string; ADisplayText: Boolean); override;
|
|
function GetValue(var AValue: NativeInt): Boolean;
|
|
procedure SetAsFloat(AValue: Double); override;
|
|
procedure SetAsInteger(AValue: Longint); override;
|
|
procedure SetAsLargeInt(AValue: NativeInt); override;
|
|
procedure SetAsString(const AValue: string); override;
|
|
procedure SetVarValue(const AValue: JSValue); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
Function CheckRange(AValue : NativeInt) : Boolean;
|
|
property Value: NativeInt read GetAsLargeInt write SetAsLargeInt;
|
|
published
|
|
property MaxValue: NativeInt read FMaxValue write SetMaxValue default 0;
|
|
property MinValue: NativeInt read FMinValue write SetMinValue default 0;
|
|
end;
|
|
|
|
{ TAutoIncField }
|
|
|
|
TAutoIncField = class(TIntegerField)
|
|
Protected
|
|
procedure SetAsInteger(AValue: Longint); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
end;
|
|
|
|
{ TFloatField }
|
|
|
|
TFloatField = class(TNumericField)
|
|
private
|
|
FCurrency: Boolean;
|
|
FMaxValue : Double;
|
|
FMinValue : Double;
|
|
FPrecision : Longint;
|
|
procedure SetCurrency(const AValue: Boolean);
|
|
procedure SetPrecision(const AValue: Longint);
|
|
protected
|
|
function GetAsFloat: Double; override;
|
|
function GetAsLargeInt: NativeInt; override;
|
|
function GetAsInteger: Longint; override;
|
|
function GetAsJSValue: JSValue; override;
|
|
function GetAsString: string; override;
|
|
procedure GetText(var AText: string; ADisplayText: Boolean); override;
|
|
procedure SetAsFloat(AValue: Double); override;
|
|
procedure SetAsLargeInt(AValue: NativeInt); override;
|
|
procedure SetAsInteger(AValue: Longint); override;
|
|
procedure SetAsString(const AValue: string); override;
|
|
procedure SetVarValue(const AValue: JSValue); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
Function CheckRange(AValue : Double) : Boolean;
|
|
property Value: Double read GetAsFloat write SetAsFloat;
|
|
|
|
published
|
|
property Currency: Boolean read FCurrency write SetCurrency default False;
|
|
property MaxValue: Double read FMaxValue write FMaxValue;
|
|
property MinValue: Double read FMinValue write FMinValue;
|
|
property Precision: Longint read FPrecision write SetPrecision default 15; // min 2 instellen, delphi compat
|
|
end;
|
|
|
|
|
|
{ TBooleanField }
|
|
|
|
TBooleanField = class(TField)
|
|
private
|
|
FDisplayValues : String;
|
|
// First byte indicates uppercase or not.
|
|
FDisplays : Array[Boolean,Boolean] of string;
|
|
Procedure SetDisplayValues(const AValue : String);
|
|
protected
|
|
function GetAsBoolean: Boolean; override;
|
|
function GetAsString: string; override;
|
|
function GetAsJSValue: JSValue; override;
|
|
function GetAsInteger: Longint; override;
|
|
function GetDefaultWidth: Longint; override;
|
|
procedure SetAsBoolean(AValue: Boolean); override;
|
|
procedure SetAsString(const AValue: string); override;
|
|
procedure SetAsInteger(AValue: Longint); override;
|
|
procedure SetVarValue(const AValue: JSValue); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
property Value: Boolean read GetAsBoolean write SetAsBoolean;
|
|
published
|
|
property DisplayValues: string read FDisplayValues write SetDisplayValues;
|
|
end;
|
|
|
|
{ TDateTimeField }
|
|
|
|
TDateTimeField = class(TField)
|
|
private
|
|
FDisplayFormat : String;
|
|
procedure SetDisplayFormat(const AValue: string);
|
|
protected
|
|
Function ConvertToDateTime(aValue : JSValue; aRaiseError : Boolean) : TDateTime; virtual;
|
|
Function DateTimeToNativeDateTime(aValue : TDateTime) : JSValue; virtual;
|
|
function GetAsDateTime: TDateTime; override;
|
|
function GetAsFloat: Double; override;
|
|
function GetAsString: string; override;
|
|
function GetAsJSValue: JSValue; override;
|
|
function GetDataSize: Integer; override;
|
|
procedure GetText(var AText: string; ADisplayText: Boolean); override;
|
|
procedure SetAsDateTime(AValue: TDateTime); override;
|
|
procedure SetAsFloat(AValue: Double); override;
|
|
procedure SetAsString(const AValue: string); override;
|
|
procedure SetVarValue(const AValue: JSValue); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
property Value: TDateTime read GetAsDateTime write SetAsDateTime;
|
|
published
|
|
property DisplayFormat: string read FDisplayFormat write SetDisplayFormat;
|
|
end;
|
|
|
|
{ TDateField }
|
|
|
|
TDateField = class(TDateTimeField)
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
end;
|
|
|
|
{ TTimeField }
|
|
|
|
TTimeField = class(TDateTimeField)
|
|
protected
|
|
procedure SetAsString(const AValue: string); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
end;
|
|
|
|
{ TBinaryField }
|
|
|
|
TBinaryField = class(TField)
|
|
protected
|
|
class procedure CheckTypeSize(AValue: Longint); override;
|
|
Function BlobToBytes(aValue : JSValue) : TBytes; virtual;
|
|
Function BytesToBlob(aValue : TBytes) : JSValue; virtual;
|
|
function GetAsString: string; override;
|
|
function GetAsJSValue: JSValue; override;
|
|
function GetValue(var AValue: TBytes): Boolean;
|
|
procedure SetAsString(const AValue: string); override;
|
|
procedure SetVarValue(const AValue: JSValue); override;
|
|
Function GetAsBytes: TBytes; override;
|
|
Procedure SetAsBytes(const aValue: TBytes); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
published
|
|
property Size default 16;
|
|
end;
|
|
|
|
{ TBytesField }
|
|
|
|
|
|
{ TBlobField }
|
|
TBlobDisplayValue = (dvClass, dvFull, dvClip, dvFit);
|
|
TBlobStreamMode = (bmRead, bmWrite, bmReadWrite);
|
|
TBlobType = ftBlob..ftMemo;
|
|
|
|
TBlobField = class(TBinaryField)
|
|
private
|
|
FDisplayValue: TBlobDisplayValue;
|
|
FModified : Boolean;
|
|
// Wrapper that retrieves FDataType as a TBlobType
|
|
function GetBlobType: TBlobType;
|
|
// Wrapper that calls SetFieldType
|
|
procedure SetBlobType(AValue: TBlobType);
|
|
procedure SetDisplayValue(AValue: TBlobDisplayValue);
|
|
protected
|
|
class procedure CheckTypeSize(AValue: Longint); override;
|
|
function GetBlobSize: Longint; virtual;
|
|
function GetIsNull: Boolean; override;
|
|
procedure GetText(var AText: string; ADisplayText{%H-}: Boolean); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
procedure Clear; override;
|
|
class function IsBlob: Boolean; override;
|
|
procedure SetFieldType(AValue: TFieldType); override;
|
|
property BlobSize: Longint read GetBlobSize;
|
|
property Modified: Boolean read FModified write FModified;
|
|
property Value: string read GetAsString write SetAsString;
|
|
published
|
|
property DisplayValue: TBlobDisplayValue read FDisplayValue write SetDisplayValue default dvClass;
|
|
property BlobType: TBlobType read GetBlobType write SetBlobType; // default ftBlob;
|
|
property Size default 0;
|
|
end;
|
|
|
|
{ TMemoField }
|
|
|
|
TMemoField = class(TBlobField)
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
end;
|
|
|
|
|
|
{ TVariantField }
|
|
|
|
TVariantField = class(TField)
|
|
protected
|
|
class procedure CheckTypeSize(aValue{%H-}: Integer); override;
|
|
|
|
function GetAsBoolean: Boolean; override;
|
|
procedure SetAsBoolean(aValue: Boolean); override;
|
|
|
|
function GetAsDateTime: TDateTime; override;
|
|
procedure SetAsDateTime(aValue: TDateTime); override;
|
|
|
|
function GetAsFloat: Double; override;
|
|
procedure SetAsFloat(aValue: Double); override;
|
|
|
|
function GetAsInteger: Longint; override;
|
|
procedure SetAsInteger(AValue: Longint); override;
|
|
|
|
function GetAsString: string; override;
|
|
procedure SetAsString(const aValue: string); override;
|
|
|
|
|
|
function GetAsJSValue: JSValue; override;
|
|
procedure SetVarValue(const aValue: JSValue); override;
|
|
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
end;
|
|
|
|
TDataSetField = class(TField)
|
|
private
|
|
FNestedDataSet: TDataSet;
|
|
procedure AssignNestedDataSet(Value: TDataSet);
|
|
protected
|
|
procedure Bind(Binding: Boolean); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
{ TIndexDef }
|
|
|
|
TIndexDefs = class;
|
|
|
|
TIndexOption = (ixPrimary, ixUnique, ixDescending, ixCaseInsensitive,
|
|
ixExpression, ixNonMaintained);
|
|
TIndexOptions = set of TIndexOption;
|
|
|
|
TIndexDef = class(TNamedItem)
|
|
Private
|
|
FCaseinsFields: string;
|
|
FDescFields: string;
|
|
FExpression : String;
|
|
FFields : String;
|
|
FOptions : TIndexOptions;
|
|
FSource : String;
|
|
protected
|
|
function GetExpression: string;
|
|
procedure SetCaseInsFields(const AValue: string); virtual;
|
|
procedure SetDescFields(const AValue: string);
|
|
procedure SetExpression(const AValue: string);
|
|
public
|
|
constructor Create(Owner: TIndexDefs; const AName, TheFields: string;
|
|
TheOptions: TIndexOptions); overload;
|
|
procedure Assign(Source: TPersistent); override;
|
|
published
|
|
property Expression: string read GetExpression write SetExpression;
|
|
property Fields: string read FFields write FFields;
|
|
property CaseInsFields: string read FCaseinsFields write SetCaseInsFields;
|
|
property DescFields: string read FDescFields write SetDescFields;
|
|
property Options: TIndexOptions read FOptions write FOptions;
|
|
property Source: string read FSource write FSource;
|
|
end;
|
|
TIndexDefClass = class of TIndexDef;
|
|
{ TIndexDefs }
|
|
|
|
TIndexDefs = class(TDefCollection)
|
|
Private
|
|
Function GetItem(Index: Integer): TIndexDef; reintroduce;
|
|
Procedure SetItem(Index: Integer; Value: TIndexDef); reintroduce;
|
|
public
|
|
constructor Create(ADataSet: TDataSet); virtual; overload;
|
|
procedure Add(const Name, Fields: string; Options: TIndexOptions); reintroduce;
|
|
Function AddIndexDef: TIndexDef;
|
|
function Find(const IndexName: string): TIndexDef; reintroduce;
|
|
function FindIndexForFields(const Fields{%H-}: string): TIndexDef;
|
|
function GetIndexForFields(const Fields: string;
|
|
CaseInsensitive: Boolean): TIndexDef;
|
|
procedure Update; overload; virtual;
|
|
Property Items[Index: Integer] : TIndexDef read GetItem write SetItem; default;
|
|
end;
|
|
|
|
{ TCheckConstraint }
|
|
|
|
TCheckConstraint = class(TCollectionItem)
|
|
Private
|
|
FCustomConstraint : String;
|
|
FErrorMessage : String;
|
|
FFromDictionary : Boolean;
|
|
FImportedConstraint : String;
|
|
public
|
|
procedure Assign(Source{%H-}: TPersistent); override;
|
|
// function GetDisplayName: string; override;
|
|
published
|
|
property CustomConstraint: string read FCustomConstraint write FCustomConstraint;
|
|
property ErrorMessage: string read FErrorMessage write FErrorMessage;
|
|
property FromDictionary: Boolean read FFromDictionary write FFromDictionary;
|
|
property ImportedConstraint: string read FImportedConstraint write FImportedConstraint;
|
|
end;
|
|
|
|
{ TCheckConstraints }
|
|
|
|
TCheckConstraints = class(TCollection)
|
|
Private
|
|
Function GetItem(Index{%H-} : Longint) : TCheckConstraint; reintroduce;
|
|
Procedure SetItem(index{%H-} : Longint; Value{%H-} : TCheckConstraint); reintroduce;
|
|
protected
|
|
function GetOwner: TPersistent; override;
|
|
public
|
|
constructor Create(AOwner{%H-}: TPersistent); reintroduce;
|
|
function Add: TCheckConstraint; reintroduce;
|
|
property Items[Index: Longint]: TCheckConstraint read GetItem write SetItem; default;
|
|
end;
|
|
|
|
{ TFieldsEnumerator }
|
|
|
|
TFieldsEnumerator = class
|
|
private
|
|
FPosition: Integer;
|
|
FFields: TFields;
|
|
function GetCurrent: TField;
|
|
public
|
|
constructor Create(AFields: TFields); reintroduce;
|
|
function MoveNext: Boolean;
|
|
property Current: TField read GetCurrent;
|
|
end;
|
|
|
|
{ TFields }
|
|
|
|
TFields = Class(TObject)
|
|
Private
|
|
FDataset : TDataset;
|
|
FFieldList : TFpList;
|
|
FOnChange : TNotifyEvent;
|
|
FValidFieldKinds : TFieldKinds;
|
|
Protected
|
|
Procedure ClearFieldDefs;
|
|
Procedure Changed;
|
|
Procedure CheckfieldKind(Fieldkind : TFieldKind; Field : TField);
|
|
Function GetCount : Longint;
|
|
Function GetField (Index : Integer) : TField;
|
|
Procedure SetField(Index: Integer; Value: TField);
|
|
Procedure SetFieldIndex (Field : TField;Value : Integer);
|
|
Property OnChange : TNotifyEvent Read FOnChange Write FOnChange;
|
|
Property ValidFieldKinds : TFieldKinds Read FValidFieldKinds;
|
|
Public
|
|
Constructor Create(ADataset : TDataset); reintroduce;
|
|
Destructor Destroy;override;
|
|
Procedure Add(Field : TField);
|
|
Procedure CheckFieldName (Const Value : String);
|
|
Procedure CheckFieldNames (Const Value : String);
|
|
Procedure Clear;
|
|
Function FindField (Const Value : String) : TField;
|
|
Function FieldByName (Const Value : String) : TField;
|
|
Function FieldByNumber(FieldNo : Integer) : TField;
|
|
Function GetEnumerator: TFieldsEnumerator;
|
|
Procedure GetFieldNames (Values : TStrings);
|
|
Function IndexOf(Field : TField) : Longint;
|
|
procedure Remove(Value : TField);
|
|
Property Count : Integer Read GetCount;
|
|
Property Dataset : TDataset Read FDataset;
|
|
Property Fields [Index : Integer] : TField Read GetField Write SetField; default;
|
|
end;
|
|
TFieldsClass = Class of TFields;
|
|
|
|
{ TParam }
|
|
|
|
TBlobData = TBytes; // Delphi defines it as alias to TBytes
|
|
|
|
TParamBinding = array of integer;
|
|
|
|
TParamType = (ptUnknown, ptInput, ptOutput, ptInputOutput, ptResult);
|
|
TParamTypes = set of TParamType;
|
|
|
|
TParamStyle = (psInterbase,psPostgreSQL,psSimulated);
|
|
|
|
TParams = class;
|
|
|
|
TParam = class(TCollectionItem)
|
|
private
|
|
FValue: JSValue;
|
|
FPrecision: Integer;
|
|
FNumericScale: Integer;
|
|
FName: string;
|
|
FDataType: TFieldType;
|
|
FBound: Boolean;
|
|
FParamType: TParamType;
|
|
FSize: Integer;
|
|
Function GetDataSet: TDataSet;
|
|
Function IsParamStored: Boolean;
|
|
protected
|
|
Procedure AssignParam(Param: TParam);
|
|
Procedure AssignTo(Dest: TPersistent); override;
|
|
Function GetAsBoolean: Boolean;
|
|
Function GetAsBytes: TBytes;
|
|
Function GetAsDateTime: TDateTime;
|
|
Function GetAsFloat: Double;
|
|
Function GetAsInteger: Longint;
|
|
Function GetAsLargeInt: NativeInt;
|
|
Function GetAsMemo: string;
|
|
Function GetAsString: string;
|
|
Function GetAsJSValue: JSValue;
|
|
Function GetDisplayName: string; override;
|
|
Function GetIsNull: Boolean;
|
|
Function IsEqual(AValue: TParam): Boolean;
|
|
Procedure SetAsBlob(const AValue: TBlobData);
|
|
Procedure SetAsBoolean(AValue: Boolean);
|
|
Procedure SetAsBytes(const AValue{%H-}: TBytes);
|
|
Procedure SetAsDate(const AValue: TDateTime);
|
|
Procedure SetAsDateTime(const AValue: TDateTime);
|
|
Procedure SetAsFloat(const AValue: Double);
|
|
Procedure SetAsInteger(AValue: Longint);
|
|
Procedure SetAsLargeInt(AValue: NativeInt);
|
|
Procedure SetAsMemo(const AValue: string);
|
|
Procedure SetAsString(const AValue: string);
|
|
Procedure SetAsTime(const AValue: TDateTime);
|
|
Procedure SetAsJSValue(const AValue: JSValue);
|
|
Procedure SetDataType(AValue: TFieldType);
|
|
Procedure SetText(const AValue: string);
|
|
public
|
|
constructor Create(ACollection: TCollection); overload; override;
|
|
constructor Create(AParams: TParams; AParamType: TParamType); reintroduce; overload;
|
|
Procedure Assign(Source: TPersistent); override;
|
|
Procedure AssignField(Field: TField);
|
|
Procedure AssignToField(Field: TField);
|
|
Procedure AssignFieldValue(Field: TField; const AValue: JSValue);
|
|
Procedure AssignFromField(Field : TField);
|
|
Procedure Clear;
|
|
Property AsBlob : TBlobData read GetAsBytes write SetAsBytes;
|
|
Property AsBoolean : Boolean read GetAsBoolean write SetAsBoolean;
|
|
Property AsBytes : TBytes read GetAsBytes write SetAsBytes;
|
|
Property AsDate : TDateTime read GetAsDateTime write SetAsDate;
|
|
Property AsDateTime : TDateTime read GetAsDateTime write SetAsDateTime;
|
|
Property AsFloat : Double read GetAsFloat write SetAsFloat;
|
|
Property AsInteger : LongInt read GetAsInteger write SetAsInteger;
|
|
Property AsLargeInt : NativeInt read GetAsLargeInt write SetAsLargeInt;
|
|
Property AsMemo : string read GetAsMemo write SetAsMemo;
|
|
Property AsSmallInt : LongInt read GetAsInteger write SetAsInteger;
|
|
Property AsString : string read GetAsString write SetAsString;
|
|
Property AsTime : TDateTime read GetAsDateTime write SetAsTime;
|
|
Property Bound : Boolean read FBound write FBound;
|
|
Property Dataset : TDataset Read GetDataset;
|
|
Property IsNull : Boolean read GetIsNull;
|
|
Property Text : string read GetAsString write SetText;
|
|
published
|
|
Property DataType : TFieldType read FDataType write SetDataType;
|
|
Property Name : string read FName write FName;
|
|
Property NumericScale : Integer read FNumericScale write FNumericScale default 0;
|
|
Property ParamType : TParamType read FParamType write FParamType;
|
|
Property Precision : Integer read FPrecision write FPrecision default 0;
|
|
Property Size : Integer read FSize write FSize default 0;
|
|
Property Value : JSValue read GetAsJSValue write SetAsJSValue stored IsParamStored;
|
|
end;
|
|
TParamClass = Class of TParam;
|
|
|
|
{ TParams }
|
|
|
|
TParams = class(TCollection)
|
|
private
|
|
FOwner: TPersistent;
|
|
Function GetItem(Index: Integer): TParam; reintroduce;
|
|
Function GetParamValue(const ParamName: string): JSValue;
|
|
Procedure SetItem(Index: Integer; Value: TParam); reintroduce;
|
|
Procedure SetParamValue(const ParamName: string; const Value: JSValue);
|
|
protected
|
|
Procedure AssignTo(Dest: TPersistent); override;
|
|
Function GetDataSet: TDataSet;
|
|
Function GetOwner: TPersistent; override;
|
|
Class Function ParamClass : TParamClass; virtual;
|
|
public
|
|
Constructor Create(AOwner: TPersistent; AItemClass : TCollectionItemClass); overload;
|
|
Constructor Create(AOwner: TPersistent); overload;
|
|
Constructor Create; overload; reintroduce;
|
|
Procedure AddParam(Value: TParam);
|
|
Procedure AssignValues(Value: TParams);
|
|
Function CreateParam(FldType: TFieldType; const ParamName: string; ParamType: TParamType): TParam;
|
|
Function FindParam(const Value: string): TParam;
|
|
Procedure GetParamList(List: TList; const ParamNames: string);
|
|
Function IsEqual(Value: TParams): Boolean;
|
|
Function ParamByName(const Value: string): TParam;
|
|
Function ParseSQL(SQL: String; DoCreate: Boolean): String; overload;
|
|
Function ParseSQL(SQL: String; DoCreate, EscapeSlash, EscapeRepeat : Boolean; ParameterStyle : TParamStyle): String; overload;
|
|
Function ParseSQL(SQL: String; DoCreate, EscapeSlash, EscapeRepeat : Boolean; ParameterStyle : TParamStyle; out ParamBinding: TParambinding): String; overload;
|
|
Function ParseSQL(SQL: String; DoCreate, EscapeSlash, EscapeRepeat : Boolean; ParameterStyle : TParamStyle; out ParamBinding: TParambinding; out ReplaceString : string): String; overload;
|
|
Procedure RemoveParam(Value: TParam);
|
|
Procedure CopyParamValuesFromDataset(ADataset : TDataset; CopyBound : Boolean);
|
|
Property Dataset : TDataset Read GetDataset;
|
|
Property Items[Index: Integer] : TParam read GetItem write SetItem; default;
|
|
Property ParamValues[const ParamName: string] : JSValue read GetParamValue write SetParamValue;
|
|
end;
|
|
|
|
{ TDataSet }
|
|
|
|
TBookmarkFlag = (bfCurrent, bfBOF, bfEOF, bfInserted);
|
|
TBookmark = record
|
|
Data : JSValue;
|
|
Flag : TBookmarkFlag;
|
|
end; // Bookmark is always the index in the data array.
|
|
TBookmarkStr = string; // JSON encoded version of the above
|
|
|
|
TGetMode = (gmCurrent, gmNext, gmPrior);
|
|
TGetResult = (grOK, grBOF, grEOF, grError);
|
|
|
|
TResyncMode = set of (rmExact, rmCenter);
|
|
TDataAction = (daFail, daAbort, daRetry);
|
|
TUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApplied);
|
|
TUpdateKind = (ukModify, ukInsert, ukDelete);
|
|
|
|
TLocateOption = (loCaseInsensitive, loPartialKey, loFromCurrent);
|
|
TLocateOptions = set of TLocateOption;
|
|
TDataOperation = procedure of object;
|
|
|
|
TDataSetNotifyEvent = procedure(DataSet: TDataSet) of object;
|
|
TDataSetErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError;
|
|
var DataAction: TDataAction) of object;
|
|
|
|
TFilterOption = (foCaseInsensitive, foNoPartialCompare);
|
|
TFilterOptions = set of TFilterOption;
|
|
|
|
TLoadOption = (loNoOpen,loNoEvents,loAtEOF,loCancelPending);
|
|
TLoadOptions = Set of TLoadOption;
|
|
TDatasetLoadEvent = procedure(DataSet: TDataSet; Data : JSValue) of object;
|
|
TDatasetLoadFailEvent = procedure(DataSet: TDataSet; ID : Integer; Const ErrorMsg : String) of object;
|
|
|
|
TFilterRecordEvent = procedure(DataSet: TDataSet;
|
|
var Accept: Boolean) of object;
|
|
TDatasetClass = Class of TDataset;
|
|
|
|
TRecordState = (rsNew,rsClean,rsUpdate,rsDelete);
|
|
TDataRecord = record
|
|
data : JSValue;
|
|
state : TRecordState;
|
|
bookmark : JSValue;
|
|
bookmarkFlag : TBookmarkFlag;
|
|
end;
|
|
TBuffers = Array of TDataRecord;
|
|
|
|
TResolveInfo = record
|
|
Data : JSValue;
|
|
Status : TUpdateStatus;
|
|
ResolveStatus : TResolveStatus;
|
|
Error : String; // Only filled on error.
|
|
BookMark : TBookmark;
|
|
_private : JSValue; // for use by descendents of TDataset
|
|
end;
|
|
TResolveInfoArray = Array of TResolveInfo;
|
|
|
|
// Record so we can extend later on
|
|
TResolveResults = record
|
|
Records : TResolveInfoArray;
|
|
end;
|
|
|
|
TOnRecordResolveEvent = Procedure (Sender : TDataset; info : TResolveInfo) of object;
|
|
TApplyUpdatesEvent = Procedure (Sender : TDataset; info : TResolveResults) of object;
|
|
|
|
TNestedDataSetsList = TFPList;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
|
|
TDataSet = class(TComponent)
|
|
Private
|
|
FAfterApplyUpdates: TApplyUpdatesEvent;
|
|
FAfterLoad: TDatasetNotifyEvent;
|
|
FBeforeApplyUpdates: TDatasetNotifyEvent;
|
|
FBeforeLoad: TDatasetNotifyEvent;
|
|
FBlockReadSize: Integer;
|
|
FCalcBuffer: TDataRecord;
|
|
FCalcFieldsCount: Longint;
|
|
FOnLoadFail: TDatasetLoadFailEvent;
|
|
FOnRecordResolved: TOnRecordResolveEvent;
|
|
FOpenAfterRead : boolean;
|
|
FActiveRecord: Longint;
|
|
FAfterCancel: TDataSetNotifyEvent;
|
|
FAfterClose: TDataSetNotifyEvent;
|
|
FAfterDelete: TDataSetNotifyEvent;
|
|
FAfterEdit: TDataSetNotifyEvent;
|
|
FAfterInsert: TDataSetNotifyEvent;
|
|
FAfterOpen: TDataSetNotifyEvent;
|
|
FAfterPost: TDataSetNotifyEvent;
|
|
FAfterRefresh: TDataSetNotifyEvent;
|
|
FAfterScroll: TDataSetNotifyEvent;
|
|
FAutoCalcFields: Boolean;
|
|
FBOF: Boolean;
|
|
FBeforeCancel: TDataSetNotifyEvent;
|
|
FBeforeClose: TDataSetNotifyEvent;
|
|
FBeforeDelete: TDataSetNotifyEvent;
|
|
FBeforeEdit: TDataSetNotifyEvent;
|
|
FBeforeInsert: TDataSetNotifyEvent;
|
|
FBeforeOpen: TDataSetNotifyEvent;
|
|
FBeforePost: TDataSetNotifyEvent;
|
|
FBeforeRefresh: TDataSetNotifyEvent;
|
|
FBeforeScroll: TDataSetNotifyEvent;
|
|
FBlobFieldCount: Longint;
|
|
FBuffers : TBuffers;
|
|
// The actual length of FBuffers is FBufferCount+1
|
|
FBufferCount: Longint;
|
|
FConstraints: TCheckConstraints;
|
|
FDisableControlsCount : Integer;
|
|
FDisableControlsState : TDatasetState;
|
|
FCurrentRecord: Longint;
|
|
FDataSources : TFPList;
|
|
FDefaultFields: Boolean;
|
|
FEOF: Boolean;
|
|
FEnableControlsEvent : TDataEvent;
|
|
FFieldList : TFields;
|
|
FFieldDefs: TFieldDefs;
|
|
FFilterOptions: TFilterOptions;
|
|
FFilterText: string;
|
|
FFiltered: Boolean;
|
|
FFound: Boolean;
|
|
FInternalCalcFields: Boolean;
|
|
FModified: Boolean;
|
|
FOnCalcFields: TDataSetNotifyEvent;
|
|
FOnDeleteError: TDataSetErrorEvent;
|
|
FOnEditError: TDataSetErrorEvent;
|
|
FOnFilterRecord: TFilterRecordEvent;
|
|
FOnNewRecord: TDataSetNotifyEvent;
|
|
FOnPostError: TDataSetErrorEvent;
|
|
FRecordCount: Longint;
|
|
FIsUniDirectional: Boolean;
|
|
FState : TDataSetState;
|
|
FInternalOpenComplete: Boolean;
|
|
FDataProxy : TDataProxy;
|
|
FDataRequestID : Integer;
|
|
FUpdateBatchID : Integer;
|
|
FChangeList : TFPList;
|
|
FBatchList : TFPList;
|
|
FInApplyupdates : Boolean;
|
|
FLoadCount : Integer;
|
|
FMinLoadID : Integer;
|
|
FDataSetField: TDataSetField;
|
|
FNestedDataSets: TNestedDataSetsList;
|
|
FNestedDataSetClass: TDataSetClass;
|
|
Procedure DoInsertAppend(DoAppend : Boolean);
|
|
Procedure DoInternalOpen;
|
|
Function GetBuffer (Index : longint) : TDataRecord;
|
|
function GetDataProxy: TDataProxy;
|
|
function GetIsLoading: Boolean;
|
|
Procedure RegisterDataSource(ADataSource : TDataSource);
|
|
procedure SetConstraints(Value: TCheckConstraints);
|
|
procedure SetDataProxy(AValue: TDataProxy);
|
|
Procedure ShiftBuffersForward;
|
|
Procedure ShiftBuffersBackward;
|
|
Function TryDoing (P : TDataOperation; Ev : TDatasetErrorEvent) : Boolean;
|
|
Function GetActive : boolean;
|
|
Procedure UnRegisterDataSource(ADataSource : TDataSource);
|
|
procedure SetBlockReadSize(AValue: Integer); virtual;
|
|
Procedure SetFieldDefs(AFieldDefs: TFieldDefs);
|
|
procedure DoInsertAppendRecord(const Values: array of jsValue; DoAppend : boolean);
|
|
// Callback for Tdataproxy.DoGetData;
|
|
function ResolveRecordUpdate(anUpdate: TRecordUpdateDescriptor): Boolean;
|
|
procedure HandleRequestResponse(ARequest: TDataRequest);
|
|
function GetNestedDataSets: TNestedDataSetsList;
|
|
protected
|
|
// Proxy methods
|
|
// Override this to integrate package in local data
|
|
// call OnRecordResolved
|
|
procedure DoOnRecordResolved(anUpdate: TRecordUpdateDescriptor); virtual;
|
|
// Convert TRecordUpdateDescriptor to ResolveInfo
|
|
function RecordUpdateDescriptorToResolveInfo(anUpdate: TRecordUpdateDescriptor): TResolveInfo; virtual;
|
|
function DoResolveRecordUpdate(anUpdate{%H-}: TRecordUpdateDescriptor): Boolean; virtual;
|
|
Function GetRecordUpdates(AList: TRecordUpdateDescriptorList) : Integer; virtual;
|
|
procedure ResolveUpdateBatch(Sender: TObject; aBatch: TRecordUpdateBatch); virtual;
|
|
Function DataPacketReceived(ARequest{%H-}: TDataRequest) : Boolean; virtual;
|
|
function DoLoad(aOptions: TLoadOptions; aAfterLoad: TDatasetLoadEvent): Boolean; virtual;
|
|
function DoGetDataProxy: TDataProxy; virtual;
|
|
Procedure InitChangeList; virtual;
|
|
Procedure DoneChangeList; virtual;
|
|
Procedure ClearChangeList;
|
|
procedure ResetUpdateDescriptors;
|
|
function GetApplyUpdateData(aBuffer: TDataRecord) : JSValue; virtual;
|
|
Function IndexInChangeList(aBookmark: TBookmark): Integer; virtual;
|
|
Function AddToChangeList(aChange : TUpdateStatus) : TRecordUpdateDescriptor ; virtual;
|
|
Procedure RemoveFromChangeList(R : TRecordUpdateDescriptor); virtual;
|
|
Procedure DoApplyUpdates;
|
|
procedure RecalcBufListSize;
|
|
procedure ActivateBuffers; virtual;
|
|
procedure BindFields(Binding: Boolean);
|
|
procedure BlockReadNext; virtual;
|
|
function BookmarkAvailable: Boolean;
|
|
procedure CalculateFields(Var Buffer: TDataRecord); virtual;
|
|
procedure CheckActive; virtual;
|
|
procedure CheckInactive; virtual;
|
|
procedure CheckBiDirectional;
|
|
procedure Loaded; override;
|
|
procedure ClearBuffers; virtual;
|
|
procedure ClearCalcFields(var Buffer{%H-}: TDataRecord); virtual;
|
|
procedure CloseBlob(Field{%H-}: TField); virtual;
|
|
procedure CloseCursor; virtual;
|
|
procedure CreateFields; virtual;
|
|
procedure DataEvent(Event: TDataEvent; Info: JSValue); virtual;
|
|
procedure DestroyFields; virtual;
|
|
procedure DoAfterCancel; virtual;
|
|
procedure DoAfterClose; virtual;
|
|
procedure DoAfterDelete; virtual;
|
|
procedure DoAfterEdit; virtual;
|
|
procedure DoAfterInsert; virtual;
|
|
procedure DoAfterOpen; virtual;
|
|
procedure DoAfterPost; virtual;
|
|
procedure DoAfterScroll; virtual;
|
|
procedure DoAfterRefresh; virtual;
|
|
procedure DoBeforeCancel; virtual;
|
|
procedure DoBeforeClose; virtual;
|
|
procedure DoBeforeDelete; virtual;
|
|
procedure DoBeforeEdit; virtual;
|
|
procedure DoBeforeInsert; virtual;
|
|
procedure DoBeforeOpen; virtual;
|
|
procedure DoBeforePost; virtual;
|
|
procedure DoBeforeScroll; virtual;
|
|
procedure DoBeforeRefresh; virtual;
|
|
procedure DoOnCalcFields; virtual;
|
|
procedure DoOnNewRecord; virtual;
|
|
procedure DoBeforeLoad; virtual;
|
|
procedure DoAfterLoad; virtual;
|
|
procedure DoBeforeApplyUpdates; virtual;
|
|
procedure DoAfterApplyUpdates(const ResolveInfo: TResolveResults); virtual;
|
|
function FieldByNumber(FieldNo: Longint): TField;
|
|
function FindRecord(Restart{%H-}, GoForward{%H-}: Boolean): Boolean; virtual;
|
|
function GetBookmarkStr: TBookmarkStr; virtual;
|
|
procedure GetCalcFields(Var Buffer: TDataRecord); virtual;
|
|
function GetCanModify: Boolean; virtual;
|
|
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
|
|
function GetFieldClass(FieldType: TFieldType): TFieldClass; virtual;
|
|
Function GetfieldCount : Integer;
|
|
function GetFieldValues(const FieldName : string) : JSValue; virtual;
|
|
function GetIsIndexField(Field{%H-}: TField): Boolean; virtual;
|
|
function GetIndexDefs(IndexDefs : TIndexDefs; IndexTypes : TIndexOptions) : TIndexDefs;
|
|
function GetNextRecords: Longint; virtual;
|
|
function GetNextRecord: Boolean; virtual;
|
|
function GetPriorRecords: Longint; virtual;
|
|
function GetPriorRecord: Boolean; virtual;
|
|
function GetRecordCount: Longint; virtual;
|
|
function GetRecNo: Longint; virtual;
|
|
procedure InitFieldDefs; virtual;
|
|
procedure InitFieldDefsFromfields;
|
|
procedure InitRecord(var Buffer: TDataRecord); virtual;
|
|
procedure InternalCancel; virtual;
|
|
procedure InternalEdit; virtual;
|
|
procedure InternalInsert; virtual;
|
|
procedure InternalRefresh; virtual;
|
|
procedure OpenCursor(InfoQuery: Boolean); virtual;
|
|
procedure OpenCursorcomplete; virtual;
|
|
procedure RefreshInternalCalcFields(Var Buffer{%H-}: TDataRecord); virtual;
|
|
procedure RestoreState(const Value: TDataSetState);
|
|
Procedure SetActive (Value : Boolean); virtual;
|
|
procedure SetBookmarkStr(const Value: TBookmarkStr); virtual;
|
|
procedure SetBufListSize(Value: Longint); virtual;
|
|
procedure SetChildOrder(Child: TComponent; Order: Longint); override;
|
|
procedure SetCurrentRecord(Index: Longint); virtual;
|
|
procedure SetDefaultFields(const Value: Boolean);
|
|
procedure SetFiltered(Value: Boolean); virtual;
|
|
procedure SetFilterOptions(Value: TFilterOptions); virtual;
|
|
procedure SetFilterText(const Value: string); virtual;
|
|
procedure SetFieldValues(const FieldName: string; Value: JSValue); virtual;
|
|
procedure SetFound(const Value: Boolean); virtual;
|
|
procedure SetModified(Value: Boolean);
|
|
procedure SetName(const NewName: TComponentName); override;
|
|
procedure SetOnFilterRecord(const Value: TFilterRecordEvent); virtual;
|
|
procedure SetRecNo(Value{%H-}: Longint); virtual;
|
|
procedure SetState(Value: TDataSetState);
|
|
function SetTempState(const Value: TDataSetState): TDataSetState;
|
|
Function TempBuffer: TDataRecord;
|
|
procedure UpdateIndexDefs; virtual;
|
|
property ActiveRecord: Longint read FActiveRecord;
|
|
property CurrentRecord: Longint read FCurrentRecord;
|
|
property BlobFieldCount: Longint read FBlobFieldCount;
|
|
property Buffers[Index: Longint]: TDataRecord read GetBuffer;
|
|
property BufferCount: Longint read FBufferCount;
|
|
property CalcBuffer: TDataRecord read FCalcBuffer;
|
|
property CalcFieldsCount: Longint read FCalcFieldsCount;
|
|
property InternalCalcFields: Boolean read FInternalCalcFields;
|
|
property Constraints: TCheckConstraints read FConstraints write SetConstraints;
|
|
function AllocRecordBuffer: TDataRecord; virtual;
|
|
procedure FreeRecordBuffer(var Buffer{%H-}: TDataRecord); virtual;
|
|
procedure GetBookmarkData(Buffer{%H-}: TDataRecord; var Data{%H-}: TBookmark); virtual;
|
|
function GetBookmarkFlag(Buffer{%H-}: TDataRecord): TBookmarkFlag; virtual;
|
|
function GetDataSource: TDataSource; virtual;
|
|
function GetRecordSize: Word; virtual;
|
|
procedure InternalAddRecord(Buffer{%H-}: Pointer; AAppend{%H-}: Boolean); virtual;
|
|
procedure InternalDelete; virtual;
|
|
procedure InternalFirst; virtual;
|
|
procedure InternalGotoBookmark(ABookmark{%H-}: TBookmark); virtual;
|
|
procedure InternalHandleException(E: Exception); virtual;
|
|
procedure InternalInitRecord(var Buffer{%H-}: TDataRecord); virtual;
|
|
procedure InternalLast; virtual;
|
|
procedure InternalPost; virtual;
|
|
procedure InternalSetToRecord(Buffer{%H-}: TDataRecord); virtual;
|
|
procedure SetBookmarkFlag(Var Buffer{%H-}: TDataRecord; Value{%H-}: TBookmarkFlag); virtual;
|
|
procedure SetBookmarkData(Var Buffer{%H-}: TDataRecord; Data{%H-}: TBookmark); virtual;
|
|
procedure SetUniDirectional(const Value: Boolean);
|
|
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
|
procedure SetDataSetField(const Value: TDataSetField); virtual;
|
|
// These use the active buffer
|
|
function GetFieldData(Field: TField): JSValue; virtual; overload;
|
|
procedure SetFieldData(Field: TField; AValue : JSValue); virtual; overload;
|
|
function GetFieldData(Field: TField; Buffer: TDatarecord): JSValue; virtual; overload;
|
|
procedure SetFieldData(Field: TField; var Buffer: TDatarecord; AValue : JSValue); virtual; overload;
|
|
class function FieldDefsClass : TFieldDefsClass; virtual;
|
|
class function FieldsClass : TFieldsClass; virtual;
|
|
property NestedDataSets: TNestedDataSetsList read GetNestedDataSets;
|
|
protected { abstract methods }
|
|
function GetRecord(var Buffer: TDataRecord; GetMode: TGetMode; DoCheck: Boolean): TGetResult; virtual; abstract;
|
|
procedure InternalClose; virtual; abstract;
|
|
procedure InternalOpen; virtual; abstract;
|
|
procedure InternalInitFieldDefs; virtual; abstract;
|
|
function IsCursorOpen: Boolean; virtual; abstract;
|
|
property DataProxy : TDataProxy Read GetDataProxy Write SetDataProxy;
|
|
Property LoadCount : Integer Read FLoadCount;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
function ActiveBuffer: TDataRecord;
|
|
procedure Append;
|
|
procedure AppendRecord(const Values: array of jsValue);
|
|
function BookmarkValid(ABookmark{%H-}: TBookmark): Boolean; virtual;
|
|
function ConvertToDateTime(aField : TField; aValue : JSValue; ARaiseException : Boolean) : TDateTime; virtual;
|
|
function ConvertDateTimeToNative(aField : TField; aValue : TDateTime) : JSValue; virtual;
|
|
Class function DefaultConvertToDateTime(aField : TField; aValue : JSValue; ARaiseException{%H-} : Boolean) : TDateTime; virtual;
|
|
Class function DefaultConvertDateTimeToNative(aField : TField; aValue : TDateTime) : JSValue; virtual;
|
|
Function BlobDataToBytes(aValue : JSValue) : TBytes; virtual;
|
|
Class Function DefaultBlobDataToBytes(aValue : JSValue) : TBytes; virtual;
|
|
Function BytesToBlobData(aValue : TBytes) : JSValue ; virtual;
|
|
Class Function DefaultBytesToBlobData(aValue : TBytes) : JSValue; virtual;
|
|
procedure Cancel; virtual;
|
|
procedure CheckBrowseMode;
|
|
procedure ClearFields;
|
|
procedure Close;
|
|
Procedure ApplyUpdates;
|
|
function ControlsDisabled: Boolean;
|
|
function CompareBookmarks(Bookmark1{%H-}, Bookmark2{%H-}: TBookmark): Longint; virtual;
|
|
procedure CursorPosChanged;
|
|
procedure Delete; virtual;
|
|
procedure DisableControls;
|
|
procedure Edit;
|
|
procedure EnableControls;
|
|
function FieldByName(const FieldName: string): TField;
|
|
function FindField(const FieldName: string): TField;
|
|
function FindFirst: Boolean; virtual;
|
|
function FindLast: Boolean; virtual;
|
|
function FindNext: Boolean; virtual;
|
|
function FindPrior: Boolean; virtual;
|
|
procedure First;
|
|
procedure FreeBookmark(ABookmark{%H-}: TBookmark); virtual;
|
|
function GetBookmark: TBookmark; virtual;
|
|
function GetCurrentRecord(Buffer{%H-}: TDataRecord): Boolean; virtual;
|
|
procedure GetFieldList(List: TList; const FieldNames: string); overload;
|
|
procedure GetFieldList(List: TFPList; const FieldNames: string); overload;
|
|
procedure GetFieldNames(List: TStrings);
|
|
procedure GotoBookmark(const ABookmark: TBookmark);
|
|
procedure Insert; reintroduce;
|
|
procedure InsertRecord(const Values: array of JSValue);
|
|
function IsEmpty: Boolean;
|
|
function IsLinkedTo(ADataSource: TDataSource): Boolean;
|
|
function IsSequenced: Boolean; virtual;
|
|
procedure Last;
|
|
Function Load(aOptions : TLoadOptions; aAfterLoad : TDatasetLoadEvent) : Boolean;
|
|
function Locate(const KeyFields{%H-}: string; const KeyValues{%H-}: JSValue; Options{%H-}: TLocateOptions) : boolean; virtual;
|
|
function Lookup(const KeyFields{%H-}: string; const KeyValues{%H-}: JSValue; const ResultFields{%H-}: string): JSValue; virtual;
|
|
function MoveBy(Distance: Longint): Longint;
|
|
procedure Next;
|
|
procedure Open;
|
|
procedure Post; virtual;
|
|
procedure Prior;
|
|
procedure Refresh;
|
|
procedure Resync(Mode: TResyncMode); virtual;
|
|
Procedure CancelLoading;
|
|
procedure SetFields(const Values: array of JSValue);
|
|
procedure UpdateCursorPos;
|
|
procedure UpdateRecord;
|
|
Function GetPendingUpdates : TResolveInfoArray;
|
|
property DataSetField: TDataSetField read FDataSetField write SetDataSetField;
|
|
Property Loading : Boolean Read GetIsLoading;
|
|
property BlockReadSize: Integer read FBlockReadSize write SetBlockReadSize;
|
|
property BOF: Boolean read FBOF;
|
|
property Bookmark: TBookmark read GetBookmark write GotoBookmark;
|
|
property CanModify: Boolean read GetCanModify;
|
|
property DataSource: TDataSource read GetDataSource;
|
|
property DefaultFields: Boolean read FDefaultFields;
|
|
property EOF: Boolean read FEOF;
|
|
property FieldCount: Longint read GetFieldCount;
|
|
property FieldDefs: TFieldDefs read FFieldDefs write SetFieldDefs;
|
|
property Found: Boolean read FFound;
|
|
property Modified: Boolean read FModified;
|
|
property IsUniDirectional: Boolean read FIsUniDirectional default False;
|
|
property RecordCount: Longint read GetRecordCount;
|
|
property RecNo: Longint read GetRecNo write SetRecNo;
|
|
property RecordSize: Word read GetRecordSize;
|
|
property State: TDataSetState read FState;
|
|
property Fields : TFields read FFieldList;
|
|
property FieldValues[const FieldName : string] : JSValue read GetFieldValues write SetFieldValues; default;
|
|
property Filter: string read FFilterText write SetFilterText;
|
|
property Filtered: Boolean read FFiltered write SetFiltered default False;
|
|
property FilterOptions: TFilterOptions read FFilterOptions write SetFilterOptions;
|
|
property Active: Boolean read GetActive write SetActive default False;
|
|
property AutoCalcFields: Boolean read FAutoCalcFields write FAutoCalcFields default true;
|
|
property BeforeOpen: TDataSetNotifyEvent read FBeforeOpen write FBeforeOpen;
|
|
property AfterOpen: TDataSetNotifyEvent read FAfterOpen write FAfterOpen;
|
|
property BeforeClose: TDataSetNotifyEvent read FBeforeClose write FBeforeClose;
|
|
property AfterClose: TDataSetNotifyEvent read FAfterClose write FAfterClose;
|
|
property BeforeInsert: TDataSetNotifyEvent read FBeforeInsert write FBeforeInsert;
|
|
property AfterInsert: TDataSetNotifyEvent read FAfterInsert write FAfterInsert;
|
|
property BeforeEdit: TDataSetNotifyEvent read FBeforeEdit write FBeforeEdit;
|
|
property AfterEdit: TDataSetNotifyEvent read FAfterEdit write FAfterEdit;
|
|
property BeforePost: TDataSetNotifyEvent read FBeforePost write FBeforePost;
|
|
property AfterPost: TDataSetNotifyEvent read FAfterPost write FAfterPost;
|
|
property BeforeCancel: TDataSetNotifyEvent read FBeforeCancel write FBeforeCancel;
|
|
property AfterCancel: TDataSetNotifyEvent read FAfterCancel write FAfterCancel;
|
|
property BeforeDelete: TDataSetNotifyEvent read FBeforeDelete write FBeforeDelete;
|
|
property AfterDelete: TDataSetNotifyEvent read FAfterDelete write FAfterDelete;
|
|
property BeforeScroll: TDataSetNotifyEvent read FBeforeScroll write FBeforeScroll;
|
|
property AfterScroll: TDataSetNotifyEvent read FAfterScroll write FAfterScroll;
|
|
property BeforeRefresh: TDataSetNotifyEvent read FBeforeRefresh write FBeforeRefresh;
|
|
property BeforeLoad : TDatasetNotifyEvent Read FBeforeLoad Write FBeforeLoad;
|
|
Property AfterLoad : TDatasetNotifyEvent Read FAfterLoad Write FAfterLoad;
|
|
Property BeforeApplyUpdates : TDatasetNotifyEvent Read FBeforeApplyUpdates Write FBeforeApplyUpdates;
|
|
Property AfterApplyUpdates : TApplyUpdatesEvent Read FAfterApplyUpdates Write FAfterApplyUpdates;
|
|
property AfterRefresh: TDataSetNotifyEvent read FAfterRefresh write FAfterRefresh;
|
|
property OnCalcFields: TDataSetNotifyEvent read FOnCalcFields write FOnCalcFields;
|
|
property OnDeleteError: TDataSetErrorEvent read FOnDeleteError write FOnDeleteError;
|
|
property OnEditError: TDataSetErrorEvent read FOnEditError write FOnEditError;
|
|
property OnFilterRecord: TFilterRecordEvent read FOnFilterRecord write SetOnFilterRecord;
|
|
property OnNewRecord: TDataSetNotifyEvent read FOnNewRecord write FOnNewRecord;
|
|
Property OnRecordResolved : TOnRecordResolveEvent Read FOnRecordResolved Write FOnRecordResolved;
|
|
property OnPostError: TDataSetErrorEvent read FOnPostError write FOnPostError;
|
|
property OnLoadFail : TDatasetLoadFailEvent Read FOnLoadFail Write FOnLoadFail;
|
|
end;
|
|
|
|
{ TDataLink }
|
|
|
|
TDataLink = class(TPersistent)
|
|
private
|
|
FFirstRecord,
|
|
FBufferCount : Integer;
|
|
FActive,
|
|
FDataSourceFixed,
|
|
FEditing,
|
|
FReadOnly,
|
|
FUpdatingRecord,
|
|
FVisualControl : Boolean;
|
|
FDataSource : TDataSource;
|
|
Function CalcFirstRecord(Index : Integer) : Integer;
|
|
Procedure CalcRange;
|
|
Procedure CheckActiveAndEditing;
|
|
Function GetDataset : TDataset;
|
|
procedure SetActive(AActive: Boolean);
|
|
procedure SetDataSource(Value: TDataSource);
|
|
Procedure SetReadOnly(Value : Boolean);
|
|
protected
|
|
procedure ActiveChanged; virtual;
|
|
procedure CheckBrowseMode; virtual;
|
|
procedure DataEvent(Event: TDataEvent; Info: JSValue); virtual;
|
|
procedure DataSetChanged; virtual;
|
|
procedure DataSetScrolled(Distance{%H-}: Integer); virtual;
|
|
procedure EditingChanged; virtual;
|
|
procedure FocusControl(Field{%H-}: JSValue); virtual;
|
|
function GetActiveRecord: Integer; virtual;
|
|
function GetBOF: Boolean; virtual;
|
|
function GetBufferCount: Integer; virtual;
|
|
function GetEOF: Boolean; virtual;
|
|
function GetRecordCount: Integer; virtual;
|
|
procedure LayoutChanged; virtual;
|
|
function MoveBy(Distance: Integer): Integer; virtual;
|
|
procedure RecordChanged(Field{%H-}: TField); virtual;
|
|
procedure SetActiveRecord(Value: Integer); virtual;
|
|
procedure SetBufferCount(Value: Integer); virtual;
|
|
procedure UpdateData; virtual;
|
|
property VisualControl: Boolean read FVisualControl write FVisualControl;
|
|
property FirstRecord: Integer read FFirstRecord write FFirstRecord;
|
|
public
|
|
constructor Create; reintroduce;
|
|
destructor Destroy; override;
|
|
function Edit: Boolean;
|
|
procedure UpdateRecord;
|
|
property Active: Boolean read FActive;
|
|
property ActiveRecord: Integer read GetActiveRecord write SetActiveRecord;
|
|
property BOF: Boolean read GetBOF;
|
|
property BufferCount: Integer read GetBufferCount write SetBufferCount;
|
|
property DataSet: TDataSet read GetDataSet;
|
|
property DataSource: TDataSource read FDataSource write SetDataSource;
|
|
property DataSourceFixed: Boolean read FDataSourceFixed write FDataSourceFixed;
|
|
property Editing: Boolean read FEditing;
|
|
property Eof: Boolean read GetEOF;
|
|
property ReadOnly: Boolean read FReadOnly write SetReadOnly;
|
|
property RecordCount: Integer read GetRecordCount;
|
|
end;
|
|
|
|
{ TDetailDataLink }
|
|
|
|
TDetailDataLink = class(TDataLink)
|
|
protected
|
|
function GetDetailDataSet: TDataSet; virtual;
|
|
public
|
|
property DetailDataSet: TDataSet read GetDetailDataSet;
|
|
end;
|
|
|
|
{ TMasterDataLink }
|
|
|
|
TMasterDataLink = class(TDetailDataLink)
|
|
private
|
|
FDetailDataSet: TDataSet;
|
|
FFieldNames: string;
|
|
FFields: TList;
|
|
FOnMasterChange: TNotifyEvent;
|
|
FOnMasterDisable: TNotifyEvent;
|
|
procedure SetFieldNames(const Value: string);
|
|
protected
|
|
procedure ActiveChanged; override;
|
|
procedure CheckBrowseMode; override;
|
|
function GetDetailDataSet: TDataSet; override;
|
|
procedure LayoutChanged; override;
|
|
procedure RecordChanged(Field: TField); override;
|
|
Procedure DoMasterDisable; virtual;
|
|
Procedure DoMasterChange; virtual;
|
|
public
|
|
constructor Create(ADataSet: TDataSet);virtual; reintroduce;
|
|
destructor Destroy; override;
|
|
property FieldNames: string read FFieldNames write SetFieldNames;
|
|
property Fields: TList read FFields;
|
|
property OnMasterChange: TNotifyEvent read FOnMasterChange write FOnMasterChange;
|
|
property OnMasterDisable: TNotifyEvent read FOnMasterDisable write FOnMasterDisable;
|
|
end;
|
|
|
|
{ TMasterParamsDataLink }
|
|
|
|
TMasterParamsDataLink = Class(TMasterDataLink)
|
|
Private
|
|
FParams : TParams;
|
|
Procedure SetParams(AValue : TParams);
|
|
Protected
|
|
Procedure DoMasterDisable; override;
|
|
Procedure DoMasterChange; override;
|
|
Public
|
|
constructor Create(ADataSet: TDataSet); override;
|
|
Procedure RefreshParamNames; virtual;
|
|
Procedure CopyParamsFromMaster(CopyBound : Boolean); virtual;
|
|
Property Params : TParams Read FParams Write SetParams;
|
|
end;
|
|
|
|
{ TDataSource }
|
|
|
|
TDataChangeEvent = procedure(Sender: TObject; Field: TField) of object;
|
|
|
|
TDataSource = class(TComponent)
|
|
private
|
|
FDataSet: TDataSet;
|
|
FDataLinks: TList;
|
|
FEnabled: Boolean;
|
|
FAutoEdit: Boolean;
|
|
FState: TDataSetState;
|
|
FOnStateChange: TNotifyEvent;
|
|
FOnDataChange: TDataChangeEvent;
|
|
FOnUpdateData: TNotifyEvent;
|
|
procedure DistributeEvent(Event: TDataEvent; Info: JSValue);
|
|
procedure RegisterDataLink(DataLink: TDataLink);
|
|
Procedure ProcessEvent(Event : TDataEvent; Info : JSValue);
|
|
procedure SetDataSet(ADataSet: TDataSet);
|
|
procedure SetEnabled(Value: Boolean);
|
|
procedure UnregisterDataLink(DataLink: TDataLink);
|
|
protected
|
|
Procedure DoDataChange (Info : Pointer);virtual;
|
|
Procedure DoStateChange; virtual;
|
|
Procedure DoUpdateData;
|
|
property DataLinks: TList read FDataLinks;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure Edit;
|
|
function IsLinkedTo(ADataSet{%H-}: TDataSet): Boolean;
|
|
property State: TDataSetState read FState;
|
|
published
|
|
property AutoEdit: Boolean read FAutoEdit write FAutoEdit default True;
|
|
property DataSet: TDataSet read FDataSet write SetDataSet;
|
|
property Enabled: Boolean read FEnabled write SetEnabled default True;
|
|
property OnStateChange: TNotifyEvent read FOnStateChange write FOnStateChange;
|
|
property OnDataChange: TDataChangeEvent read FOnDataChange write FOnDataChange;
|
|
property OnUpdateData: TNotifyEvent read FOnUpdateData write FOnUpdateData;
|
|
end;
|
|
|
|
|
|
{ TDataRequest }
|
|
TDataRequestResult = (rrFail,rrEOF,rrOK);
|
|
TDataRequestEvent = Procedure (ARequest : TDataRequest) of object;
|
|
|
|
TDataRequest = Class(TObject)
|
|
private
|
|
FBookmark: TBookMark;
|
|
FCurrent: TBookMark;
|
|
FDataset: TDataset;
|
|
FErrorMsg: String;
|
|
FEvent: TDatasetLoadEvent;
|
|
FLoadOptions: TLoadOptions;
|
|
FRequestID: Integer;
|
|
FSuccess: TDataRequestResult;
|
|
FData : JSValue;
|
|
FAfterRequest : TDataRequestEvent;
|
|
FDataProxy : TDataProxy;
|
|
Protected
|
|
Procedure DoAfterRequest;
|
|
Public
|
|
Constructor Create(aDataProxy : TDataProxy; aOptions: TLoadOptions; aAfterRequest: TDataRequestEvent; aAfterLoad: TDatasetLoadEvent); virtual; reintroduce;
|
|
property DataProxy : TDataProxy Read FDataProxy;
|
|
Property Dataset : TDataset Read FDataset;
|
|
Property Bookmark : TBookMark Read FBookmark;
|
|
Property RequestID : Integer Read FRequestID;
|
|
Property LoadOptions : TLoadOptions Read FLoadOptions;
|
|
Property Current : TBookMark Read FCurrent;
|
|
Property Success : TDataRequestResult Read FSuccess Write FSuccess;
|
|
Property Event : TDatasetLoadEvent Read FEvent;
|
|
Property ErrorMsg : String Read FErrorMsg Write FErrorMsg;
|
|
Property Data : JSValue read FData Write FData;
|
|
end;
|
|
TDataRequestClass = Class of TDataRequest;
|
|
|
|
{ TRecordUpdateDescriptor }
|
|
|
|
TRecordUpdateDescriptor = Class(TObject)
|
|
private
|
|
FBookmark: TBookmark;
|
|
FData: JSValue;
|
|
FDataset: TDataset;
|
|
FProxy: TDataProxy;
|
|
FResolveStatus: TResolveStatus;
|
|
FResolveError: String;
|
|
FServerData: JSValue;
|
|
FStatus: TUpdateStatus;
|
|
Protected
|
|
Procedure SetResolveStatus(aValue : TResolveStatus); virtual;
|
|
Procedure Reset;
|
|
Public
|
|
Constructor Create(aProxy : TDataProxy; aDataset : TDataset; aBookmark : TBookMark; AData : JSValue; AStatus : TUpdateStatus); reintroduce;
|
|
Procedure Resolve(aData : JSValue);
|
|
Procedure ResolveFailed(aError : String);
|
|
Property Proxy : TDataProxy read FProxy;
|
|
Property Dataset : TDataset Read FDataset;
|
|
Property OriginalStatus : TUpdateStatus Read FStatus; deprecated;
|
|
Property Status : TUpdateStatus Read FStatus;
|
|
Property ResolveStatus : TResolveStatus Read FResolveStatus;
|
|
Property ServerData : JSValue Read FServerData;
|
|
Property Data : JSValue Read FData;
|
|
Property Bookmark : TBookmark Read FBookmark;
|
|
Property ResolveError : String Read FResolveError ;
|
|
end;
|
|
TRecordUpdateDescriptorClass = Class of TRecordUpdateDescriptor;
|
|
|
|
{ TRecordUpdateDescriptorList }
|
|
|
|
TRecordUpdateDescriptorList = Class(TFPList)
|
|
private
|
|
function GetUpdate(AIndex : Integer): TRecordUpdateDescriptor;
|
|
Public
|
|
Property UpdateDescriptors[AIndex : Integer] : TRecordUpdateDescriptor Read GetUpdate; Default;
|
|
end;
|
|
|
|
{ TRecordUpdateBatch }
|
|
TUpdateBatchStatus = (ubsPending,ubsProcessing,ubsProcessed,ubsResolved);
|
|
TResolveBatchEvent = Procedure (Sender : TObject; ARequest : TRecordUpdateBatch) of object;
|
|
|
|
TRecordUpdateBatch = class(TObject)
|
|
private
|
|
FBatchID: Integer;
|
|
FDataset: TDataset;
|
|
FLastChangeIndex: Integer;
|
|
FList: TRecordUpdateDescriptorList;
|
|
FOnResolve: TResolveBatchEvent;
|
|
FOwnsList: Boolean;
|
|
FStatus: TUpdateBatchStatus;
|
|
Protected
|
|
Property LastChangeIndex : Integer Read FLastChangeIndex;
|
|
Public
|
|
Constructor Create (aBatchID : Integer; AList : TRecordUpdateDescriptorList; AOwnsList : Boolean); reintroduce;
|
|
Destructor Destroy; override;
|
|
Procedure FreeList;
|
|
Property Dataset : TDataset Read FDataset Write FDataset;
|
|
Property OnResolve : TResolveBatchEvent Read FOnResolve Write FOnResolve;
|
|
Property OwnsList : Boolean Read FOwnsList;
|
|
property BatchID : Integer Read FBatchID;
|
|
Property Status : TUpdateBatchStatus Read FStatus Write FStatus;
|
|
Property List : TRecordUpdateDescriptorList Read FList;
|
|
end;
|
|
TRecordUpdateBatchClass = Class of TRecordUpdateBatch;
|
|
|
|
{ TDataProxy }
|
|
|
|
TDataProxy = Class(TComponent)
|
|
Protected
|
|
Function GetDataRequestClass : TDataRequestClass; virtual;
|
|
Function GetUpdateDescriptorClass : TRecordUpdateDescriptorClass; virtual;
|
|
Function GetUpdateBatchClass : TRecordUpdateBatchClass; virtual;
|
|
// Use this to call resolve event, and free the batch.
|
|
Procedure ResolveBatch(aBatch : TRecordUpdateBatch);
|
|
Public
|
|
Function GetDataRequest(aOptions: TLoadOptions; aAfterRequest: TDataRequestEvent; aAfterLoad: TDatasetLoadEvent) : TDataRequest; virtual;
|
|
Function GetUpdateDescriptor(aDataset : TDataset; aBookmark : TBookMark; AData : JSValue; AStatus : TUpdateStatus) : TRecordUpdateDescriptor; virtual;
|
|
function GetRecordUpdateBatch(aBatchID: Integer; AList: TRecordUpdateDescriptorList; AOwnsList: Boolean=True): TRecordUpdateBatch; virtual;
|
|
// actual calls to do the work. Dataset wi
|
|
Function DoGetData(aRequest : TDataRequest) : Boolean; virtual; abstract;
|
|
// TDataProxy is responsible for calling OnResolve and if not, Freeing the batch.
|
|
Function ProcessUpdateBatch(aBatch : TRecordUpdateBatch): Boolean; virtual; abstract;
|
|
end;
|
|
|
|
const
|
|
{
|
|
TFieldType = (
|
|
ftUnknown, ftString, ftInteger, ftLargeInt, ftBoolean, ftFloat, ftDate,
|
|
ftTime, ftDateTime, ftAutoInc, ftBlob, ftMemo, ftFixedChar,
|
|
ftVariant
|
|
);
|
|
}
|
|
|
|
Const
|
|
Fieldtypenames : Array [TFieldType] of String =
|
|
(
|
|
{ftUnknown} 'Unknown',
|
|
{ftString} 'String',
|
|
{ftInteger} 'Integer',
|
|
{ftLargeint} 'NativeInt',
|
|
{ftBoolean} 'Boolean',
|
|
{ftFloat} 'Float',
|
|
{ftDate} 'Date',
|
|
{ftTime} 'Time',
|
|
{ftDateTime} 'DateTime',
|
|
{ftAutoInc} 'AutoInc',
|
|
{ftBlob} 'Blob',
|
|
{ftMemo} 'Memo',
|
|
{ftFixedChar} 'FixedChar',
|
|
{ftVariant} 'Variant',
|
|
{ftDataset} 'Dataset'
|
|
);
|
|
|
|
DefaultFieldClasses : Array [TFieldType] of TFieldClass =
|
|
(
|
|
{ ftUnknown} Tfield,
|
|
{ ftString} TStringField,
|
|
{ ftInteger} TIntegerField,
|
|
{ ftLargeint} TLargeIntField,
|
|
{ ftBoolean} TBooleanField,
|
|
{ ftFloat} TFloatField,
|
|
{ ftDate} TDateField,
|
|
{ ftTime} TTimeField,
|
|
{ ftDateTime} TDateTimeField,
|
|
{ ftAutoInc} TAutoIncField,
|
|
{ ftBlob} TBlobField,
|
|
{ ftMemo} TMemoField,
|
|
{ ftFixedChar} TStringField,
|
|
{ ftVariant} TVariantField,
|
|
{ ftDataset} Nil
|
|
);
|
|
|
|
dsEditModes = [dsEdit, dsInsert, dsSetKey];
|
|
dsWriteModes = [dsEdit, dsInsert, dsSetKey, dsCalcFields, dsFilter,
|
|
dsNewValue, dsInternalCalc, dsRefreshFields];
|
|
// Correct list of all field types that are BLOB types.
|
|
// Please use this instead of checking TBlobType which will give
|
|
// incorrect results
|
|
ftBlobTypes = [ftBlob, ftMemo];
|
|
|
|
|
|
{ Auxiliary functions }
|
|
|
|
Procedure DatabaseError (Const Msg : String); overload;
|
|
Procedure DatabaseError (Const Msg : String; Comp : TComponent); overload;
|
|
Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of Const); overload;
|
|
Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of Const; Comp : TComponent); overload;
|
|
Function ExtractFieldName(Const Fields: String; var Pos: Integer): String;
|
|
|
|
// function SkipComments(var p: PChar; EscapeSlash, EscapeRepeat : Boolean) : boolean;
|
|
|
|
// operator Enumerator(ADataSet: TDataSet): TDataSetEnumerator;
|
|
|
|
implementation
|
|
|
|
uses DBConst,TypInfo;
|
|
|
|
{ ---------------------------------------------------------------------
|
|
Auxiliary functions
|
|
---------------------------------------------------------------------}
|
|
|
|
Procedure DatabaseError (Const Msg : String);
|
|
|
|
begin
|
|
Raise EDataBaseError.Create(Msg);
|
|
end;
|
|
|
|
Procedure DatabaseError (Const Msg : String; Comp : TComponent);
|
|
|
|
begin
|
|
if assigned(Comp) and (Comp.Name <> '') then
|
|
Raise EDatabaseError.CreateFmt('%s : %s',[Comp.Name,Msg])
|
|
else
|
|
DatabaseError(Msg);
|
|
end;
|
|
|
|
Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of Const);
|
|
|
|
begin
|
|
Raise EDatabaseError.CreateFmt(Fmt,Args);
|
|
end;
|
|
|
|
Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of Const;
|
|
Comp : TComponent);
|
|
begin
|
|
if assigned(comp) then
|
|
Raise EDatabaseError.CreateFmt(Format('%s : %s',[Comp.Name,Fmt]),Args)
|
|
else
|
|
DatabaseErrorFmt(Fmt, Args);
|
|
end;
|
|
|
|
function ExtractFieldName(const Fields: string; var Pos: Integer): string;
|
|
var
|
|
i: Integer;
|
|
FieldsLength: Integer;
|
|
begin
|
|
i:=Pos;
|
|
FieldsLength:=Length(Fields);
|
|
while (i<=FieldsLength) and (Fields[i]<>';') do Inc(i);
|
|
Result:=Trim(Copy(Fields,Pos,i-Pos));
|
|
if (i<=FieldsLength) and (Fields[i]=';') then Inc(i);
|
|
Pos:=i;
|
|
end;
|
|
|
|
{ TRecordUpdateBatch }
|
|
|
|
constructor TRecordUpdateBatch.Create(aBatchID: Integer; AList: TRecordUpdateDescriptorList; AOwnsList : Boolean);
|
|
begin
|
|
FBatchID:=aBatchID;
|
|
FList:=AList;
|
|
FOwnsList:=AOwnsList;
|
|
FStatus:=ubsPending;
|
|
end;
|
|
|
|
destructor TRecordUpdateBatch.Destroy;
|
|
begin
|
|
if OwnsList then
|
|
FreeList;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TRecordUpdateBatch.FreeList;
|
|
begin
|
|
FreeAndNil(FList);
|
|
end;
|
|
|
|
{ TRecordUpdateDescriptorList }
|
|
|
|
function TRecordUpdateDescriptorList.GetUpdate(AIndex : Integer): TRecordUpdateDescriptor;
|
|
begin
|
|
Result:=TRecordUpdateDescriptor(Items[AIndex]);
|
|
end;
|
|
|
|
{ TRecordUpdateDescriptor }
|
|
|
|
procedure TRecordUpdateDescriptor.SetResolveStatus(aValue: TResolveStatus);
|
|
begin
|
|
FResolveStatus:=AValue;
|
|
end;
|
|
|
|
procedure TRecordUpdateDescriptor.Reset;
|
|
begin
|
|
FResolveStatus:=rsUnresolved;
|
|
FResolveError:='';
|
|
FServerData:=Null;
|
|
end;
|
|
|
|
constructor TRecordUpdateDescriptor.Create(aProxy: TDataProxy; aDataset: TDataset; aBookmark: TBookMark; AData: JSValue;
|
|
AStatus: TUpdateStatus);
|
|
begin
|
|
FDataset:=aDataset;
|
|
FBookmark:=aBookmark;
|
|
FData:=AData;
|
|
FStatus:=AStatus;
|
|
FProxy:=aProxy;
|
|
end;
|
|
|
|
|
|
procedure TRecordUpdateDescriptor.Resolve(aData: JSValue);
|
|
begin
|
|
SetResolveStatus(rsResolved);
|
|
FServerData:=AData;
|
|
end;
|
|
|
|
procedure TRecordUpdateDescriptor.ResolveFailed(aError: String);
|
|
begin
|
|
SetResolveStatus(rsResolveFailed);
|
|
FResolveError:=AError;
|
|
end;
|
|
|
|
{ TDataRequest }
|
|
|
|
procedure TDataRequest.DoAfterRequest;
|
|
begin
|
|
if Assigned(FAfterRequest) then
|
|
FAfterRequest(Self);
|
|
end;
|
|
|
|
constructor TDataRequest.Create(aDataProxy : TDataProxy; aOptions: TLoadOptions; aAfterRequest: TDataRequestEvent; aAfterLoad: TDatasetLoadEvent);
|
|
begin
|
|
FDataProxy:=aDataProxy;
|
|
FLoadOptions:=aOptions;
|
|
FEvent:=aAfterLoad;
|
|
FAfterRequest:=aAfterRequest;
|
|
end;
|
|
|
|
{ TDataProxy }
|
|
|
|
function TDataProxy.GetDataRequestClass: TDataRequestClass;
|
|
begin
|
|
Result:=TDataRequest;
|
|
end;
|
|
|
|
function TDataProxy.GetUpdateDescriptorClass: TRecordUpdateDescriptorClass;
|
|
begin
|
|
Result:=TRecordUpdateDescriptor;
|
|
end;
|
|
|
|
function TDataProxy.GetUpdateBatchClass: TRecordUpdateBatchClass;
|
|
begin
|
|
Result:=TRecordUpdateBatch;
|
|
end;
|
|
|
|
procedure TDataProxy.ResolveBatch(aBatch: TRecordUpdateBatch);
|
|
begin
|
|
try
|
|
If Assigned(ABatch.FOnResolve) then
|
|
ABatch.FOnResolve(Self,ABatch);
|
|
finally
|
|
aBatch.Free;
|
|
end;
|
|
end;
|
|
|
|
function TDataProxy.GetDataRequest(aOptions: TLoadOptions; aAfterRequest : TDataRequestEvent; aAfterLoad: TDatasetLoadEvent): TDataRequest;
|
|
begin
|
|
Result:=GetDataRequestClass.Create(Self,aOptions,aAfterRequest,aAfterLoad);
|
|
end;
|
|
|
|
function TDataProxy.GetUpdateDescriptor(aDataset : TDataset; aBookmark: TBookMark; AData: JSValue; AStatus: TUpdateStatus): TRecordUpdateDescriptor;
|
|
begin
|
|
Result:=GetUpdateDescriptorClass.Create(Self,aDataset, aBookmark,AData,AStatus);
|
|
end;
|
|
|
|
function TDataProxy.GetRecordUpdateBatch(aBatchID: Integer; AList: TRecordUpdateDescriptorList; AOwnsList : Boolean = True): TRecordUpdateBatch;
|
|
begin
|
|
Result:=GetUpdateBatchClass.Create(aBatchID,AList,AOwnsList);
|
|
end;
|
|
|
|
|
|
{ EUpdateError }
|
|
constructor EUpdateError.Create(NativeError, Context : String;
|
|
ErrCode, PrevError : integer; E: Exception);
|
|
|
|
begin
|
|
Inherited CreateFmt(NativeError,[Context]);
|
|
FContext := Context;
|
|
FErrorCode := ErrCode;
|
|
FPreviousError := PrevError;
|
|
FOriginalException := E;
|
|
end;
|
|
|
|
Destructor EUpdateError.Destroy;
|
|
|
|
begin
|
|
FOriginalException.Free;
|
|
Inherited;
|
|
end;
|
|
|
|
{ TNamedItem }
|
|
|
|
function TNamedItem.GetDisplayName: string;
|
|
begin
|
|
Result := FName;
|
|
end;
|
|
|
|
procedure TNamedItem.SetDisplayName(const Value: string);
|
|
Var TmpInd : Integer;
|
|
begin
|
|
if FName=Value then exit;
|
|
if (Value <> '') and (Collection is TFieldDefs ) then
|
|
begin
|
|
TmpInd := (TDefCollection(Collection).IndexOf(Value));
|
|
if (TmpInd >= 0) and (TmpInd <> Index) then
|
|
DatabaseErrorFmt(SDuplicateName, [Value, Collection.ClassName]);
|
|
end;
|
|
FName:=Value;
|
|
inherited SetDisplayName(Value);
|
|
end;
|
|
|
|
{ TDefCollection }
|
|
|
|
procedure TDefCollection.SetItemName(Item: TCollectionItem);
|
|
|
|
Var
|
|
N : TNamedItem;
|
|
TN : String;
|
|
|
|
begin
|
|
N:=Item as TNamedItem;
|
|
if N.Name = '' then
|
|
begin
|
|
TN:=Copy(ClassName, 2, 5) + IntToStr(N.ID+1);
|
|
if assigned(Dataset) then
|
|
TN:=Dataset.Name+TN;
|
|
N.Name:=TN;
|
|
end
|
|
else
|
|
inherited SetItemName(Item);
|
|
end;
|
|
|
|
constructor TDefCollection.create(ADataset: TDataset; AOwner: TPersistent;
|
|
AClass: TCollectionItemClass);
|
|
begin
|
|
inherited Create(AOwner,AClass);
|
|
FDataset := ADataset;
|
|
end;
|
|
|
|
function TDefCollection.Find(const AName: string): TNamedItem;
|
|
var i: integer;
|
|
begin
|
|
Result := Nil;
|
|
for i := 0 to Count - 1 do
|
|
if AnsiSameText(TNamedItem(Items[i]).Name, AName) then
|
|
begin
|
|
Result := TNamedItem(Items[i]);
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
procedure TDefCollection.GetItemNames(List: TStrings);
|
|
var i: LongInt;
|
|
begin
|
|
for i := 0 to Count - 1 do
|
|
List.Add(TNamedItem(Items[i]).Name);
|
|
end;
|
|
|
|
function TDefCollection.IndexOf(const AName: string): Longint;
|
|
var i: LongInt;
|
|
begin
|
|
Result := -1;
|
|
for i := 0 to Count - 1 do
|
|
if AnsiSameText(TNamedItem(Items[i]).Name, AName) then
|
|
begin
|
|
Result := i;
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
{ TIndexDef }
|
|
|
|
procedure TIndexDef.SetDescFields(const AValue: string);
|
|
begin
|
|
if FDescFields=AValue then exit;
|
|
if AValue <> '' then FOptions:=FOptions + [ixDescending];
|
|
FDescFields:=AValue;
|
|
end;
|
|
|
|
procedure TIndexDef.Assign(Source: TPersistent);
|
|
var idef : TIndexDef;
|
|
begin
|
|
idef := nil;
|
|
if Source is TIndexDef then
|
|
idef := Source as TIndexDef;
|
|
if Assigned(idef) then
|
|
begin
|
|
FName := idef.Name;
|
|
FFields := idef.Fields;
|
|
FOptions := idef.Options;
|
|
FCaseinsFields := idef.CaseInsFields;
|
|
FDescFields := idef.DescFields;
|
|
FSource := idef.Source;
|
|
FExpression := idef.Expression;
|
|
end
|
|
else
|
|
inherited Assign(Source);
|
|
end;
|
|
|
|
function TIndexDef.GetExpression: string;
|
|
begin
|
|
Result := FExpression;
|
|
end;
|
|
|
|
procedure TIndexDef.SetExpression(const AValue: string);
|
|
begin
|
|
FExpression := AValue;
|
|
end;
|
|
|
|
procedure TIndexDef.SetCaseInsFields(const AValue: string);
|
|
begin
|
|
if FCaseinsFields=AValue then exit;
|
|
if AValue <> '' then FOptions:=FOptions + [ixCaseInsensitive];
|
|
FCaseinsFields:=AValue;
|
|
end;
|
|
|
|
constructor TIndexDef.Create(Owner: TIndexDefs; const AName, TheFields: string;
|
|
TheOptions: TIndexOptions);
|
|
|
|
begin
|
|
FName := aname;
|
|
inherited create(Owner);
|
|
FFields := TheFields;
|
|
FOptions := TheOptions;
|
|
end;
|
|
|
|
|
|
{ TIndexDefs }
|
|
|
|
Function TIndexDefs.GetItem (Index : integer) : TIndexDef;
|
|
|
|
begin
|
|
Result:=(Inherited GetItem(Index)) as TIndexDef;
|
|
end;
|
|
|
|
Procedure TIndexDefs.SetItem(Index: Integer; Value: TIndexDef);
|
|
begin
|
|
Inherited SetItem(Index,Value);
|
|
end;
|
|
|
|
constructor TIndexDefs.Create(ADataSet: TDataSet);
|
|
|
|
begin
|
|
inherited create(ADataset, Owner, TIndexDef);
|
|
end;
|
|
|
|
|
|
Function TIndexDefs.AddIndexDef: TIndexDef;
|
|
|
|
begin
|
|
// Result := inherited add as TIndexDef;
|
|
Result:=TIndexDefClass(Self.ItemClass).Create(Self,'','',[]);
|
|
end;
|
|
|
|
procedure TIndexDefs.Add(const Name, Fields: string; Options: TIndexOptions);
|
|
|
|
begin
|
|
TIndexDefClass(Self.ItemClass).Create(Self,Name,Fields,Options);
|
|
end;
|
|
|
|
function TIndexDefs.Find(const IndexName: string): TIndexDef;
|
|
begin
|
|
Result := (inherited Find(IndexName)) as TIndexDef;
|
|
if (Result=Nil) Then
|
|
DatabaseErrorFmt(SIndexNotFound, [IndexName], FDataSet);
|
|
end;
|
|
|
|
function TIndexDefs.FindIndexForFields(const Fields: string): TIndexDef;
|
|
|
|
begin
|
|
//!! To be implemented
|
|
Result:=nil;
|
|
end;
|
|
|
|
|
|
function TIndexDefs.GetIndexForFields(const Fields: string;
|
|
CaseInsensitive: Boolean): TIndexDef;
|
|
|
|
var
|
|
i, FieldsLen: integer;
|
|
Last: TIndexDef;
|
|
begin
|
|
Last := nil;
|
|
FieldsLen := Length(Fields);
|
|
for i := 0 to Count - 1 do
|
|
begin
|
|
Result := Items[I];
|
|
if (Result.Options * [ixDescending, ixExpression] = []) and
|
|
(not CaseInsensitive or (ixCaseInsensitive in Result.Options)) and
|
|
AnsiSameText(Fields, Result.Fields) then
|
|
begin
|
|
Exit;
|
|
end else
|
|
if AnsiSameText(Fields, Copy(Result.Fields, 1, FieldsLen)) and
|
|
((Length(Result.Fields) = FieldsLen) or
|
|
(Result.Fields[FieldsLen + 1] = ';')) then
|
|
begin
|
|
if (Last = nil) or
|
|
((Last <> nil) And (Length(Last.Fields) > Length(Result.Fields))) then
|
|
Last := Result;
|
|
end;
|
|
end;
|
|
Result := Last;
|
|
end;
|
|
|
|
procedure TIndexDefs.Update;
|
|
|
|
begin
|
|
if (not updated) and assigned(Dataset) then
|
|
begin
|
|
Dataset.UpdateIndexDefs;
|
|
updated := True;
|
|
end;
|
|
end;
|
|
|
|
{ TCheckConstraint }
|
|
|
|
procedure TCheckConstraint.Assign(Source: TPersistent);
|
|
|
|
begin
|
|
//!! To be implemented
|
|
end;
|
|
|
|
|
|
|
|
{ TCheckConstraints }
|
|
|
|
Function TCheckConstraints.GetItem(Index : Longint) : TCheckConstraint;
|
|
|
|
begin
|
|
//!! To be implemented
|
|
Result := nil;
|
|
end;
|
|
|
|
|
|
Procedure TCheckConstraints.SetItem(index : Longint; Value : TCheckConstraint);
|
|
|
|
begin
|
|
//!! To be implemented
|
|
end;
|
|
|
|
|
|
function TCheckConstraints.GetOwner: TPersistent;
|
|
|
|
begin
|
|
//!! To be implemented
|
|
Result := nil;
|
|
end;
|
|
|
|
|
|
constructor TCheckConstraints.Create(AOwner: TPersistent);
|
|
|
|
begin
|
|
//!! To be implemented
|
|
inherited Create(TCheckConstraint);
|
|
end;
|
|
|
|
|
|
function TCheckConstraints.Add: TCheckConstraint;
|
|
|
|
begin
|
|
//!! To be implemented
|
|
Result := nil;
|
|
end;
|
|
|
|
{ TLookupList }
|
|
|
|
constructor TLookupList.Create;
|
|
|
|
begin
|
|
FList := TFPList.Create;
|
|
end;
|
|
|
|
destructor TLookupList.Destroy;
|
|
|
|
begin
|
|
Clear;
|
|
FList.Destroy;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TLookupList.Add(const AKey, AValue: JSValue);
|
|
|
|
var LookupRec: TJSObject;
|
|
|
|
begin
|
|
LookupRec:=New(['Key',AKey,'Value',AValue]);
|
|
FList.Add(LookupRec);
|
|
end;
|
|
|
|
procedure TLookupList.Clear;
|
|
|
|
begin
|
|
FList.Clear;
|
|
end;
|
|
|
|
function TLookupList.FirstKeyByValue(const AValue: JSValue): JSValue;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to FList.Count - 1 do
|
|
with TJSObject(FList[i]) do
|
|
if Properties['Value'] = AValue then
|
|
begin
|
|
Result := Properties['Key'];
|
|
exit;
|
|
end;
|
|
Result := Null;
|
|
end;
|
|
|
|
function TLookupList.ValueOfKey(const AKey: JSValue): JSValue;
|
|
|
|
Function VarArraySameValues(VarArray1,VarArray2 : TJSValueDynArray) : Boolean;
|
|
// This only works for one-dimensional vararrays with a lower bound of 0
|
|
// and equal higher bounds wich only contains JSValues.
|
|
// The vararrays returned by GetFieldValues do apply.
|
|
var i : integer;
|
|
begin
|
|
Result := True;
|
|
if (Length(VarArray1)<>Length(VarArray2)) then
|
|
exit;
|
|
for i := 0 to Length(VarArray1) do
|
|
begin
|
|
if VarArray1[i]<>VarArray2[i] then
|
|
begin
|
|
Result := false;
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
var I: Integer;
|
|
begin
|
|
Result := Null;
|
|
if IsNull(AKey) then Exit;
|
|
i := FList.Count - 1;
|
|
if IsArray(AKey) then
|
|
while (i >= 0) And not VarArraySameValues(TJSValueDynArray(TJSOBject(FList.Items[I]).Properties['Key']),TJSValueDynArray(AKey)) do Dec(i)
|
|
else
|
|
while (i >= 0) And (TJSObject(FList[I]).Properties['Key'] <> AKey) do Dec(i);
|
|
if i >= 0 then Result := TJSObject(FList[I]).Properties['Value'];
|
|
end;
|
|
|
|
procedure TLookupList.ValuesToStrings(AStrings: TStrings);
|
|
|
|
var
|
|
i: Integer;
|
|
p: TJSObject;
|
|
|
|
begin
|
|
AStrings.Clear;
|
|
for i := 0 to FList.Count - 1 do
|
|
begin
|
|
p := TJSObject(FList[i]);
|
|
AStrings.AddObject(String(p.properties['Value']), TObject(p));
|
|
end;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------
|
|
TDataSet
|
|
---------------------------------------------------------------------}
|
|
|
|
Const
|
|
DefaultBufferCount = 10;
|
|
|
|
constructor TDataSet.Create(AOwner: TComponent);
|
|
|
|
begin
|
|
Inherited Create(AOwner);
|
|
FFieldDefs:=FieldDefsClass.Create(Self);
|
|
FFieldList:=FieldsClass.Create(Self);
|
|
FDataSources:=TFPList.Create;
|
|
FConstraints:=TCheckConstraints.Create(Self);
|
|
SetLength(FBuffers,1);
|
|
FActiveRecord := 0;
|
|
FEOF := True;
|
|
FBOF := True;
|
|
FIsUniDirectional := False;
|
|
FAutoCalcFields := True;
|
|
FDataRequestID:=0;
|
|
FNestedDataSetClass := TDataSetClass(Self.ClassType);
|
|
end;
|
|
|
|
destructor TDataSet.Destroy;
|
|
|
|
var
|
|
i: Integer;
|
|
|
|
begin
|
|
Active:=False;
|
|
|
|
SetDataSetField(nil);
|
|
|
|
FFieldDefs.Free;
|
|
FFieldList.Free;
|
|
FNestedDataSets.Free;
|
|
With FDataSources do
|
|
begin
|
|
While Count>0 do
|
|
TDataSource(Items[Count - 1]).DataSet:=Nil;
|
|
Destroy;
|
|
end;
|
|
for i := 0 to FBufferCount do
|
|
FreeRecordBuffer(FBuffers[i]);
|
|
FConstraints.Free;
|
|
SetLength(FBuffers,1);
|
|
Inherited Destroy;
|
|
end;
|
|
|
|
// This procedure must be called when the first record is made/read
|
|
procedure TDataSet.ActivateBuffers;
|
|
|
|
begin
|
|
FBOF:=False;
|
|
FEOF:=False;
|
|
FActiveRecord:=0;
|
|
end;
|
|
|
|
procedure TDataSet.BindFields(Binding: Boolean);
|
|
|
|
var i, FieldIndex: Integer;
|
|
FieldDef: TFieldDef;
|
|
Field: TField;
|
|
|
|
begin
|
|
{ FieldNo is set to -1 for calculated/lookup fields, to 0 for unbound field
|
|
and for bound fields it is set to FieldDef.FieldNo }
|
|
FCalcFieldsCount := 0;
|
|
FBlobFieldCount := 0;
|
|
for i := 0 to Fields.Count - 1 do
|
|
begin
|
|
Field := Fields[i];
|
|
Field.FFieldDef := Nil;
|
|
if not Binding then
|
|
Field.FFieldNo := 0
|
|
else if Field.FieldKind in [fkCalculated, fkLookup] then
|
|
begin
|
|
Field.FFieldNo := -1;
|
|
Inc(FCalcFieldsCount);
|
|
end
|
|
else
|
|
begin
|
|
FieldIndex := FieldDefs.IndexOf(Field.FieldName);
|
|
if FieldIndex = -1 then
|
|
DatabaseErrorFmt(SFieldNotFound,[Field.FieldName],Self)
|
|
else
|
|
begin
|
|
FieldDef := FieldDefs[FieldIndex];
|
|
Field.FFieldDef := FieldDef;
|
|
Field.FFieldNo := FieldDef.FieldNo;
|
|
if FieldDef.InternalCalcField then
|
|
FInternalCalcFields := True;
|
|
if Field.IsBlob then
|
|
begin
|
|
Field.FSize := FieldDef.Size;
|
|
Inc(FBlobFieldCount);
|
|
end;
|
|
// synchronize CodePage between TFieldDef and TField
|
|
// character data in record buffer and field buffer should have same CodePage
|
|
end;
|
|
end;
|
|
Field.Bind(Binding);
|
|
end;
|
|
end;
|
|
|
|
function TDataSet.BookmarkAvailable: Boolean;
|
|
|
|
Const BookmarkStates = [dsBrowse,dsEdit,dsInsert];
|
|
|
|
begin
|
|
Result:=(Not IsEmpty) and not FIsUniDirectional and (State in BookmarkStates)
|
|
and (getBookMarkFlag(ActiveBuffer)=bfCurrent);
|
|
end;
|
|
|
|
procedure TDataSet.CalculateFields(var Buffer: TDataRecord);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
FCalcBuffer := Buffer;
|
|
|
|
if FState <> dsInternalCalc then
|
|
begin
|
|
ClearCalcFields(FCalcBuffer);
|
|
|
|
if not IsUniDirectional then
|
|
for i := 0 to FFieldList.Count - 1 do
|
|
if FFieldList[i].FieldKind = fkLookup then
|
|
FFieldList[i].CalcLookupValue;
|
|
end;
|
|
|
|
DoOnCalcFields;
|
|
end;
|
|
|
|
procedure TDataSet.CheckActive;
|
|
|
|
begin
|
|
If Not Active then
|
|
DataBaseError(SInactiveDataset,Self);
|
|
end;
|
|
|
|
procedure TDataSet.CheckInactive;
|
|
|
|
begin
|
|
If Active then
|
|
DataBaseError(SActiveDataset,Self);
|
|
end;
|
|
|
|
procedure TDataSet.ClearBuffers;
|
|
|
|
begin
|
|
FRecordCount:=0;
|
|
FActiveRecord:=0;
|
|
FCurrentRecord:=-1;
|
|
FBOF:=True;
|
|
FEOF:=True;
|
|
end;
|
|
|
|
procedure TDataSet.ClearCalcFields(var Buffer: TDataRecord);
|
|
|
|
begin
|
|
// Empty
|
|
end;
|
|
|
|
procedure TDataSet.CloseBlob(Field: TField);
|
|
|
|
begin
|
|
//!! To be implemented
|
|
end;
|
|
|
|
procedure TDataSet.CloseCursor;
|
|
|
|
begin
|
|
ClearBuffers;
|
|
SetBufListSize(0);
|
|
Fields.ClearFieldDefs;
|
|
InternalClose;
|
|
FInternalOpenComplete := False;
|
|
end;
|
|
|
|
procedure TDataSet.CreateFields;
|
|
|
|
Var I : longint;
|
|
|
|
begin
|
|
{$ifdef DSDebug}
|
|
Writeln ('Creating fields');
|
|
Writeln ('Count : ',fielddefs.Count);
|
|
For I:=0 to FieldDefs.Count-1 do
|
|
Writeln('Def ',I,' : ',Fielddefs.items[i].Name,'(',Fielddefs.items[i].FieldNo,')');
|
|
{$endif}
|
|
For I:=0 to FieldDefs.Count-1 do
|
|
With FieldDefs.Items[I] do
|
|
If DataType<>ftUnknown then
|
|
begin
|
|
{$ifdef DSDebug}
|
|
Writeln('About to create field ',FieldDefs.Items[i].Name);
|
|
{$endif}
|
|
CreateField(self);
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.DataEvent(Event: TDataEvent; Info: JSValue);
|
|
|
|
procedure HandleFieldChange(aField: TField);
|
|
begin
|
|
if aField.FieldKind in [fkData, fkInternalCalc] then
|
|
SetModified(True);
|
|
|
|
if State <> dsSetKey then begin
|
|
if aField.FieldKind = fkData then begin
|
|
if FInternalCalcFields then
|
|
RefreshInternalCalcFields(FBuffers[FActiveRecord])
|
|
else if FAutoCalcFields and (FCalcFieldsCount <> 0) then
|
|
CalculateFields(FBuffers[FActiveRecord]);
|
|
end;
|
|
aField.Change;
|
|
end;
|
|
end;
|
|
|
|
procedure HandleScrollOrChange;
|
|
var
|
|
A: Integer;
|
|
|
|
NestedDataSet: TDataSet;
|
|
|
|
begin
|
|
if State <> dsInsert then
|
|
UpdateCursorPos;
|
|
|
|
if Assigned(FNestedDataSets) then
|
|
for A := 0 to Pred(NestedDataSets.Count) do
|
|
begin
|
|
NestedDataSet := TDataSet(NestedDataSets[A]);
|
|
|
|
if NestedDataSet.Active then
|
|
NestedDataSet.DataEvent(deParentScroll, 0);
|
|
end;
|
|
end;
|
|
|
|
var
|
|
i: Integer;
|
|
begin
|
|
case Event of
|
|
deFieldChange : HandleFieldChange(TField(Info));
|
|
deDataSetChange,
|
|
deDataSetScroll : HandleScrollOrChange;
|
|
deLayoutChange : FEnableControlsEvent:=deLayoutChange;
|
|
end;
|
|
|
|
if not ControlsDisabled and (FState <> dsBlockRead) then begin
|
|
for i := 0 to FDataSources.Count - 1 do
|
|
TDataSource(FDataSources[i]).ProcessEvent(Event, Info);
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.DestroyFields;
|
|
|
|
begin
|
|
FFieldList.Clear;
|
|
end;
|
|
|
|
procedure TDataSet.DoAfterCancel;
|
|
|
|
begin
|
|
If assigned(FAfterCancel) then
|
|
FAfterCancel(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoAfterClose;
|
|
|
|
begin
|
|
If assigned(FAfterClose) and not (csDestroying in ComponentState) then
|
|
FAfterClose(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoAfterDelete;
|
|
|
|
begin
|
|
If assigned(FAfterDelete) then
|
|
FAfterDelete(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoAfterEdit;
|
|
|
|
begin
|
|
If assigned(FAfterEdit) then
|
|
FAfterEdit(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoAfterInsert;
|
|
|
|
begin
|
|
If assigned(FAfterInsert) then
|
|
FAfterInsert(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoAfterOpen;
|
|
|
|
begin
|
|
If assigned(FAfterOpen) then
|
|
FAfterOpen(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoAfterPost;
|
|
|
|
begin
|
|
If assigned(FAfterPost) then
|
|
FAfterPost(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoAfterScroll;
|
|
|
|
begin
|
|
If assigned(FAfterScroll) then
|
|
FAfterScroll(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoAfterRefresh;
|
|
|
|
begin
|
|
If assigned(FAfterRefresh) then
|
|
FAfterRefresh(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoBeforeCancel;
|
|
|
|
begin
|
|
If assigned(FBeforeCancel) then
|
|
FBeforeCancel(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoBeforeClose;
|
|
|
|
begin
|
|
If assigned(FBeforeClose) and not (csDestroying in ComponentState) then
|
|
FBeforeClose(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoBeforeDelete;
|
|
|
|
begin
|
|
If assigned(FBeforeDelete) then
|
|
FBeforeDelete(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoBeforeEdit;
|
|
|
|
begin
|
|
If assigned(FBeforeEdit) then
|
|
FBeforeEdit(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoBeforeInsert;
|
|
|
|
begin
|
|
If assigned(FBeforeInsert) then
|
|
FBeforeInsert(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoBeforeOpen;
|
|
|
|
begin
|
|
If assigned(FBeforeOpen) then
|
|
FBeforeOpen(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoBeforePost;
|
|
|
|
begin
|
|
If assigned(FBeforePost) then
|
|
FBeforePost(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoBeforeScroll;
|
|
|
|
begin
|
|
If assigned(FBeforeScroll) then
|
|
FBeforeScroll(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoBeforeRefresh;
|
|
|
|
begin
|
|
If assigned(FBeforeRefresh) then
|
|
FBeforeRefresh(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoInternalOpen;
|
|
|
|
begin
|
|
InternalOpen;
|
|
FInternalOpenComplete := True;
|
|
{$ifdef dsdebug}
|
|
Writeln ('Calling internal open');
|
|
{$endif}
|
|
{$ifdef dsdebug}
|
|
Writeln ('Calling RecalcBufListSize');
|
|
{$endif}
|
|
FRecordCount := 0;
|
|
RecalcBufListSize;
|
|
FBOF := True;
|
|
FEOF := (FRecordCount = 0);
|
|
if Assigned(DataProxy) then
|
|
InitChangeList;
|
|
end;
|
|
|
|
procedure TDataSet.DoOnCalcFields;
|
|
|
|
begin
|
|
If Assigned(FOnCalcfields) then
|
|
FOnCalcFields(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoOnNewRecord;
|
|
|
|
begin
|
|
If assigned(FOnNewRecord) then
|
|
FOnNewRecord(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoBeforeLoad;
|
|
begin
|
|
If Assigned(FBeforeLoad) then
|
|
FBeforeLoad(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoAfterLoad;
|
|
begin
|
|
if Assigned(FAfterLoad) then
|
|
FAfterLoad(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoBeforeApplyUpdates;
|
|
|
|
begin
|
|
If Assigned(FBeforeApplyUpdates) then
|
|
FBeforeApplyUpdates(Self);
|
|
end;
|
|
|
|
procedure TDataSet.DoAfterApplyUpdates(const ResolveInfo: TResolveResults);
|
|
|
|
begin
|
|
If Assigned(FAfterApplyUpdates) then
|
|
FAfterApplyUpdates(Self,ResolveInfo);
|
|
end;
|
|
|
|
function TDataSet.FieldByNumber(FieldNo: Longint): TField;
|
|
|
|
begin
|
|
Result:=FFieldList.FieldByNumber(FieldNo);
|
|
end;
|
|
|
|
function TDataSet.FindRecord(Restart, GoForward: Boolean): Boolean;
|
|
|
|
begin
|
|
//!! To be implemented
|
|
Result:=false;
|
|
end;
|
|
|
|
|
|
function TDataSet.GetBookmarkStr: TBookmarkStr;
|
|
|
|
Var
|
|
B : TBookMark;
|
|
|
|
begin
|
|
Result:='';
|
|
If BookMarkAvailable then
|
|
begin
|
|
GetBookMarkData(ActiveBuffer,B);
|
|
Result:=TJSJSON.stringify(B);
|
|
end
|
|
end;
|
|
|
|
function TDataSet.GetBuffer(Index: longint): TDataRecord;
|
|
|
|
begin
|
|
Result:=FBuffers[Index];
|
|
end;
|
|
|
|
function TDataSet.DoGetDataProxy: TDataProxy;
|
|
|
|
begin
|
|
Result:=nil;
|
|
end;
|
|
|
|
procedure TDataSet.InitChangeList;
|
|
|
|
begin
|
|
DoneChangeList;
|
|
FChangeList:=TFPList.Create;
|
|
end;
|
|
|
|
procedure TDataSet.ClearChangeList;
|
|
|
|
Var
|
|
I : integer;
|
|
|
|
begin
|
|
If not Assigned(FChangeList) then
|
|
exit;
|
|
For I:=0 to FChangeList.Count-1 do
|
|
begin
|
|
TObject(FChangeList[i]).Destroy;
|
|
FChangeList[i]:=Nil;
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.ResetUpdateDescriptors;
|
|
|
|
Var
|
|
I : Integer;
|
|
|
|
begin
|
|
For I:=0 to FChangeList.Count-1 do
|
|
TRecordUpdateDescriptor(FChangeList[i]).Reset;
|
|
end;
|
|
|
|
function TDataSet.IndexInChangeList(aBookmark: TBookmark): Integer;
|
|
|
|
begin
|
|
Result:=-1;
|
|
if Not assigned(FChangeList) then
|
|
exit;
|
|
Result:=FChangeList.Count-1;
|
|
While (Result>=0) and (CompareBookmarks(aBookMark,TRecordUpdateDescriptor(FChangeList[Result]).Bookmark)<>0) do
|
|
Dec(Result);
|
|
end;
|
|
|
|
function TDataSet.GetApplyUpdateData(aBuffer : TDataRecord) : JSValue;
|
|
|
|
begin
|
|
Result:=aBuffer.Data;
|
|
end;
|
|
|
|
function TDataSet.AddToChangeList(aChange: TUpdateStatus): TRecordUpdateDescriptor;
|
|
|
|
Var
|
|
B : TBookmark;
|
|
I : Integer;
|
|
aData : JSValue;
|
|
|
|
begin
|
|
Result:=Nil;
|
|
if Not Assigned(FChangeList) then
|
|
Exit;
|
|
B:=GetBookmark;
|
|
I:=IndexInChangeList(B);
|
|
if (I=-1) then
|
|
begin
|
|
aData:=GetApplyUpdateData(ActiveBuffer);
|
|
if Assigned(DataProxy) then
|
|
Result:=DataProxy.GetUpdateDescriptor(Self,B,aData,aChange)
|
|
else
|
|
Result:=TRecordUpdateDescriptor.Create(Nil,Self,B,aData,aChange);
|
|
FChangeList.Add(Result);
|
|
end
|
|
else
|
|
begin
|
|
Result:=TRecordUpdateDescriptor(FChangeList[i]);
|
|
Case aChange of
|
|
usDeleted :
|
|
begin
|
|
if Result.FStatus = usInserted then
|
|
FChangeList.Delete(I)
|
|
else
|
|
Result.FStatus:=usDeleted;
|
|
end;
|
|
usInserted : DatabaseError(SErrInsertingSameRecordtwice,Self);
|
|
usModified : Result.FData:=GetApplyUpdateData(ActiveBuffer);
|
|
end
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.RemoveFromChangeList(R: TRecordUpdateDescriptor);
|
|
|
|
begin
|
|
if Not (Assigned(R) and Assigned(FChangeList)) then
|
|
Exit;
|
|
end;
|
|
|
|
function TDataSet.GetRecordUpdates(AList: TRecordUpdateDescriptorList): Integer;
|
|
|
|
Var
|
|
I,MinIndex : integer;
|
|
|
|
begin
|
|
MinIndex:=0; // Check batch list for minimal index ?
|
|
For I:=MinIndex to FChangeList.Count-1 do
|
|
if TRecordUpdateDescriptor(FChangeList[i]).ResolveStatus=rsUnResolved then
|
|
Alist.Add(FChangeList[i]);
|
|
Result:=FChangeList.Count;
|
|
end;
|
|
|
|
function TDataSet.ResolveRecordUpdate(anUpdate: TRecordUpdateDescriptor): Boolean;
|
|
|
|
// This must return true if the record may be removed from the list of 'modified' records.
|
|
// If it returns false, the record is kept in the list of modified records.
|
|
|
|
begin
|
|
try
|
|
Result:=DoResolveRecordUpdate(anUpdate);
|
|
If not Result then
|
|
anUpdate.SetResolveStatus(rsResolveFailed);
|
|
except
|
|
On E : Exception do
|
|
begin
|
|
anUpdate.ResolveFailed(E.Classname+': '+E.Message);
|
|
Result:=False;
|
|
end;
|
|
end;
|
|
DoOnRecordResolved(anUpdate);
|
|
end;
|
|
|
|
function TDataSet.RecordUpdateDescriptorToResolveInfo(anUpdate: TRecordUpdateDescriptor): TResolveInfo;
|
|
|
|
begin
|
|
Result.BookMark:=anUpdate.Bookmark;
|
|
Result.Data:=anUpdate.Data;
|
|
Result.Status:=anUpdate.Status;
|
|
Result.ResolveStatus:=anUpdate.ResolveStatus;
|
|
Result.Error:=anUpdate.ResolveError;
|
|
end;
|
|
|
|
procedure TDataSet.DoOnRecordResolved(anUpdate: TRecordUpdateDescriptor) ;
|
|
|
|
Var
|
|
Info : TResolveInfo;
|
|
|
|
begin
|
|
if Not Assigned(OnRecordResolved) then exit;
|
|
Info:=RecordUpdateDescriptorToResolveInfo(anUpdate);
|
|
OnRecordResolved(Self,Info);
|
|
end;
|
|
|
|
procedure TDataSet.ResolveUpdateBatch(Sender: TObject; aBatch : TRecordUpdateBatch);
|
|
|
|
Var
|
|
BI,RI,Idx: integer;
|
|
RUD : TRecordUpdateDescriptor;
|
|
doRemove : Boolean;
|
|
Results : TResolveResults;
|
|
|
|
begin
|
|
if Assigned(FBatchList) and (aBatch.Dataset=Self) then
|
|
BI:=FBatchList.IndexOf(aBatch)
|
|
else
|
|
BI:=-1;
|
|
if (BI=-1) then
|
|
Exit;
|
|
FBatchList.Delete(Bi);
|
|
SetLength(Results.Records, aBatch.List.Count);
|
|
For RI:=0 to aBatch.List.Count-1 do
|
|
begin
|
|
RUD:=aBatch.List[RI];
|
|
Results.Records[RI]:=RecordUpdateDescriptorToResolveInfo(RUD);
|
|
aBatch.List.Items[RI]:=Nil;
|
|
Idx:=IndexInChangeList(RUD.Bookmark);
|
|
if (Idx<>-1) then
|
|
begin
|
|
doRemove:=False;
|
|
if (RUD.ResolveStatus=rsResolved) then
|
|
DoRemove:=ResolveRecordUpdate(RUD)
|
|
else
|
|
// What if not resolvable.. ?
|
|
DoRemove:=(RUD.ResolveStatus=rsResolved);
|
|
If DoRemove then
|
|
begin
|
|
RUD.Free;
|
|
FChangeList.Delete(Idx);
|
|
end
|
|
else
|
|
RUD.Reset; // So we try it again in next applyupdates.
|
|
end;
|
|
end;
|
|
if (FBatchList.Count=0) then
|
|
FreeAndNil(FBatchList);
|
|
DoAfterApplyUpdates(Results);
|
|
end;
|
|
|
|
procedure TDataSet.DoApplyUpdates;
|
|
|
|
Var
|
|
B : TRecordUpdateBatch;
|
|
l : TRecordUpdateDescriptorList;
|
|
I : integer;
|
|
|
|
begin
|
|
if Not Assigned(DataProxy) then
|
|
DatabaseError(SErrDoApplyUpdatesNeedsProxy,Self);
|
|
if FInApplyupdates then
|
|
exit;
|
|
try
|
|
FInApplyupdates:=True;
|
|
if Not (Assigned(FChangeList) and (FChangeList.Count>0)) then
|
|
Exit;
|
|
L:=TRecordUpdateDescriptorList.Create;
|
|
try
|
|
I:=GetRecordUpdates(L);
|
|
except
|
|
L.Free;
|
|
Raise;
|
|
end;
|
|
Inc(FUpdateBatchID);
|
|
For I:=0 to L.Count-1 do
|
|
TRecordUpdateDescriptor(L[i]).SetResolveStatus(rsResolving);
|
|
B:=DataProxy.GetRecordUpdateBatch(FUpdateBatchID,L,True);
|
|
B.FDataset:=Self;
|
|
B.FLastChangeIndex:=I;
|
|
B.OnResolve:=@ResolveUpdateBatch;
|
|
If not Assigned(FBatchlist) then
|
|
FBatchlist:=TFPList.Create;
|
|
FBatchList.Add(B);
|
|
DataProxy.ProcessUpdateBatch(B);
|
|
Finally
|
|
FInApplyupdates:=False;
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.DoneChangeList;
|
|
|
|
begin
|
|
ClearChangeList;
|
|
FreeAndNil(FChangeList);
|
|
end;
|
|
|
|
function TDataSet.GetDataProxy: TDataProxy;
|
|
|
|
begin
|
|
If (FDataProxy=Nil) then
|
|
DataProxy:=DoGetDataProxy;
|
|
Result:=FDataProxy;
|
|
end;
|
|
|
|
function TDataSet.GetIsLoading: Boolean;
|
|
begin
|
|
// Writeln(Name,' GetIsLoading Loadcount : ',LoadCount);
|
|
Result:=(FLoadCount>0);
|
|
end;
|
|
|
|
function TDataSet.DataPacketReceived(ARequest: TDataRequest): Boolean;
|
|
|
|
begin
|
|
Result:=False;
|
|
end;
|
|
|
|
procedure TDataSet.HandleRequestResponse(ARequest: TDataRequest);
|
|
|
|
Var
|
|
DataAdded : Boolean;
|
|
|
|
begin
|
|
if Not Assigned(ARequest) then
|
|
exit;
|
|
// Writeln(Name,' Check request response: ',ARequest.FRequestID,', min: ',FMinLoadID,' Loadcount:',FLoadCount);
|
|
if ARequest.FRequestID<=FMinLoadID then
|
|
begin
|
|
ARequest.Destroy;
|
|
Exit;
|
|
end;
|
|
Dec(FloadCount);
|
|
// Writeln(Name,' Handle request response: ',ARequest.FRequestID,', min: ',FMinLoadID,' Loadcount:',FLoadCount);
|
|
Case ARequest.Success of
|
|
rrFail:
|
|
begin
|
|
if Assigned(FOnLoadFail) then
|
|
FOnLoadFail(Self,aRequest.RequestID,aRequest.ErrorMsg);
|
|
end;
|
|
rrEOF,
|
|
rrOK :
|
|
begin
|
|
DataAdded:=False;
|
|
// Notify caller
|
|
if Assigned(ARequest.Event) then
|
|
ARequest.Event(Self,aRequest.Data);
|
|
// allow descendent to integrate data.
|
|
// Must be done before user is notified or dataset is opened...
|
|
if (ARequest.Success<>rrEOF) then
|
|
DataAdded:=DataPacketReceived(aRequest);
|
|
// Open if needed.
|
|
if Not (Active or (loNoOpen in aRequest.LoadOptions)) then
|
|
begin
|
|
// Notify user
|
|
if not (loNoEvents in aRequest.LoadOptions) then
|
|
DoAfterLoad;
|
|
Open
|
|
end
|
|
else
|
|
begin
|
|
if (loAtEOF in aRequest.LoadOptions) and DataAdded then
|
|
FEOF:=False;
|
|
if not (loNoEvents in aRequest.LoadOptions) then
|
|
DoAfterLoad;
|
|
end;
|
|
end;
|
|
end;
|
|
aRequest.Destroy;
|
|
end;
|
|
|
|
function TDataSet.DoResolveRecordUpdate(anUpdate: TRecordUpdateDescriptor): Boolean;
|
|
begin
|
|
Result:=True;
|
|
end;
|
|
|
|
procedure TDataSet.GetCalcFields(var Buffer: TDataRecord);
|
|
var
|
|
i: Integer;
|
|
OldState: TDatasetState;
|
|
begin
|
|
if (FCalcFieldsCount > 0) or FInternalCalcFields then
|
|
begin
|
|
OldState := FState;
|
|
FState := dsCalcFields;
|
|
try
|
|
CalculateFields(Buffer);
|
|
finally
|
|
FState := OldState;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TDataSet.GetCanModify: Boolean;
|
|
|
|
begin
|
|
Result:= not FIsUnidirectional;
|
|
end;
|
|
|
|
procedure TDataSet.GetChildren(Proc: TGetChildProc; Root: TComponent);
|
|
|
|
var
|
|
I: Integer;
|
|
Field: TField;
|
|
|
|
begin
|
|
for I := 0 to Fields.Count - 1 do begin
|
|
Field := Fields[I];
|
|
if (Field.Owner = Root) then
|
|
Proc(Field);
|
|
end;
|
|
end;
|
|
|
|
function TDataSet.GetDataSource: TDataSource;
|
|
begin
|
|
Result:=nil;
|
|
end;
|
|
|
|
function TDataSet.GetRecordSize: Word;
|
|
begin
|
|
Result := 0;
|
|
end;
|
|
|
|
procedure TDataSet.InternalAddRecord(Buffer: Pointer; AAppend: Boolean);
|
|
begin
|
|
// empty stub
|
|
end;
|
|
|
|
procedure TDataSet.InternalDelete;
|
|
begin
|
|
// empty stub
|
|
end;
|
|
|
|
procedure TDataSet.InternalFirst;
|
|
begin
|
|
// empty stub
|
|
end;
|
|
|
|
procedure TDataSet.InternalGotoBookmark(ABookmark: TBookmark);
|
|
begin
|
|
// empty stub
|
|
end;
|
|
|
|
procedure TDataSet.SetDataSetField(const Value: TDataSetField);
|
|
begin
|
|
if Value = FDataSetField then
|
|
exit;
|
|
if (Value <> nil) and ((Value.DataSet = Self) or
|
|
((Value.DataSet.GetDataSource <> nil) and
|
|
(Value.DataSet.GetDataSource.DataSet = Self))) then
|
|
DatabaseError(SCircularDataLink, Self);
|
|
if Assigned(Value) and not InheritsFrom(Value.DataSet.FNestedDataSetClass) then
|
|
DatabaseErrorFmt(SNestedDataSetClass, [Value.DataSet.FNestedDataSetClass.ClassName], Self);
|
|
if Active then
|
|
Close;
|
|
if Assigned(FDataSetField) then
|
|
FDataSetField.AssignNestedDataSet(nil);
|
|
FDataSetField := Value;
|
|
if Assigned(Value) then
|
|
begin
|
|
Value.AssignNestedDataSet(Self);
|
|
if Value.DataSet.Active then
|
|
Open;
|
|
end;
|
|
end;
|
|
|
|
function TDataSet.GetNestedDataSets: TNestedDataSetsList;
|
|
begin
|
|
if not Assigned(FNestedDataSets) then
|
|
FNestedDataSets := TNestedDataSetsList.Create;
|
|
Result := FNestedDataSets;
|
|
end;
|
|
|
|
function TDataSet.GetFieldData(Field: TField; Buffer: TDatarecord): JSValue;
|
|
|
|
begin
|
|
Result:=TJSObject(buffer.data).Properties[Field.FieldName];
|
|
if isUndefined(Result) then
|
|
Result:=Null;
|
|
end;
|
|
|
|
|
|
procedure TDataSet.SetFieldData(Field: TField; var Buffer: TDatarecord; AValue: JSValue);
|
|
|
|
begin
|
|
TJSObject(buffer.data).Properties[Field.FieldName]:=AValue;
|
|
end;
|
|
|
|
|
|
function TDataSet.GetFieldClass(FieldType: TFieldType): TFieldClass;
|
|
|
|
begin
|
|
Result := DefaultFieldClasses[FieldType];
|
|
end;
|
|
|
|
function TDataSet.GetIsIndexField(Field: TField): Boolean;
|
|
|
|
begin
|
|
Result:=False;
|
|
end;
|
|
|
|
function TDataSet.GetIndexDefs(IndexDefs: TIndexDefs; IndexTypes: TIndexOptions
|
|
): TIndexDefs;
|
|
|
|
var i,f : integer;
|
|
IndexFields : TStrings;
|
|
|
|
begin
|
|
IndexDefs.Update;
|
|
Result := TIndexDefs.Create(Self);
|
|
Result.Assign(IndexDefs);
|
|
i := 0;
|
|
IndexFields := TStringList.Create;
|
|
while i < result.Count do
|
|
begin
|
|
if (not ((IndexTypes = []) and (result[i].Options = []))) and
|
|
((IndexTypes * result[i].Options) = []) then
|
|
begin
|
|
result.Delete(i);
|
|
dec(i);
|
|
end
|
|
else
|
|
begin
|
|
// ExtractStrings([';'],[' '],result[i].Fields,Indexfields);
|
|
for f := 0 to IndexFields.Count-1 do
|
|
if FindField(Indexfields[f]) = nil then
|
|
begin
|
|
result.Delete(i);
|
|
dec(i);
|
|
break;
|
|
end;
|
|
end;
|
|
inc(i);
|
|
end;
|
|
IndexFields.Free;
|
|
end;
|
|
|
|
function TDataSet.GetNextRecord: Boolean;
|
|
|
|
Var
|
|
T : TDataRecord;
|
|
|
|
begin
|
|
{$ifdef dsdebug}
|
|
Writeln ('Getting next record. Internal RecordCount : ',FRecordCount);
|
|
Writeln ('Getting next record. Internal buffercount : ',FBufferCount);
|
|
{$endif}
|
|
If FRecordCount>0 Then
|
|
SetCurrentRecord(FRecordCount-1);
|
|
Result:=GetRecord(FBuffers[FBufferCount],gmNext,True)=grOK;
|
|
if Result then
|
|
begin
|
|
If FRecordCount=0 then ActivateBuffers;
|
|
if FRecordCount=FBufferCount then
|
|
ShiftBuffersBackward
|
|
else
|
|
begin
|
|
Inc(FRecordCount);
|
|
FCurrentRecord:=FRecordCount - 1;
|
|
T:=FBuffers[FCurrentRecord];
|
|
FBuffers[FCurrentRecord]:=FBuffers[FBufferCount];
|
|
FBuffers[FBufferCount]:=T;
|
|
end;
|
|
end
|
|
else
|
|
CursorPosChanged;
|
|
{$ifdef dsdebug}
|
|
Writeln ('Result getting next record : ',Result);
|
|
{$endif}
|
|
end;
|
|
|
|
function TDataSet.GetNextRecords: Longint;
|
|
|
|
begin
|
|
Result:=0;
|
|
{$ifdef dsdebug}
|
|
Writeln ('Getting next record(s), need :',FBufferCount);
|
|
{$endif}
|
|
While (FRecordCount<FBufferCount) and GetNextRecord do
|
|
Inc(Result);
|
|
{$ifdef dsdebug}
|
|
Writeln ('Result Getting next record(S), GOT :',RESULT);
|
|
{$endif}
|
|
end;
|
|
|
|
function TDataSet.GetPriorRecord: Boolean;
|
|
|
|
begin
|
|
{$ifdef dsdebug}
|
|
Writeln ('GetPriorRecord: Getting previous record');
|
|
{$endif}
|
|
CheckBiDirectional;
|
|
If FRecordCount>0 Then SetCurrentRecord(0);
|
|
Result:=GetRecord(FBuffers[FBufferCount],gmPrior,True)=grOK;
|
|
if Result then
|
|
begin
|
|
If FRecordCount=0 then ActivateBuffers;
|
|
ShiftBuffersForward;
|
|
|
|
if FRecordCount<FBufferCount then
|
|
Inc(FRecordCount);
|
|
end
|
|
else
|
|
CursorPosChanged;
|
|
{$ifdef dsdebug}
|
|
Writeln ('Result getting prior record : ',Result);
|
|
{$endif}
|
|
end;
|
|
|
|
function TDataSet.GetPriorRecords: Longint;
|
|
|
|
begin
|
|
Result:=0;
|
|
{$ifdef dsdebug}
|
|
Writeln ('Getting previous record(s), need :',FBufferCount);
|
|
{$endif}
|
|
While (FRecordCount<FBufferCount) and GetPriorRecord do
|
|
Inc(Result);
|
|
end;
|
|
|
|
function TDataSet.GetRecNo: Longint;
|
|
|
|
begin
|
|
Result := -1;
|
|
end;
|
|
|
|
function TDataSet.GetRecordCount: Longint;
|
|
|
|
begin
|
|
Result := -1;
|
|
end;
|
|
|
|
procedure TDataSet.InitFieldDefs;
|
|
|
|
begin
|
|
if IsCursorOpen then
|
|
InternalInitFieldDefs
|
|
else
|
|
begin
|
|
try
|
|
OpenCursor(True);
|
|
finally
|
|
CloseCursor;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.SetBlockReadSize(AValue: Integer);
|
|
begin
|
|
// the state is changed even when setting the same BlockReadSize (follows Delphi behavior)
|
|
// e.g., state is dsBrowse and BlockReadSize is 1. Setting BlockReadSize to 1 will change state to dsBlockRead
|
|
FBlockReadSize := AValue;
|
|
if AValue > 0 then
|
|
begin
|
|
CheckActive;
|
|
SetState(dsBlockRead);
|
|
end
|
|
else
|
|
begin
|
|
//update state only when in dsBlockRead
|
|
if FState = dsBlockRead then
|
|
SetState(dsBrowse);
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.SetFieldDefs(AFieldDefs: TFieldDefs);
|
|
|
|
begin
|
|
Fields.ClearFieldDefs;
|
|
FFieldDefs.Assign(AFieldDefs);
|
|
end;
|
|
|
|
procedure TDataSet.DoInsertAppendRecord(const Values: array of jsValue; DoAppend: boolean);
|
|
var i : integer;
|
|
ValuesSize : integer;
|
|
begin
|
|
ValuesSize:=Length(Values);
|
|
if ValuesSize>FieldCount then DatabaseError(STooManyFields,self);
|
|
if DoAppend then
|
|
Append
|
|
else
|
|
Insert;
|
|
for i := 0 to ValuesSize-1 do
|
|
Fields[i].AssignValue(Values[i]);
|
|
Post;
|
|
end;
|
|
|
|
procedure TDataSet.InitFieldDefsFromfields;
|
|
var i : integer;
|
|
|
|
begin
|
|
if FieldDefs.Count = 0 then
|
|
begin
|
|
FieldDefs.BeginUpdate;
|
|
try
|
|
for i := 0 to Fields.Count-1 do with Fields[i] do
|
|
if not (FieldKind in [fkCalculated,fkLookup]) then // Do not add fielddefs for calculated/lookup fields.
|
|
begin
|
|
FFieldDef:=FieldDefs.FieldDefClass.Create(FieldDefs,FieldName,DataType,Size,Required,FieldDefs.Count+1);
|
|
with FFieldDef do
|
|
begin
|
|
if Required then Attributes := Attributes + [faRequired];
|
|
if ReadOnly then Attributes := Attributes + [faReadOnly];
|
|
end;
|
|
end;
|
|
finally
|
|
FieldDefs.EndUpdate;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.InitRecord(var Buffer: TDataRecord);
|
|
|
|
begin
|
|
InternalInitRecord(Buffer);
|
|
ClearCalcFields(Buffer);
|
|
end;
|
|
|
|
procedure TDataSet.InternalCancel;
|
|
|
|
begin
|
|
//!! To be implemented
|
|
end;
|
|
|
|
procedure TDataSet.InternalEdit;
|
|
|
|
begin
|
|
//!! To be implemented
|
|
end;
|
|
|
|
procedure TDataSet.InternalRefresh;
|
|
|
|
begin
|
|
//!! To be implemented
|
|
end;
|
|
|
|
procedure TDataSet.OpenCursor(InfoQuery: Boolean);
|
|
|
|
begin
|
|
if InfoQuery then
|
|
InternalInitFieldDefs
|
|
else if State <> dsOpening then
|
|
DoInternalOpen;
|
|
end;
|
|
|
|
procedure TDataSet.OpenCursorcomplete;
|
|
begin
|
|
try
|
|
if FState = dsOpening then DoInternalOpen
|
|
finally
|
|
if FInternalOpenComplete then
|
|
begin
|
|
SetState(dsBrowse);
|
|
DoAfterOpen;
|
|
if not IsEmpty then
|
|
DoAfterScroll;
|
|
end
|
|
else
|
|
begin
|
|
SetState(dsInactive);
|
|
CloseCursor;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.RefreshInternalCalcFields(var Buffer: TDataRecord);
|
|
|
|
begin
|
|
//!! To be implemented
|
|
end;
|
|
|
|
function TDataSet.SetTempState(const Value: TDataSetState): TDataSetState;
|
|
|
|
begin
|
|
result := FState;
|
|
FState := value;
|
|
inc(FDisableControlsCount);
|
|
end;
|
|
|
|
procedure TDataSet.RestoreState(const Value: TDataSetState);
|
|
|
|
begin
|
|
FState := value;
|
|
dec(FDisableControlsCount);
|
|
end;
|
|
|
|
function TDataSet.GetActive: boolean;
|
|
|
|
begin
|
|
result := (FState <> dsInactive) and (FState <> dsOpening);
|
|
end;
|
|
|
|
procedure TDataSet.InternalHandleException(E :Exception);
|
|
|
|
begin
|
|
ShowException(E,Nil);
|
|
end;
|
|
|
|
procedure TDataSet.InternalInitRecord(var Buffer: TDataRecord);
|
|
begin
|
|
// empty stub
|
|
end;
|
|
|
|
procedure TDataSet.InternalLast;
|
|
begin
|
|
// empty stub
|
|
end;
|
|
|
|
procedure TDataSet.InternalPost;
|
|
|
|
Procedure CheckRequiredFields;
|
|
|
|
Var I : longint;
|
|
|
|
begin
|
|
For I:=0 to FFieldList.Count-1 do
|
|
With FFieldList[i] do
|
|
// Required fields that are NOT autoinc !! Autoinc cannot be set !!
|
|
if Required and not ReadOnly and
|
|
(FieldKind=fkData) and Not (DataType=ftAutoInc) and IsNull then
|
|
DatabaseErrorFmt(SNeedField,[DisplayName],Self);
|
|
end;
|
|
|
|
begin
|
|
CheckRequiredFields;
|
|
end;
|
|
|
|
procedure TDataSet.InternalSetToRecord(Buffer: TDataRecord);
|
|
begin
|
|
// empty stub
|
|
end;
|
|
|
|
procedure TDataSet.SetBookmarkFlag(var Buffer: TDataRecord; Value: TBookmarkFlag);
|
|
begin
|
|
// empty stub
|
|
end;
|
|
|
|
procedure TDataSet.SetBookmarkData(var Buffer: TDataRecord; Data: TBookmark);
|
|
begin
|
|
// empty stub
|
|
end;
|
|
|
|
procedure TDataSet.SetUniDirectional(const Value: Boolean);
|
|
begin
|
|
FIsUniDirectional := Value;
|
|
end;
|
|
|
|
procedure TDataSet.Notification(AComponent: TComponent; Operation: TOperation);
|
|
begin
|
|
inherited Notification(AComponent, Operation);
|
|
if (Operation=opRemove) and (AComponent=FDataProxy) then
|
|
FDataProxy:=Nil;
|
|
end;
|
|
|
|
class function TDataSet.FieldDefsClass: TFieldDefsClass;
|
|
begin
|
|
Result:=TFieldDefs;
|
|
end;
|
|
|
|
class function TDataSet.FieldsClass: TFieldsClass;
|
|
begin
|
|
Result:=TFields;
|
|
end;
|
|
|
|
procedure TDataSet.SetActive(Value: Boolean);
|
|
|
|
begin
|
|
if value and (Fstate = dsInactive) then
|
|
begin
|
|
if csLoading in ComponentState then
|
|
begin
|
|
FOpenAfterRead := true;
|
|
exit;
|
|
end
|
|
else
|
|
begin
|
|
DoBeforeOpen;
|
|
FEnableControlsEvent:=deLayoutChange;
|
|
FInternalCalcFields:=False;
|
|
try
|
|
FDefaultFields:=FieldCount=0;
|
|
OpenCursor(False);
|
|
finally
|
|
if FState <> dsOpening then OpenCursorComplete;
|
|
end;
|
|
end;
|
|
FModified:=False;
|
|
end
|
|
else if not value and (Fstate <> dsinactive) then
|
|
begin
|
|
DoBeforeClose;
|
|
SetState(dsInactive);
|
|
DoneChangeList;
|
|
CloseCursor;
|
|
DoAfterClose;
|
|
FModified:=False;
|
|
end
|
|
end;
|
|
|
|
procedure TDataSet.Loaded;
|
|
|
|
begin
|
|
inherited;
|
|
try
|
|
if FOpenAfterRead then SetActive(true);
|
|
except
|
|
on E : Exception do
|
|
if csDesigning in Componentstate then
|
|
InternalHandleException(E);
|
|
else
|
|
raise;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TDataSet.RecalcBufListSize;
|
|
|
|
var
|
|
i, j, ABufferCount: Integer;
|
|
DataLink: TDataLink;
|
|
|
|
begin
|
|
{$ifdef dsdebug}
|
|
Writeln('Recalculating buffer list size - check cursor');
|
|
{$endif}
|
|
If Not IsCursorOpen Then
|
|
Exit;
|
|
{$ifdef dsdebug}
|
|
Writeln('Recalculating buffer list size');
|
|
{$endif}
|
|
if IsUniDirectional then
|
|
ABufferCount := 1
|
|
else
|
|
ABufferCount := DefaultBufferCount;
|
|
{$ifdef dsdebug}
|
|
Writeln('Recalculating buffer list size, start count: ',ABufferCount);
|
|
{$endif}
|
|
for i := 0 to FDataSources.Count - 1 do
|
|
for j := 0 to TDataSource(FDataSources[i]).DataLinks.Count - 1 do
|
|
begin
|
|
DataLink:=TDataLink(TDataSource(FDataSources[i]).DataLinks[j]);
|
|
if ABufferCount<DataLink.BufferCount then
|
|
ABufferCount:=DataLink.BufferCount;
|
|
end;
|
|
{$ifdef dsdebug}
|
|
Writeln('Recalculating buffer list size, end count: ',ABufferCount);
|
|
{$endif}
|
|
|
|
If (FBufferCount=ABufferCount) Then
|
|
exit;
|
|
|
|
{$ifdef dsdebug}
|
|
Writeln('Setting buffer list size');
|
|
{$endif}
|
|
SetBufListSize(ABufferCount);
|
|
{$ifdef dsdebug}
|
|
Writeln('Getting next buffers');
|
|
{$endif}
|
|
GetNextRecords;
|
|
if (FRecordCount < FBufferCount) and not IsUniDirectional then
|
|
begin
|
|
FActiveRecord := FActiveRecord + GetPriorRecords;
|
|
CursorPosChanged;
|
|
end;
|
|
{$Ifdef dsDebug}
|
|
WriteLn(
|
|
'SetBufferCount: FActiveRecord=',FActiveRecord,
|
|
' FCurrentRecord=',FCurrentRecord,
|
|
' FBufferCount= ',FBufferCount,
|
|
' FRecordCount=',FRecordCount);
|
|
{$Endif}
|
|
end;
|
|
|
|
procedure TDataSet.SetBookmarkStr(const Value: TBookmarkStr);
|
|
|
|
Var
|
|
O: TJSObject;
|
|
B : TBookmark;
|
|
|
|
begin
|
|
O:=TJSJSON.parseObject(Value);
|
|
B.Flag:=TBookmarkFlag(O.Properties['flag']);
|
|
B.Data:=O.Properties['Index'];
|
|
GotoBookMark(B)
|
|
end;
|
|
|
|
procedure TDataSet.SetBufListSize(Value: Longint);
|
|
|
|
Var
|
|
I : Integer;
|
|
|
|
begin
|
|
if Value < 0 then Value := 0;
|
|
If Value=FBufferCount Then
|
|
exit;
|
|
// Less buffers, shift buffers.
|
|
if value>FBufferCount then
|
|
begin
|
|
SetLength(FBuffers,Value+1); // FBuffers[FBufferCount] is used as a temp buffer
|
|
For I:=FBufferCount to Value do
|
|
FBuffers[i]:=AllocRecordBuffer;
|
|
end
|
|
else if value<FBufferCount then
|
|
if (value>=0) and (FActiveRecord>Value-1) then
|
|
begin
|
|
for i := 0 to (FActiveRecord-Value) do
|
|
ShiftBuffersBackward;
|
|
FActiveRecord := Value -1;
|
|
end;
|
|
SetLength(FBuffers,Value+1); // FBuffers[FBufferCount] is used as a temp buffer
|
|
FBufferCount:=Value;
|
|
if FRecordCount > FBufferCount then
|
|
FRecordCount := FBufferCount;
|
|
|
|
end;
|
|
|
|
procedure TDataSet.SetChildOrder(Child: TComponent; Order: Longint);
|
|
|
|
var
|
|
Field: TField;
|
|
begin
|
|
Field := Child as TField;
|
|
if Fields.IndexOf(Field) >= 0 then
|
|
Field.Index := Order;
|
|
end;
|
|
|
|
procedure TDataSet.SetCurrentRecord(Index: Longint);
|
|
|
|
begin
|
|
If FCurrentRecord<>Index then
|
|
begin
|
|
{$ifdef DSdebug}
|
|
Writeln ('Setting current record to: ',index);
|
|
{$endif}
|
|
if not FIsUniDirectional then Case GetBookMarkFlag(FBuffers[Index]) of
|
|
bfCurrent : InternalSetToRecord(FBuffers[Index]);
|
|
bfBOF : InternalFirst;
|
|
bfEOF : InternalLast;
|
|
end;
|
|
FCurrentRecord:=Index;
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.SetDefaultFields(const Value: Boolean);
|
|
begin
|
|
FDefaultFields := Value;
|
|
end;
|
|
|
|
procedure TDataSet.CheckBiDirectional;
|
|
|
|
begin
|
|
if FIsUniDirectional then DataBaseError(SUniDirectional,Self);
|
|
end;
|
|
|
|
procedure TDataSet.SetFilterOptions(Value: TFilterOptions);
|
|
|
|
begin
|
|
CheckBiDirectional;
|
|
FFilterOptions := Value;
|
|
end;
|
|
|
|
procedure TDataSet.SetFilterText(const Value: string);
|
|
|
|
begin
|
|
FFilterText := value;
|
|
end;
|
|
|
|
procedure TDataSet.SetFiltered(Value: Boolean);
|
|
|
|
begin
|
|
if Value then CheckBiDirectional;
|
|
FFiltered := value;
|
|
end;
|
|
|
|
procedure TDataSet.SetFound(const Value: Boolean);
|
|
begin
|
|
FFound := Value;
|
|
end;
|
|
|
|
procedure TDataSet.SetModified(Value: Boolean);
|
|
|
|
begin
|
|
FModified := value;
|
|
end;
|
|
|
|
procedure TDataSet.SetName(const NewName: TComponentName);
|
|
|
|
function CheckName(const FieldName: string): string;
|
|
var i,j: integer;
|
|
begin
|
|
Result := FieldName;
|
|
i := 0;
|
|
j := 0;
|
|
while (i < Fields.Count) do begin
|
|
if Result = Fields[i].FieldName then begin
|
|
inc(j);
|
|
Result := FieldName + IntToStr(j);
|
|
end else Inc(i);
|
|
end;
|
|
end;
|
|
|
|
var
|
|
i: integer;
|
|
nm: string;
|
|
old: string;
|
|
|
|
begin
|
|
if Self.Name = NewName then Exit;
|
|
old := Self.Name;
|
|
inherited SetName(NewName);
|
|
if (csDesigning in ComponentState) then
|
|
for i := 0 to Fields.Count - 1 do begin
|
|
nm := old + Fields[i].FieldName;
|
|
if Copy(Fields[i].Name, 1, Length(nm)) = nm then
|
|
Fields[i].Name := CheckName(NewName + Fields[i].FieldName);
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.SetOnFilterRecord(const Value: TFilterRecordEvent);
|
|
|
|
begin
|
|
CheckBiDirectional;
|
|
FOnFilterRecord := Value;
|
|
end;
|
|
|
|
procedure TDataSet.SetRecNo(Value: Longint);
|
|
|
|
begin
|
|
//!! To be implemented
|
|
end;
|
|
|
|
procedure TDataSet.SetState(Value: TDataSetState);
|
|
|
|
begin
|
|
If Value<>FState then
|
|
begin
|
|
FState:=Value;
|
|
if Value=dsBrowse then
|
|
FModified:=false;
|
|
DataEvent(deUpdateState,0);
|
|
end;
|
|
end;
|
|
|
|
function TDataSet.TempBuffer: TDataRecord;
|
|
|
|
begin
|
|
Result := FBuffers[FRecordCount];
|
|
end;
|
|
|
|
procedure TDataSet.UpdateIndexDefs;
|
|
|
|
begin
|
|
// Empty Abstract
|
|
end;
|
|
|
|
function TDataSet.AllocRecordBuffer: TDataRecord;
|
|
begin
|
|
Result.data:=Null;
|
|
Result.state:=rsNew;
|
|
// Result := nil;
|
|
end;
|
|
|
|
procedure TDataSet.FreeRecordBuffer(var Buffer: TDataRecord);
|
|
begin
|
|
// empty stub
|
|
end;
|
|
|
|
procedure TDataSet.GetBookmarkData(Buffer: TDataRecord; var Data: TBookmark);
|
|
begin
|
|
|
|
end;
|
|
|
|
|
|
function TDataSet.GetBookmarkFlag(Buffer: TDataRecord): TBookmarkFlag;
|
|
begin
|
|
Result := bfCurrent;
|
|
end;
|
|
|
|
function TDataSet.ControlsDisabled: Boolean;
|
|
|
|
begin
|
|
Result := (FDisableControlsCount > 0);
|
|
end;
|
|
|
|
function TDataSet.ActiveBuffer: TDataRecord;
|
|
|
|
begin
|
|
{$ifdef dsdebug}
|
|
Writeln ('Active buffer requested. Returning record number: ',ActiveRecord);
|
|
{$endif}
|
|
if FactiveRecord<>-1 then
|
|
Result:=FBuffers[FActiveRecord]
|
|
else
|
|
Result:=Default(TDataRecord);
|
|
end;
|
|
|
|
function TDataSet.GetFieldData(Field: TField): JSValue;
|
|
begin
|
|
Result:=GetFieldData(Field,ActiveBuffer);
|
|
end;
|
|
|
|
procedure TDataSet.SetFieldData(Field: TField; AValue: JSValue);
|
|
begin
|
|
SetFieldData(Field,FBuffers[FActiveRecord],AValue);
|
|
end;
|
|
|
|
procedure TDataSet.Append;
|
|
|
|
begin
|
|
DoInsertAppend(True);
|
|
end;
|
|
|
|
procedure TDataSet.InternalInsert;
|
|
|
|
begin
|
|
//!! To be implemented
|
|
end;
|
|
|
|
procedure TDataSet.AppendRecord(const Values: array of jsValue);
|
|
|
|
begin
|
|
DoInsertAppendRecord(Values,True);
|
|
end;
|
|
|
|
function TDataSet.BookmarkValid(ABookmark: TBookmark): Boolean;
|
|
{
|
|
Should be overridden by descendant objects.
|
|
}
|
|
begin
|
|
Result:=False
|
|
end;
|
|
|
|
|
|
|
|
function TDataSet.ConvertToDateTime(aField: TField; aValue: JSValue; ARaiseException: Boolean): TDateTime;
|
|
begin
|
|
Result:=DefaultConvertToDateTime(aField,aValue,ARaiseException);
|
|
end;
|
|
|
|
class function TDataSet.DefaultConvertToDateTime(aField: TField; aValue: JSValue; ARaiseException: Boolean): TDateTime;
|
|
begin
|
|
Result:=0;
|
|
if IsString(aValue) then
|
|
begin
|
|
if not TryRFC3339ToDateTime(String(AValue),Result) then
|
|
Raise EConvertError.CreateFmt(SErrInvalidDateTime,[String(aValue)])
|
|
end
|
|
else if IsNumber(aValue) then
|
|
Result:=TDateTime(AValue)
|
|
else if IsDate(aValue) then
|
|
Result:=JSDateToDateTime(TJSDate(aValue));
|
|
end;
|
|
|
|
function TDataSet.ConvertDateTimeToNative(aField: TField; aValue : TDateTime) : JSValue;
|
|
|
|
begin
|
|
Result:=DefaultConvertDateTimeToNative(aField, aValue);
|
|
end;
|
|
|
|
class function TDataSet.DefaultConvertDateTimeToNative(aField: TField; aValue: TDateTime): JSValue;
|
|
|
|
begin
|
|
Result:=DateTimeToRFC3339(aValue);
|
|
end;
|
|
|
|
function TDataSet.BlobDataToBytes(aValue: JSValue): TBytes;
|
|
begin
|
|
Result:=DefaultBlobDataToBytes(aValue);
|
|
end;
|
|
|
|
class function TDataSet.DefaultBlobDataToBytes(aValue: JSValue): TBytes;
|
|
|
|
Var
|
|
S : String;
|
|
I,J,L : Integer;
|
|
|
|
begin
|
|
SetLength(Result,0);
|
|
// We assume a string, hex-encoded.
|
|
if isString(AValue) then
|
|
begin
|
|
S:=String(Avalue);
|
|
L:=Length(S);
|
|
SetLength(Result,(L+1) div 2);
|
|
I:=1;
|
|
J:=0;
|
|
While (I<L) do
|
|
begin
|
|
Result[J]:=StrToInt('$'+Copy(S,I,2));
|
|
Inc(I,2);
|
|
Inc(J,1);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TDataSet.BytesToBlobData(aValue: TBytes): JSValue;
|
|
|
|
begin
|
|
Result:=DefaultBytesToBlobData(aValue);
|
|
end;
|
|
|
|
class function TDataSet.DefaultBytesToBlobData(aValue: TBytes): JSValue;
|
|
|
|
Var
|
|
S : String;
|
|
I : Integer;
|
|
|
|
begin
|
|
if Length(AValue)=0 then
|
|
Result:=Null
|
|
else
|
|
begin
|
|
S:='';
|
|
For I:=0 to Length(AValue)-1 do
|
|
S:=TJSString(S).Concat(IntToHex(aValue[i],2));
|
|
Result:=S;
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.Cancel;
|
|
|
|
begin
|
|
If State in [dsEdit,dsInsert] then
|
|
begin
|
|
DataEvent(deCheckBrowseMode,0);
|
|
DoBeforeCancel;
|
|
UpdateCursorPos;
|
|
InternalCancel;
|
|
if (State = dsInsert) and (FRecordCount = 1) then
|
|
begin
|
|
FEOF := true;
|
|
FBOF := true;
|
|
FRecordCount := 0;
|
|
InitRecord(FBuffers[FActiveRecord]);
|
|
SetState(dsBrowse);
|
|
DataEvent(deDatasetChange,0);
|
|
end
|
|
else
|
|
begin
|
|
SetState(dsBrowse);
|
|
SetCurrentRecord(FActiveRecord);
|
|
resync([]);
|
|
end;
|
|
DoAfterCancel;
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.CheckBrowseMode;
|
|
|
|
begin
|
|
CheckActive;
|
|
DataEvent(deCheckBrowseMode,0);
|
|
Case State of
|
|
dsEdit,dsInsert:
|
|
begin
|
|
UpdateRecord;
|
|
If Modified then
|
|
Post
|
|
else
|
|
Cancel;
|
|
end;
|
|
dsSetKey: Post;
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.ClearFields;
|
|
|
|
|
|
begin
|
|
DataEvent(deCheckBrowseMode, 0);
|
|
InternalInitRecord(FBuffers[FActiveRecord]);
|
|
if State <> dsSetKey then
|
|
GetCalcFields(FBuffers[FActiveRecord]);
|
|
DataEvent(deRecordChange, 0);
|
|
end;
|
|
|
|
procedure TDataSet.Close;
|
|
|
|
begin
|
|
Active:=False;
|
|
end;
|
|
|
|
procedure TDataSet.ApplyUpdates;
|
|
begin
|
|
DoBeforeApplyUpdates;
|
|
DoApplyUpdates;
|
|
end;
|
|
|
|
function TDataSet.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Longint;
|
|
|
|
begin
|
|
Result:=0;
|
|
end;
|
|
|
|
procedure TDataSet.CursorPosChanged;
|
|
|
|
|
|
begin
|
|
FCurrentRecord:=-1;
|
|
end;
|
|
|
|
procedure TDataSet.Delete;
|
|
|
|
Var
|
|
R : TRecordUpdateDescriptor;
|
|
|
|
begin
|
|
If Not CanModify then
|
|
DatabaseError(SDatasetReadOnly,Self);
|
|
If IsEmpty then
|
|
DatabaseError(SDatasetEmpty,Self);
|
|
if State in [dsInsert] then
|
|
begin
|
|
Cancel;
|
|
end else begin
|
|
DataEvent(deCheckBrowseMode,0);
|
|
{$ifdef dsdebug}
|
|
writeln ('Delete: checking required fields');
|
|
{$endif}
|
|
DoBeforeDelete;
|
|
DoBeforeScroll;
|
|
R:=AddToChangeList(usDeleted);
|
|
If Not TryDoing(@InternalDelete,OnDeleteError) then
|
|
begin
|
|
if Assigned(R) then
|
|
RemoveFromChangeList(R);
|
|
exit;
|
|
end;
|
|
{$ifdef dsdebug}
|
|
writeln ('Delete: Internaldelete succeeded');
|
|
{$endif}
|
|
SetState(dsBrowse);
|
|
{$ifdef dsdebug}
|
|
writeln ('Delete: Browse mode set');
|
|
{$endif}
|
|
SetCurrentRecord(FActiveRecord);
|
|
Resync([]);
|
|
DoAfterDelete;
|
|
DoAfterScroll;
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.DisableControls;
|
|
|
|
|
|
begin
|
|
If FDisableControlsCount=0 then
|
|
begin
|
|
{ Save current state,
|
|
needed to detect change of state when enabling controls.
|
|
}
|
|
FDisableControlsState:=FState;
|
|
FEnableControlsEvent:=deDatasetChange;
|
|
end;
|
|
Inc(FDisableControlsCount);
|
|
end;
|
|
|
|
procedure TDataSet.DoInsertAppend(DoAppend: Boolean);
|
|
|
|
|
|
procedure DoInsert(DoAppend : Boolean);
|
|
|
|
Var
|
|
BookBeforeInsert : TBookmark;
|
|
TempBuf : TDataRecord;
|
|
I : integer;
|
|
|
|
begin
|
|
// need to scroll up al buffers after current one,
|
|
// but copy current bookmark to insert buffer.
|
|
If FRecordCount > 0 then
|
|
BookBeforeInsert:=Bookmark;
|
|
|
|
if not DoAppend then
|
|
begin
|
|
if FRecordCount > 0 then
|
|
begin
|
|
TempBuf := FBuffers[FBufferCount];
|
|
for I:=FBufferCount downto FActiveRecord+1 do
|
|
FBuffers[I]:=FBuffers[I-1];
|
|
FBuffers[FActiveRecord]:=TempBuf;
|
|
end;
|
|
end
|
|
else if FRecordCount=FBufferCount then
|
|
ShiftBuffersBackward
|
|
else
|
|
begin
|
|
if FRecordCount>0 then
|
|
inc(FActiveRecord);
|
|
end;
|
|
|
|
// Active buffer is now edit buffer. Initialize.
|
|
InitRecord(FBuffers[FActiveRecord]);
|
|
CursorPosChanged;
|
|
|
|
// Put bookmark in edit buffer.
|
|
if FRecordCount=0 then
|
|
SetBookmarkFlag(FBuffers[FActiveRecord],bfEOF)
|
|
else
|
|
begin
|
|
fBOF := false;
|
|
// 29:01:05, JvdS: Why is this here?!? It can result in records with the same bookmark-data?
|
|
// I would say that the 'internalinsert' should do this. But I don't know how Tdbf handles it
|
|
|
|
// 1-apr-06, JvdS: It just sets the bookmark of the newly inserted record to the place
|
|
// where the record should be inserted. So it is ok.
|
|
if FRecordCount > 0 then
|
|
begin
|
|
SetBookMarkData(FBuffers[FActiveRecord],BookBeforeInsert);
|
|
FreeBookmark(BookBeforeInsert);
|
|
end;
|
|
end;
|
|
|
|
InternalInsert;
|
|
|
|
// update buffer count.
|
|
If FRecordCount<FBufferCount then
|
|
Inc(FRecordCount);
|
|
end;
|
|
|
|
begin
|
|
CheckBrowseMode;
|
|
If Not CanModify then
|
|
DatabaseError(SDatasetReadOnly,Self);
|
|
DoBeforeInsert;
|
|
DoBeforeScroll;
|
|
If Not DoAppend then
|
|
begin
|
|
{$ifdef dsdebug}
|
|
Writeln ('going to insert mode');
|
|
{$endif}
|
|
DoInsert(false);
|
|
end
|
|
else
|
|
begin
|
|
{$ifdef dsdebug}
|
|
Writeln ('going to append mode');
|
|
{$endif}
|
|
ClearBuffers;
|
|
InternalLast;
|
|
GetPriorRecords;
|
|
if FRecordCount>0 then
|
|
FActiveRecord:=FRecordCount-1;
|
|
DoInsert(True);
|
|
SetBookmarkFlag(FBuffers[FActiveRecord],bfEOF);
|
|
FBOF :=False;
|
|
FEOF := true;
|
|
end;
|
|
SetState(dsInsert);
|
|
try
|
|
DoOnNewRecord;
|
|
except
|
|
SetCurrentRecord(FActiveRecord);
|
|
resync([]);
|
|
raise;
|
|
end;
|
|
// mark as not modified.
|
|
FModified:=False;
|
|
// Final events.
|
|
DataEvent(deDatasetChange,0);
|
|
DoAfterInsert;
|
|
DoAfterScroll;
|
|
{$ifdef dsdebug}
|
|
Writeln ('Done with append');
|
|
{$endif}
|
|
end;
|
|
|
|
procedure TDataSet.Edit;
|
|
|
|
begin
|
|
If State in [dsEdit,dsInsert] then exit;
|
|
CheckBrowseMode;
|
|
If Not CanModify then
|
|
DatabaseError(SDatasetReadOnly,Self);
|
|
If FRecordCount = 0 then
|
|
begin
|
|
Append;
|
|
Exit;
|
|
end;
|
|
DoBeforeEdit;
|
|
If Not TryDoing(@InternalEdit,OnEditError) then exit;
|
|
GetCalcFields(FBuffers[FActiveRecord]);
|
|
SetState(dsEdit);
|
|
DataEvent(deRecordChange,0);
|
|
DoAfterEdit;
|
|
end;
|
|
|
|
procedure TDataSet.EnableControls;
|
|
|
|
|
|
begin
|
|
if FDisableControlsCount > 0 then
|
|
Dec(FDisableControlsCount);
|
|
|
|
if FDisableControlsCount = 0 then begin
|
|
if FState <> FDisableControlsState then
|
|
DataEvent(deUpdateState, 0);
|
|
|
|
if (FState <> dsInactive) and (FDisableControlsState <> dsInactive) then
|
|
DataEvent(FEnableControlsEvent, 0);
|
|
end;
|
|
end;
|
|
|
|
function TDataSet.FieldByName(const FieldName: string): TField;
|
|
|
|
|
|
begin
|
|
Result:=FindField(FieldName);
|
|
If Result=Nil then
|
|
DatabaseErrorFmt(SFieldNotFound,[FieldName],Self);
|
|
end;
|
|
|
|
function TDataSet.FindField(const FieldName: string): TField;
|
|
|
|
|
|
begin
|
|
Result:=FFieldList.FindField(FieldName);
|
|
end;
|
|
|
|
function TDataSet.FindFirst: Boolean;
|
|
|
|
|
|
begin
|
|
Result:=False;
|
|
end;
|
|
|
|
function TDataSet.FindLast: Boolean;
|
|
|
|
|
|
begin
|
|
Result:=False;
|
|
end;
|
|
|
|
function TDataSet.FindNext: Boolean;
|
|
|
|
|
|
begin
|
|
Result:=False;
|
|
end;
|
|
|
|
function TDataSet.FindPrior: Boolean;
|
|
|
|
|
|
begin
|
|
Result:=False;
|
|
end;
|
|
|
|
procedure TDataSet.First;
|
|
|
|
|
|
begin
|
|
CheckBrowseMode;
|
|
DoBeforeScroll;
|
|
if not FIsUniDirectional then
|
|
ClearBuffers
|
|
else if not FBof then
|
|
begin
|
|
Active := False;
|
|
Active := True;
|
|
end;
|
|
try
|
|
InternalFirst;
|
|
if not FIsUniDirectional then GetNextRecords;
|
|
finally
|
|
FBOF:=True;
|
|
DataEvent(deDatasetChange,0);
|
|
DoAfterScroll;
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.FreeBookmark(ABookmark: TBookmark);
|
|
|
|
|
|
begin
|
|
{$ifdef noautomatedbookmark}
|
|
FreeMem(ABookMark,FBookMarkSize);
|
|
{$endif}
|
|
end;
|
|
|
|
function TDataSet.GetBookmark: TBookmark;
|
|
|
|
|
|
begin
|
|
if BookmarkAvailable then
|
|
GetBookMarkdata(ActiveBuffer,Result)
|
|
else
|
|
Result.Data:=Null;
|
|
end;
|
|
|
|
function TDataSet.GetCurrentRecord(Buffer: TDataRecord): Boolean;
|
|
|
|
|
|
begin
|
|
Result:=False;
|
|
end;
|
|
|
|
procedure TDataSet.GetFieldList(List: TList; const FieldNames: string);
|
|
|
|
var
|
|
F: TField;
|
|
N: String;
|
|
StrPos: Integer;
|
|
|
|
begin
|
|
if (FieldNames = '') or (List = nil) then
|
|
Exit;
|
|
StrPos := 1;
|
|
repeat
|
|
N := ExtractFieldName(FieldNames, StrPos);
|
|
F := FieldByName(N);
|
|
List.Add(F);
|
|
until StrPos > Length(FieldNames);
|
|
end;
|
|
|
|
procedure TDataSet.GetFieldList(List: TFPList; const FieldNames: string);
|
|
var
|
|
F: TField;
|
|
N: String;
|
|
StrPos: Integer;
|
|
|
|
begin
|
|
if (FieldNames = '') or (List = nil) then
|
|
Exit;
|
|
StrPos := 1;
|
|
repeat
|
|
N := ExtractFieldName(FieldNames, StrPos);
|
|
F := FieldByName(N);
|
|
List.Add(F);
|
|
until StrPos > Length(FieldNames);
|
|
end;
|
|
|
|
procedure TDataSet.GetFieldNames(List: TStrings);
|
|
|
|
|
|
begin
|
|
FFieldList.GetFieldNames(List);
|
|
end;
|
|
|
|
procedure TDataSet.GotoBookmark(const ABookmark: TBookmark);
|
|
|
|
|
|
begin
|
|
If Not IsNull(ABookMark.Data) then
|
|
begin
|
|
CheckBrowseMode;
|
|
DoBeforeScroll;
|
|
{$ifdef dsdebug}
|
|
Writeln('Gotobookmark: ',ABookMark.Data);
|
|
{$endif}
|
|
InternalGotoBookMark(ABookMark);
|
|
Resync([rmExact,rmCenter]);
|
|
DoAfterScroll;
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.Insert;
|
|
|
|
begin
|
|
DoInsertAppend(False);
|
|
end;
|
|
|
|
procedure TDataSet.InsertRecord(const Values: array of JSValue);
|
|
|
|
begin
|
|
DoInsertAppendRecord(Values,False);
|
|
end;
|
|
|
|
function TDataSet.IsEmpty: Boolean;
|
|
|
|
begin
|
|
Result:=(fBof and fEof) and
|
|
(not (State = dsInsert)); // After an insert on an empty dataset, both fBof and fEof are true
|
|
end;
|
|
|
|
function TDataSet.IsLinkedTo(ADataSource: TDataSource): Boolean;
|
|
|
|
begin
|
|
//!! Not tested, I never used nested DS
|
|
if (ADataSource = nil) or (ADataSource.Dataset = nil) then begin
|
|
Result := False
|
|
end else if ADataSource.Dataset = Self then begin
|
|
Result := True;
|
|
end else begin
|
|
Result := ADataSource.Dataset.IsLinkedTo(ADataSource.Dataset.DataSource);
|
|
end;
|
|
//!! DataSetField not implemented
|
|
end;
|
|
|
|
function TDataSet.IsSequenced: Boolean;
|
|
|
|
begin
|
|
Result := True;
|
|
end;
|
|
|
|
procedure TDataSet.Last;
|
|
|
|
begin
|
|
CheckBiDirectional;
|
|
CheckBrowseMode;
|
|
DoBeforeScroll;
|
|
ClearBuffers;
|
|
try
|
|
// Writeln('FActiveRecord before last',FActiveRecord);
|
|
InternalLast;
|
|
// Writeln('FActiveRecord after last',FActiveRecord);
|
|
GetPriorRecords;
|
|
// Writeln('FRecordCount: ',FRecordCount);
|
|
if FRecordCount>0 then
|
|
FActiveRecord:=FRecordCount-1;
|
|
// Writeln('FActiveRecord ',FActiveRecord);
|
|
finally
|
|
FEOF:=true;
|
|
DataEvent(deDataSetChange, 0);
|
|
DoAfterScroll;
|
|
end;
|
|
end;
|
|
|
|
function TDataSet.DoLoad(aOptions: TLoadOptions; aAfterLoad: TDatasetLoadEvent): Boolean;
|
|
|
|
Var
|
|
Request : TDataRequest;
|
|
|
|
begin
|
|
// Writeln(Name,' Load called. LoadCount ',LoadCount);
|
|
if not (loNoEvents in aOptions) then
|
|
DoBeforeLoad;
|
|
Result:=DataProxy<>Nil;
|
|
if Not Result then
|
|
Exit;
|
|
Request:=DataProxy.GetDataRequest(aOptions,@HandleRequestResponse,aAfterLoad);
|
|
Request.FDataset:=Self;
|
|
If Active then
|
|
Request.FBookmark:=GetBookmark;
|
|
Inc(FDataRequestID);
|
|
Request.FRequestID:=FDataRequestID;
|
|
if DataProxy.DoGetData(Request) then
|
|
Inc(FLoadCount)
|
|
else
|
|
Request.Free;
|
|
// Writeln(Name,' End of Load call. Count: ',LoadCount);
|
|
end;
|
|
|
|
|
|
function TDataSet.Load(aOptions: TLoadOptions; aAfterLoad: TDatasetLoadEvent): Boolean;
|
|
|
|
begin
|
|
if loAtEOF in aOptions then
|
|
DatabaseError(SatEOFInternalOnly,Self);
|
|
if loCancelPending in aOptions then
|
|
CancelLoading;
|
|
Result:=DoLoad(aOptions,aAfterLoad);
|
|
end;
|
|
|
|
function TDataSet.MoveBy(Distance: Longint): Longint;
|
|
Var
|
|
TheResult: Integer;
|
|
|
|
Function ScrollForward : Integer;
|
|
begin
|
|
Result:=0;
|
|
{$ifdef dsdebug}
|
|
Writeln('Scrolling forward : ',Distance);
|
|
Writeln('Active buffer : ',FActiveRecord);
|
|
Writeln('RecordCount : ',FRecordCount);
|
|
WriteLn('BufferCount : ',FBufferCount);
|
|
{$endif}
|
|
FBOF:=False;
|
|
While (Distance>0) and not FEOF do
|
|
begin
|
|
If FActiveRecord<FRecordCount-1 then
|
|
begin
|
|
Inc(FActiveRecord);
|
|
Dec(Distance);
|
|
Inc(TheResult); //Inc(Result);
|
|
end
|
|
else
|
|
begin
|
|
{$ifdef dsdebug}
|
|
Writeln('Moveby : need next record');
|
|
{$endif}
|
|
If GetNextRecord then
|
|
begin
|
|
Dec(Distance);
|
|
Dec(Result);
|
|
Inc(TheResult); //Inc(Result);
|
|
end
|
|
else
|
|
begin
|
|
FEOF:=true;
|
|
// Allow to load more records.
|
|
DoLoad([loNoOpen,loAtEOF],Nil);
|
|
end;
|
|
end;
|
|
end
|
|
end;
|
|
|
|
Function ScrollBackward : Integer;
|
|
begin
|
|
CheckBiDirectional;
|
|
Result:=0;
|
|
{$ifdef dsdebug}
|
|
Writeln('Scrolling backward : ',Abs(Distance));
|
|
Writeln('Active buffer : ',FActiveRecord);
|
|
Writeln('RecordCunt : ',FRecordCount);
|
|
WriteLn('BufferCount : ',FBufferCount);
|
|
{$endif}
|
|
FEOF:=False;
|
|
While (Distance<0) and not FBOF do
|
|
begin
|
|
If FActiveRecord>0 then
|
|
begin
|
|
Dec(FActiveRecord);
|
|
Inc(Distance);
|
|
Dec(TheResult); //Dec(Result);
|
|
end
|
|
else
|
|
begin
|
|
{$ifdef dsdebug}
|
|
Writeln('Moveby : need next record');
|
|
{$endif}
|
|
If GetPriorRecord then
|
|
begin
|
|
Inc(Distance);
|
|
Inc(Result);
|
|
Dec(TheResult); //Dec(Result);
|
|
end
|
|
else
|
|
FBOF:=true;
|
|
end;
|
|
end
|
|
end;
|
|
|
|
Var
|
|
Scrolled : Integer;
|
|
|
|
begin
|
|
CheckBrowseMode;
|
|
Result:=0; TheResult:=0;
|
|
DoBeforeScroll;
|
|
If (Distance = 0) or
|
|
((Distance>0) and FEOF) or
|
|
((Distance<0) and FBOF) then
|
|
exit;
|
|
Try
|
|
Scrolled := 0;
|
|
If Distance>0 then
|
|
Scrolled:=ScrollForward
|
|
else
|
|
Scrolled:=ScrollBackward;
|
|
finally
|
|
{$ifdef dsdebug}
|
|
WriteLn('ActiveRecord=', FActiveRecord,' FEOF=',FEOF,' FBOF=',FBOF);
|
|
{$Endif}
|
|
DataEvent(deDatasetScroll,Scrolled);
|
|
DoAfterScroll;
|
|
Result:=TheResult;
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.Next;
|
|
|
|
begin
|
|
if BlockReadSize>0 then
|
|
BlockReadNext
|
|
else
|
|
MoveBy(1);
|
|
end;
|
|
|
|
procedure TDataSet.BlockReadNext;
|
|
begin
|
|
MoveBy(1);
|
|
end;
|
|
|
|
procedure TDataSet.Open;
|
|
|
|
begin
|
|
Active:=True;
|
|
end;
|
|
|
|
procedure TDataSet.Post;
|
|
|
|
Const
|
|
UpdateStates : Array[Boolean] of TUpdateStatus = (usModified,usInserted);
|
|
|
|
Var
|
|
R : TRecordUpdateDescriptor;
|
|
WasInsert : Boolean;
|
|
|
|
begin
|
|
UpdateRecord;
|
|
if State in [dsEdit,dsInsert] then
|
|
begin
|
|
DataEvent(deCheckBrowseMode,0);
|
|
{$ifdef dsdebug}
|
|
writeln ('Post: checking required fields');
|
|
{$endif}
|
|
DoBeforePost;
|
|
WasInsert:=State=dsInsert;
|
|
If Not TryDoing(@InternalPost,OnPostError) then exit;
|
|
CursorPosChanged;
|
|
{$ifdef dsdebug}
|
|
writeln ('Post: Internalpost succeeded');
|
|
{$endif}
|
|
// First set the state to dsBrowse, then the Resync, to prevent the calling of
|
|
// the deDatasetChange event, while the state is still 'editable', while the db isn't
|
|
SetState(dsBrowse);
|
|
Resync([]);
|
|
// We get the new values here, since the bookmark should now be correct to find the record later on when doing applyupdates.
|
|
R:=AddToChangeList(UpdateStates[wasInsert]);
|
|
if Assigned(R) then
|
|
R.FBookmark:=BookMark;
|
|
{$ifdef dsdebug}
|
|
writeln ('Post: Browse mode set');
|
|
{$endif}
|
|
DoAfterPost;
|
|
end
|
|
else if State<>dsSetKey then
|
|
DatabaseErrorFmt(SNotEditing, [Name], Self);
|
|
end;
|
|
|
|
procedure TDataSet.Prior;
|
|
|
|
begin
|
|
MoveBy(-1);
|
|
end;
|
|
|
|
procedure TDataSet.Refresh;
|
|
|
|
begin
|
|
CheckbrowseMode;
|
|
DoBeforeRefresh;
|
|
UpdateCursorPos;
|
|
InternalRefresh;
|
|
{ SetCurrentRecord is called by UpdateCursorPos already, so as long as
|
|
InternalRefresh doesn't do strange things this should be ok. }
|
|
// SetCurrentRecord(FActiveRecord);
|
|
Resync([]);
|
|
DoAfterRefresh;
|
|
end;
|
|
|
|
procedure TDataSet.RegisterDataSource(ADataSource: TDataSource);
|
|
|
|
begin
|
|
FDataSources.Add(ADataSource);
|
|
RecalcBufListSize;
|
|
end;
|
|
|
|
|
|
procedure TDataSet.Resync(Mode: TResyncMode);
|
|
|
|
var i,count : integer;
|
|
|
|
begin
|
|
// See if we can find the requested record.
|
|
{$ifdef dsdebug}
|
|
Writeln ('Resync called');
|
|
{$endif}
|
|
if FIsUnidirectional then Exit;
|
|
// place the cursor of the underlying dataset to the active record
|
|
// SetCurrentRecord(FActiveRecord);
|
|
|
|
// Now look if the data on the current cursor of the underlying dataset is still available
|
|
If GetRecord(FBuffers[0],gmCurrent,False)<>grOk Then
|
|
// If that fails and rmExact is set, then raise an exception
|
|
If rmExact in Mode then
|
|
DatabaseError(SNoSuchRecord,Self)
|
|
// else, if rmexact is not set, try to fetch the next or prior record in the underlying dataset
|
|
else if (GetRecord(FBuffers[0],gmNext,True)<>grOk) and
|
|
(GetRecord(FBuffers[0],gmPrior,True)<>grOk) then
|
|
begin
|
|
{$ifdef dsdebug}
|
|
Writeln ('Resync: fuzzy resync');
|
|
{$endif}
|
|
// nothing found, invalidate buffer and bail out.
|
|
ClearBuffers;
|
|
// Make sure that the active record is 'empty', ie: that all fields are null
|
|
InternalInitRecord(FBuffers[FActiveRecord]);
|
|
DataEvent(deDatasetChange,0);
|
|
exit;
|
|
end;
|
|
FCurrentRecord := 0;
|
|
FEOF := false;
|
|
FBOF := false;
|
|
|
|
// If we've arrived here, FBuffer[0] is the current record
|
|
If (rmCenter in Mode) then
|
|
count := (FRecordCount div 2)
|
|
else
|
|
count := FActiveRecord;
|
|
i := 0;
|
|
FRecordCount := 1;
|
|
FActiveRecord := 0;
|
|
|
|
// Fill the buffers before the active record
|
|
while (i < count) and GetPriorRecord do
|
|
inc(i);
|
|
FActiveRecord := i;
|
|
// Fill the rest of the buffer
|
|
GetNextRecords;
|
|
// If the buffer is not full yet, try to fetch some more prior records
|
|
if FRecordCount < FBufferCount then FActiveRecord:=FActiveRecord+getpriorrecords;
|
|
// That's all folks!
|
|
DataEvent(deDatasetChange,0);
|
|
end;
|
|
|
|
procedure TDataSet.CancelLoading;
|
|
begin
|
|
FMinLoadID:=FDataRequestID;
|
|
FloadCount:=0;
|
|
end;
|
|
|
|
procedure TDataSet.SetFields(const Values: array of JSValue);
|
|
|
|
Var I : longint;
|
|
begin
|
|
For I:=0 to high(Values) do
|
|
Fields[I].AssignValue(Values[I]);
|
|
end;
|
|
|
|
function TDataSet.TryDoing(P: TDataOperation; Ev: TDatasetErrorEvent): Boolean;
|
|
|
|
Var Retry : TDataAction;
|
|
|
|
begin
|
|
{$ifdef dsdebug}
|
|
Writeln ('Trying to do');
|
|
If P=Nil then writeln ('Procedure to call is nil !!!');
|
|
{$endif dsdebug}
|
|
Result:=True;
|
|
Retry:=daRetry;
|
|
while Retry=daRetry do
|
|
Try
|
|
{$ifdef dsdebug}
|
|
Writeln ('Trying : updatecursorpos');
|
|
{$endif dsdebug}
|
|
UpdateCursorPos;
|
|
{$ifdef dsdebug}
|
|
Writeln ('Trying to do it');
|
|
{$endif dsdebug}
|
|
P();
|
|
exit;
|
|
except
|
|
On E : EDatabaseError do
|
|
begin
|
|
retry:=daFail;
|
|
If Assigned(Ev) then
|
|
Ev(Self,E,Retry);
|
|
Case Retry of
|
|
daFail : Raise;
|
|
daAbort : Abort;
|
|
end;
|
|
end;
|
|
else
|
|
Raise;
|
|
end;
|
|
{$ifdef dsdebug}
|
|
Writeln ('Exit Trying to do');
|
|
{$endif dsdebug}
|
|
end;
|
|
|
|
procedure TDataSet.UpdateCursorPos;
|
|
|
|
begin
|
|
If FRecordCount>0 then
|
|
SetCurrentRecord(FActiveRecord);
|
|
end;
|
|
|
|
procedure TDataSet.UpdateRecord;
|
|
|
|
begin
|
|
if not (State in dsEditModes) then
|
|
DatabaseErrorFmt(SNotEditing, [Name], Self);
|
|
DataEvent(deUpdateRecord, 0);
|
|
end;
|
|
|
|
function TDataSet.GetPendingUpdates: TResolveInfoArray;
|
|
|
|
Var
|
|
L : TRecordUpdateDescriptorList;
|
|
I : integer;
|
|
|
|
begin
|
|
L:=TRecordUpdateDescriptorList.Create;
|
|
try
|
|
SetLength(Result,GetRecordUpdates(L));
|
|
For I:=0 to L.Count-1 do
|
|
Result[i]:=RecordUpdateDescriptorToResolveInfo(L[i]);
|
|
finally
|
|
L.Free;
|
|
end;
|
|
end;
|
|
|
|
(*
|
|
function TDataSet.UpdateStatus: TUpdateStatus;
|
|
|
|
begin
|
|
Result:=;
|
|
end;
|
|
*)
|
|
|
|
procedure TDataSet.SetConstraints(Value: TCheckConstraints);
|
|
begin
|
|
FConstraints.Assign(Value);
|
|
end;
|
|
|
|
procedure TDataSet.SetDataProxy(AValue: TDataProxy);
|
|
begin
|
|
If AValue=FDataProxy then
|
|
exit;
|
|
if Assigned(FDataProxy) then
|
|
FDataProxy.RemoveFreeNotification(Self);
|
|
FDataProxy:=AValue;
|
|
if Assigned(FDataProxy) then
|
|
FDataProxy.FreeNotification(Self)
|
|
end;
|
|
|
|
function TDataSet.GetfieldCount: Integer;
|
|
|
|
begin
|
|
Result:=FFieldList.Count;
|
|
end;
|
|
|
|
procedure TDataSet.ShiftBuffersBackward;
|
|
|
|
var
|
|
TempBuf : TDataRecord;
|
|
I : Integer;
|
|
|
|
begin
|
|
TempBuf := FBuffers[0];
|
|
For I:=1 to FBufferCount do
|
|
FBuffers[I-1]:=FBuffers[i];
|
|
FBuffers[FBufferCount]:=TempBuf;
|
|
end;
|
|
|
|
procedure TDataSet.ShiftBuffersForward;
|
|
|
|
var
|
|
TempBuf : TDataRecord;
|
|
I : Integer;
|
|
|
|
begin
|
|
TempBuf := FBuffers[FBufferCount];
|
|
For I:=FBufferCount downto 1 do
|
|
FBuffers[I]:=FBuffers[i-1];
|
|
FBuffers[0]:=TempBuf;
|
|
end;
|
|
|
|
function TDataSet.GetFieldValues(const FieldName: string): JSValue;
|
|
|
|
var
|
|
i: Integer;
|
|
FieldList: TList;
|
|
A : TJSValueDynArray;
|
|
|
|
begin
|
|
FieldList := TList.Create;
|
|
try
|
|
GetFieldList(FieldList, FieldName);
|
|
if FieldList.Count>1 then
|
|
begin
|
|
SetLength(A,FieldList.Count);
|
|
for i := 0 to FieldList.Count - 1 do
|
|
A[i] := TField(FieldList[i]).Value;
|
|
Result:=A;
|
|
end
|
|
else
|
|
Result := FieldByName(FieldName).Value;
|
|
finally
|
|
FieldList.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TDataSet.SetFieldValues(const FieldName: string; Value: JSValue);
|
|
|
|
var
|
|
i : Integer;
|
|
FieldList: TList;
|
|
A : TJSValueDynArray;
|
|
|
|
begin
|
|
if IsArray(Value) then
|
|
begin
|
|
FieldList := TList.Create;
|
|
try
|
|
GetFieldList(FieldList, FieldName);
|
|
A:=TJSValueDynArray(Value);
|
|
if (FieldList.Count = 1) and (Length(A)>0) then
|
|
// Allow for a field type that can deal with an array
|
|
FieldByName(FieldName).Value := Value
|
|
else
|
|
for i := 0 to FieldList.Count - 1 do
|
|
TField(FieldList[i]).Value := A[i];
|
|
finally
|
|
FieldList.Free;
|
|
end;
|
|
end
|
|
else
|
|
FieldByName(FieldName).Value := Value;
|
|
end;
|
|
|
|
function TDataSet.Locate(const KeyFields: string; const KeyValues: JSValue;
|
|
Options: TLocateOptions): boolean;
|
|
|
|
begin
|
|
CheckBiDirectional;
|
|
Result := False;
|
|
end;
|
|
|
|
function TDataSet.Lookup(const KeyFields: string; const KeyValues: JSValue;
|
|
const ResultFields: string): JSValue;
|
|
|
|
begin
|
|
CheckBiDirectional;
|
|
Result := Null;
|
|
end;
|
|
|
|
|
|
procedure TDataSet.UnRegisterDataSource(ADataSource: TDataSource);
|
|
|
|
begin
|
|
FDataSources.Remove(ADataSource);
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------
|
|
TFieldDef
|
|
---------------------------------------------------------------------}
|
|
|
|
constructor TFieldDef.Create(ACollection: TCollection);
|
|
|
|
begin
|
|
Inherited Create(ACollection);
|
|
FFieldNo:=Index+1;
|
|
end;
|
|
|
|
constructor TFieldDef.Create(AOwner: TFieldDefs; const AName: string; ADataType: TFieldType; ASize: Integer; ARequired: Boolean;
|
|
AFieldNo: Longint);
|
|
begin
|
|
{$ifdef dsdebug }
|
|
Writeln('TFieldDef.Create : ',Aname,'(',AFieldNo,')');
|
|
{$endif}
|
|
Inherited Create(AOwner);
|
|
Name:=Aname;
|
|
FDatatype:=ADatatype;
|
|
FSize:=ASize;
|
|
FRequired:=ARequired;
|
|
FPrecision:=-1;
|
|
FFieldNo:=AFieldNo;
|
|
end;
|
|
|
|
destructor TFieldDef.Destroy;
|
|
|
|
begin
|
|
Inherited destroy;
|
|
end;
|
|
|
|
procedure TFieldDef.Assign(Source: TPersistent);
|
|
var fd: TFieldDef;
|
|
begin
|
|
fd := nil;
|
|
if Source is TFieldDef then
|
|
fd := Source as TFieldDef;
|
|
if Assigned(fd) then begin
|
|
Collection.BeginUpdate;
|
|
try
|
|
Name := fd.Name;
|
|
DataType := fd.DataType;
|
|
Size := fd.Size;
|
|
Precision := fd.Precision;
|
|
FRequired := fd.Required;
|
|
finally
|
|
Collection.EndUpdate;
|
|
end;
|
|
end
|
|
else
|
|
inherited Assign(Source);
|
|
end;
|
|
|
|
function TFieldDef.CreateField(AOwner: TComponent): TField;
|
|
|
|
var TheField : TFieldClass;
|
|
|
|
begin
|
|
{$ifdef dsdebug}
|
|
Writeln ('Creating field '+FNAME);
|
|
{$endif dsdebug}
|
|
TheField:=GetFieldClass;
|
|
if TheField=Nil then
|
|
DatabaseErrorFmt(SUnknownFieldType,[FName]);
|
|
Result:=TheField.Create(AOwner);
|
|
Try
|
|
Result.FFieldDef:=Self;
|
|
Result.Size:=FSize;
|
|
Result.Required:=FRequired;
|
|
Result.FFieldName:=FName;
|
|
Result.FDisplayLabel:=DisplayName;
|
|
Result.FFieldNo:=Self.FieldNo;
|
|
Result.SetFieldType(DataType);
|
|
Result.FReadOnly:=(faReadOnly in Attributes);
|
|
{$ifdef dsdebug}
|
|
Writeln ('TFieldDef.CreateField : Result Fieldno : ',Result.FieldNo,'; Self : ',FieldNo);
|
|
Writeln ('TFieldDef.CreateField : Trying to set dataset');
|
|
{$endif dsdebug}
|
|
Result.Dataset:=TFieldDefs(Collection).Dataset;
|
|
if (Result is TFloatField) then
|
|
TFloatField(Result).Precision := FPrecision;
|
|
except
|
|
Result.Free;
|
|
Raise;
|
|
end;
|
|
end;
|
|
|
|
procedure TFieldDef.SetAttributes(AValue: TFieldAttributes);
|
|
begin
|
|
FAttributes := AValue;
|
|
Changed(False);
|
|
end;
|
|
|
|
procedure TFieldDef.SetDataType(AValue: TFieldType);
|
|
begin
|
|
FDataType := AValue;
|
|
Changed(False);
|
|
end;
|
|
|
|
procedure TFieldDef.SetPrecision(const AValue: Longint);
|
|
begin
|
|
FPrecision := AValue;
|
|
Changed(False);
|
|
end;
|
|
|
|
procedure TFieldDef.SetSize(const AValue: Integer);
|
|
begin
|
|
FSize := AValue;
|
|
Changed(False);
|
|
end;
|
|
|
|
procedure TFieldDef.SetRequired(const AValue: Boolean);
|
|
begin
|
|
FRequired := AValue;
|
|
Changed(False);
|
|
end;
|
|
|
|
function TFieldDef.GetFieldClass: TFieldClass;
|
|
|
|
begin
|
|
//!! Should be owner as tdataset but that doesn't work ??
|
|
|
|
If Assigned(Collection) And
|
|
(Collection is TFieldDefs) And
|
|
Assigned(TFieldDefs(Collection).Dataset) then
|
|
Result:=TFieldDefs(Collection).Dataset.GetFieldClass(FDataType)
|
|
else
|
|
Result:=Nil;
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------
|
|
TFieldDefs
|
|
---------------------------------------------------------------------}
|
|
|
|
{
|
|
destructor TFieldDefs.Destroy;
|
|
|
|
begin
|
|
FItems.Free;
|
|
// This will destroy all fielddefs since we own them...
|
|
Inherited Destroy;
|
|
end;
|
|
}
|
|
|
|
procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType);
|
|
|
|
begin
|
|
Add(AName,ADatatype,0,False);
|
|
end;
|
|
|
|
procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize : Word);
|
|
|
|
begin
|
|
Add(AName,ADatatype,ASize,False);
|
|
end;
|
|
|
|
procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize: Word;
|
|
ARequired: Boolean);
|
|
|
|
begin
|
|
If Length(AName)=0 Then
|
|
DatabaseError(SNeedFieldName,Dataset);
|
|
// the fielddef will register itself here as an owned component.
|
|
// fieldno is 1 based !
|
|
BeginUpdate;
|
|
try
|
|
Add(AName,ADataType,ASize,ARequired,Count+1);
|
|
finally
|
|
EndUpdate;
|
|
end;
|
|
end;
|
|
|
|
function TFieldDefs.GetItem(Index: Longint): TFieldDef;
|
|
|
|
begin
|
|
Result := TFieldDef(inherited Items[Index]);
|
|
end;
|
|
|
|
procedure TFieldDefs.SetItem(Index: Longint; const AValue: TFieldDef);
|
|
begin
|
|
inherited Items[Index] := AValue;
|
|
end;
|
|
|
|
class function TFieldDefs.FieldDefClass: TFieldDefClass;
|
|
begin
|
|
Result:=TFieldDef;
|
|
end;
|
|
|
|
constructor TFieldDefs.Create(ADataSet: TDataSet);
|
|
begin
|
|
Inherited Create(ADataset, Owner, FieldDefClass);
|
|
end;
|
|
|
|
function TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize, APrecision: Integer;
|
|
ARequired, AReadOnly: Boolean; AFieldNo: Integer): TFieldDef;
|
|
begin
|
|
Result:=FieldDefClass.Create(Self, MakeNameUnique(AName), ADataType, ASize, ARequired, AFieldNo);
|
|
if AReadOnly then
|
|
Result.Attributes := Result.Attributes + [faReadOnly];
|
|
end;
|
|
|
|
function TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize: Word; ARequired: Boolean; AFieldNo: Integer): TFieldDef;
|
|
begin
|
|
Result:=FieldDefClass.Create(Self,AName,ADataType,ASize,ARequired,AFieldNo);
|
|
end;
|
|
|
|
procedure TFieldDefs.Assign(FieldDefs: TFieldDefs);
|
|
|
|
var I : longint;
|
|
|
|
begin
|
|
Clear;
|
|
For i:=0 to FieldDefs.Count-1 do
|
|
With FieldDefs[i] do
|
|
Add(Name,DataType,Size,Required);
|
|
end;
|
|
|
|
function TFieldDefs.Find(const AName: string): TFieldDef;
|
|
begin
|
|
Result := (Inherited Find(AName)) as TFieldDef;
|
|
if Result=nil then DatabaseErrorFmt(SFieldNotFound,[AName],FDataset);
|
|
end;
|
|
|
|
{
|
|
procedure TFieldDefs.Clear;
|
|
|
|
var I : longint;
|
|
|
|
begin
|
|
For I:=FItems.Count-1 downto 0 do
|
|
TFieldDef(Fitems[i]).Free;
|
|
FItems.Clear;
|
|
end;
|
|
}
|
|
|
|
procedure TFieldDefs.Update;
|
|
|
|
begin
|
|
if not Updated then
|
|
begin
|
|
If Assigned(Dataset) then
|
|
DataSet.InitFieldDefs;
|
|
Updated := True;
|
|
end;
|
|
end;
|
|
|
|
function TFieldDefs.MakeNameUnique(const AName: String): string;
|
|
var DblFieldCount : integer;
|
|
begin
|
|
DblFieldCount := 0;
|
|
Result := AName;
|
|
while assigned(inherited Find(Result)) do
|
|
begin
|
|
inc(DblFieldCount);
|
|
Result := AName + '_' + IntToStr(DblFieldCount);
|
|
end;
|
|
end;
|
|
|
|
function TFieldDefs.AddFieldDef: TFieldDef;
|
|
|
|
begin
|
|
Result:=FieldDefClass.Create(Self,'',ftUnknown,0,False,Count+1);
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------
|
|
TField
|
|
---------------------------------------------------------------------}
|
|
|
|
Const
|
|
// SBCD = 'BCD';
|
|
SBoolean = 'Boolean';
|
|
SDateTime = 'TDateTime';
|
|
SFloat = 'Float';
|
|
SInteger = 'Integer';
|
|
SLargeInt = 'NativeInt';
|
|
SJSValue = 'JSValue';
|
|
SString = 'String';
|
|
SBytes = 'Bytes';
|
|
|
|
constructor TField.Create(AOwner: TComponent);
|
|
|
|
//Var
|
|
// I : Integer;
|
|
|
|
begin
|
|
Inherited Create(AOwner);
|
|
FVisible:=True;
|
|
SetLength(FValidChars,255);
|
|
// For I:=0 to 255 do
|
|
// FValidChars[i]:=Char(i);
|
|
|
|
FProviderFlags := [pfInUpdate,pfInWhere];
|
|
end;
|
|
|
|
destructor TField.Destroy;
|
|
|
|
begin
|
|
IF Assigned(FDataSet) then
|
|
begin
|
|
FDataSet.Active:=False;
|
|
if Assigned(FFields) then
|
|
FFields.Remove(Self);
|
|
end;
|
|
FLookupList.Free;
|
|
Inherited Destroy;
|
|
end;
|
|
|
|
Procedure TField.RaiseAccessError(const TypeName: string);
|
|
|
|
Var
|
|
E : EDatabaseError;
|
|
|
|
begin
|
|
E:=AccessError(TypeName);
|
|
Raise E;
|
|
end;
|
|
|
|
function TField.AccessError(const TypeName: string): EDatabaseError;
|
|
|
|
begin
|
|
Result:=EDatabaseError.CreateFmt(SinvalidTypeConversion,[TypeName,FFieldName]);
|
|
end;
|
|
|
|
procedure TField.DefineProperties(Filer: TFiler);
|
|
procedure IgnoreReadString(Reader: TReader);
|
|
begin
|
|
Reader.ReadString;
|
|
end;
|
|
|
|
procedure IgnoreReadBoolean(Reader: TReader);
|
|
begin
|
|
Reader.ReadBoolean;
|
|
end;
|
|
|
|
procedure IgnoreWrite(Writer: TWriter);
|
|
begin
|
|
end;
|
|
|
|
begin
|
|
Filer.DefineProperty('AttributeSet', @IgnoreReadString, @IgnoreWrite, False);
|
|
Filer.DefineProperty('Calculated', @IgnoreReadBoolean, @IgnoreWrite, False);
|
|
Filer.DefineProperty('Lookup', @IgnoreReadBoolean, @IgnoreWrite, False);
|
|
end;
|
|
|
|
procedure TField.Assign(Source: TPersistent);
|
|
|
|
begin
|
|
if Source = nil then Clear
|
|
else if Source is TField then begin
|
|
Value := TField(Source).Value;
|
|
end else
|
|
inherited Assign(Source);
|
|
end;
|
|
|
|
procedure TField.AssignValue(const AValue: JSValue);
|
|
|
|
procedure Error;
|
|
begin
|
|
DatabaseErrorFmt(SFieldValueError, [DisplayName]);
|
|
end;
|
|
|
|
begin
|
|
Case GetValueType(AValue) of
|
|
jvtNull : Clear;
|
|
jvtBoolean : AsBoolean:=Boolean(AValue);
|
|
jvtInteger : AsLargeInt:=NativeInt(AValue);
|
|
jvtFloat : AsFloat:=Double(AValue);
|
|
jvtString : AsString:=String(AValue);
|
|
jvtArray : SetAsBytes(TBytes(AValue));
|
|
else
|
|
Error;
|
|
end;
|
|
end;
|
|
|
|
procedure TField.Bind(Binding: Boolean);
|
|
|
|
begin
|
|
if Binding and (FieldKind=fkLookup) then
|
|
begin
|
|
if ((FLookupDataSet = nil) or (FLookupKeyFields = '') or
|
|
(FLookupResultField = '') or (FKeyFields = '')) then
|
|
DatabaseErrorFmt(SLookupInfoError, [DisplayName]);
|
|
FFields.CheckFieldNames(FKeyFields);
|
|
FLookupDataSet.Open;
|
|
FLookupDataSet.Fields.CheckFieldNames(FLookupKeyFields);
|
|
FLookupDataSet.FieldByName(FLookupResultField);
|
|
if FLookupCache then
|
|
RefreshLookupList;
|
|
end;
|
|
end;
|
|
|
|
procedure TField.Change;
|
|
|
|
begin
|
|
If Assigned(FOnChange) Then
|
|
FOnChange(Self);
|
|
end;
|
|
|
|
procedure TField.CheckInactive;
|
|
|
|
begin
|
|
If Assigned(FDataSet) then
|
|
FDataset.CheckInactive;
|
|
end;
|
|
|
|
procedure TField.Clear;
|
|
|
|
begin
|
|
SetData(Nil);
|
|
end;
|
|
|
|
procedure TField.DataChanged;
|
|
|
|
begin
|
|
FDataset.DataEvent(deFieldChange,self);
|
|
end;
|
|
|
|
procedure TField.FocusControl;
|
|
var
|
|
Field1: TField;
|
|
begin
|
|
Field1 := Self;
|
|
FDataSet.DataEvent(deFocusControl,Field1);
|
|
end;
|
|
|
|
function TField.GetAsBoolean: Boolean;
|
|
begin
|
|
raiseAccessError(SBoolean);
|
|
Result:=false;
|
|
end;
|
|
|
|
function TField.GetAsBytes: TBytes;
|
|
|
|
begin
|
|
raiseAccessError(SBytes);
|
|
Result:=nil;
|
|
end;
|
|
|
|
|
|
function TField.GetAsDateTime: TDateTime;
|
|
|
|
begin
|
|
raiseAccessError(SdateTime);
|
|
Result:=0.0;
|
|
end;
|
|
|
|
function TField.GetAsFloat: Double;
|
|
|
|
begin
|
|
raiseAccessError(SDateTime);
|
|
Result:=0.0;
|
|
end;
|
|
|
|
function TField.GetAsLargeInt: NativeInt;
|
|
begin
|
|
RaiseAccessError(SLargeInt);
|
|
Result:=0;
|
|
end;
|
|
|
|
function TField.GetAsLongint: Longint;
|
|
|
|
begin
|
|
Result:=GetAsInteger;
|
|
end;
|
|
|
|
function TField.GetAsInteger: Longint;
|
|
|
|
begin
|
|
RaiseAccessError(SInteger);
|
|
Result:=0;
|
|
end;
|
|
|
|
function TField.GetAsJSValue: JSValue;
|
|
|
|
begin
|
|
Result:=GetData
|
|
end;
|
|
|
|
|
|
function TField.GetAsString: string;
|
|
begin
|
|
Result := GetClassDesc
|
|
end;
|
|
|
|
function TField.GetOldValue: JSValue;
|
|
|
|
var SaveState : TDatasetState;
|
|
|
|
begin
|
|
SaveState := FDataset.State;
|
|
try
|
|
FDataset.SetTempState(dsOldValue);
|
|
Result := GetAsJSValue;
|
|
finally
|
|
FDataset.RestoreState(SaveState);
|
|
end;
|
|
end;
|
|
|
|
function TField.GetNewValue: JSValue;
|
|
|
|
var SaveState : TDatasetState;
|
|
|
|
begin
|
|
SaveState := FDataset.State;
|
|
try
|
|
FDataset.SetTempState(dsNewValue);
|
|
Result := GetAsJSValue;
|
|
finally
|
|
FDataset.RestoreState(SaveState);
|
|
end;
|
|
end;
|
|
|
|
procedure TField.SetNewValue(const AValue: JSValue);
|
|
|
|
var SaveState : TDatasetState;
|
|
|
|
begin
|
|
SaveState := FDataset.State;
|
|
try
|
|
FDataset.SetTempState(dsNewValue);
|
|
SetAsJSValue(AValue);
|
|
finally
|
|
FDataset.RestoreState(SaveState);
|
|
end;
|
|
end;
|
|
|
|
function TField.GetCurValue: JSValue;
|
|
|
|
var SaveState : TDatasetState;
|
|
|
|
begin
|
|
SaveState := FDataset.State;
|
|
try
|
|
FDataset.SetTempState(dsCurValue);
|
|
Result := GetAsJSValue;
|
|
finally
|
|
FDataset.RestoreState(SaveState);
|
|
end;
|
|
end;
|
|
|
|
function TField.GetCanModify: Boolean;
|
|
|
|
begin
|
|
Result:=Not ReadOnly;
|
|
If Result then
|
|
begin
|
|
Result := FieldKind in [fkData, fkInternalCalc];
|
|
if Result then
|
|
begin
|
|
Result:=Assigned(DataSet) and Dataset.Active;
|
|
If Result then
|
|
Result:= DataSet.CanModify;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TField.GetClassDesc: String;
|
|
var ClassN : string;
|
|
begin
|
|
ClassN := copy(ClassName,2,pos('Field',ClassName)-2);
|
|
if isNull then
|
|
result := '(' + LowerCase(ClassN) + ')'
|
|
else
|
|
result := '(' + UpperCase(ClassN) + ')';
|
|
end;
|
|
|
|
|
|
function TField.GetData : JSValue;
|
|
|
|
begin
|
|
IF FDataset=Nil then
|
|
DatabaseErrorFmt(SNoDataset,[FieldName]);
|
|
If FValidating then
|
|
result:=FValueBuffer
|
|
else
|
|
begin
|
|
Result:=FDataset.GetFieldData(Self);
|
|
If IsUndefined(Result) then
|
|
Result:=Null;
|
|
end;
|
|
end;
|
|
|
|
function TField.GetDataSize: Integer;
|
|
|
|
begin
|
|
Result:=0;
|
|
end;
|
|
|
|
function TField.GetDefaultWidth: Longint;
|
|
|
|
begin
|
|
Result:=10;
|
|
end;
|
|
|
|
function TField.GetDisplayName : String;
|
|
|
|
begin
|
|
If FDisplayLabel<>'' then
|
|
result:=FDisplayLabel
|
|
else
|
|
Result:=FFieldName;
|
|
end;
|
|
|
|
function TField.IsDisplayLabelStored: Boolean;
|
|
|
|
begin
|
|
Result:=(DisplayLabel<>FieldName);
|
|
end;
|
|
|
|
function TField.IsDisplayWidthStored: Boolean;
|
|
|
|
begin
|
|
Result:=(FDisplayWidth<>0);
|
|
end;
|
|
|
|
function TField.GetLookupList: TLookupList;
|
|
begin
|
|
if not Assigned(FLookupList) then
|
|
FLookupList := TLookupList.Create;
|
|
Result := FLookupList;
|
|
end;
|
|
|
|
procedure TField.CalcLookupValue;
|
|
begin
|
|
// MVC: TODO
|
|
// if FLookupCache then
|
|
// Value := LookupList.ValueOfKey(FDataSet.FieldValues[FKeyFields])
|
|
// else if
|
|
if Assigned(FLookupDataSet) and FLookupDataSet.Active then
|
|
Value := FLookupDataSet.Lookup(FLookupKeyfields, FDataSet.FieldValues[FKeyFields], FLookupresultField)
|
|
else
|
|
Value:=Null;
|
|
end;
|
|
|
|
function TField.GetIndex: longint;
|
|
|
|
begin
|
|
If Assigned(FDataset) then
|
|
Result:=FDataset.FFieldList.IndexOf(Self)
|
|
else
|
|
Result:=-1;
|
|
end;
|
|
|
|
function TField.GetLookup: Boolean;
|
|
begin
|
|
Result := FieldKind = fkLookup;
|
|
end;
|
|
|
|
procedure TField.SetAlignment(const AValue: TAlignMent);
|
|
begin
|
|
if FAlignment <> AValue then
|
|
begin
|
|
FAlignment := AValue;
|
|
PropertyChanged(false);
|
|
end;
|
|
end;
|
|
|
|
procedure TField.SetIndex(const AValue: Longint);
|
|
begin
|
|
if FFields <> nil then FFields.SetFieldIndex(Self, AValue)
|
|
end;
|
|
|
|
function TField.GetIsNull: Boolean;
|
|
|
|
begin
|
|
Result:=js.IsNull(GetData);
|
|
end;
|
|
|
|
function TField.GetParentComponent: TComponent;
|
|
|
|
begin
|
|
Result := DataSet;
|
|
end;
|
|
|
|
procedure TField.GetText(var AText: string; ADisplayText: Boolean);
|
|
|
|
begin
|
|
AText:=GetAsString;
|
|
end;
|
|
|
|
function TField.HasParent: Boolean;
|
|
|
|
begin
|
|
HasParent:=True;
|
|
end;
|
|
|
|
function TField.IsValidChar(InputChar: Char): Boolean;
|
|
|
|
begin
|
|
// FValidChars must be set in Create.
|
|
Result:=CharInset(InputChar,FValidChars);
|
|
end;
|
|
|
|
procedure TField.RefreshLookupList;
|
|
var
|
|
tmpActive: Boolean;
|
|
begin
|
|
if not Assigned(FLookupDataSet) or (Length(FLookupKeyfields) = 0)
|
|
or (Length(FLookupresultField) = 0) or (Length(FKeyFields) = 0) then
|
|
Exit;
|
|
|
|
tmpActive := FLookupDataSet.Active;
|
|
try
|
|
FLookupDataSet.Active := True;
|
|
FFields.CheckFieldNames(FKeyFields);
|
|
FLookupDataSet.Fields.CheckFieldNames(FLookupKeyFields);
|
|
FLookupDataset.FieldByName(FLookupResultField); // I presume that if it doesn't exist it throws exception, and that a field with null value is still valid
|
|
LookupList.Clear; // have to be F-less because we might be creating it here with getter!
|
|
|
|
FLookupDataSet.DisableControls;
|
|
try
|
|
FLookupDataSet.First;
|
|
while not FLookupDataSet.Eof do
|
|
begin
|
|
// FLookupList.Add(FLookupDataSet.FieldValues[FLookupKeyfields], FLookupDataSet.FieldValues[FLookupResultField]);
|
|
FLookupDataSet.Next;
|
|
end;
|
|
finally
|
|
FLookupDataSet.EnableControls;
|
|
end;
|
|
finally
|
|
FLookupDataSet.Active := tmpActive;
|
|
end;
|
|
end;
|
|
|
|
procedure TField.Notification(AComponent: TComponent; Operation: TOperation);
|
|
|
|
begin
|
|
Inherited Notification(AComponent,Operation);
|
|
if (Operation = opRemove) and (AComponent = FLookupDataSet) then
|
|
FLookupDataSet := nil;
|
|
end;
|
|
|
|
procedure TField.PropertyChanged(LayoutAffected: Boolean);
|
|
|
|
begin
|
|
If (FDataset<>Nil) and (FDataset.Active) then
|
|
If LayoutAffected then
|
|
FDataset.DataEvent(deLayoutChange,0)
|
|
else
|
|
FDataset.DataEvent(deDatasetchange,0);
|
|
end;
|
|
|
|
|
|
procedure TField.SetAsBytes(const AValue: TBytes);
|
|
begin
|
|
RaiseAccessError(SBytes);
|
|
end;
|
|
|
|
procedure TField.SetAsBoolean(AValue: Boolean);
|
|
|
|
begin
|
|
RaiseAccessError(SBoolean);
|
|
end;
|
|
|
|
procedure TField.SetAsDateTime(AValue: TDateTime);
|
|
|
|
begin
|
|
RaiseAccessError(SDateTime);
|
|
end;
|
|
|
|
procedure TField.SetAsFloat(AValue: Double);
|
|
|
|
begin
|
|
RaiseAccessError(SFloat);
|
|
end;
|
|
|
|
procedure TField.SetAsJSValue(const AValue: JSValue);
|
|
|
|
begin
|
|
if js.IsNull(AValue) then
|
|
Clear
|
|
else
|
|
try
|
|
SetVarValue(AValue);
|
|
except
|
|
on EVariantError do
|
|
DatabaseErrorFmt(SFieldValueError, [DisplayName]);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TField.SetAsLongint(AValue: Longint);
|
|
begin
|
|
SetAsInteger(AValue);
|
|
end;
|
|
|
|
procedure TField.SetAsInteger(AValue: Longint);
|
|
begin
|
|
RaiseAccessError(SInteger);
|
|
end;
|
|
|
|
procedure TField.SetAsLargeInt(AValue: NativeInt);
|
|
begin
|
|
RaiseAccessError(SLargeInt);
|
|
end;
|
|
|
|
procedure TField.SetAsString(const AValue: string);
|
|
begin
|
|
RaiseAccessError(SString);
|
|
end;
|
|
|
|
procedure TField.SetData(Buffer: JSValue);
|
|
|
|
begin
|
|
If Not Assigned(FDataset) then
|
|
DatabaseErrorFmt(SNoDataset,[FieldName]);
|
|
FDataSet.SetFieldData(Self,Buffer);
|
|
end;
|
|
|
|
procedure TField.SetDataset(AValue: TDataset);
|
|
|
|
begin
|
|
{$ifdef dsdebug}
|
|
Writeln ('Setting dataset');
|
|
{$endif}
|
|
If AValue=FDataset then exit;
|
|
If Assigned(FDataset) Then
|
|
begin
|
|
FDataset.CheckInactive;
|
|
FDataset.FFieldList.Remove(Self);
|
|
end;
|
|
If Assigned(AValue) then
|
|
begin
|
|
AValue.CheckInactive;
|
|
AValue.FFieldList.Add(Self);
|
|
end;
|
|
FDataset:=AValue;
|
|
end;
|
|
|
|
procedure TField.SetDataType(AValue: TFieldType);
|
|
|
|
begin
|
|
FDataType := AValue;
|
|
end;
|
|
|
|
procedure TField.SetFieldType(AValue: TFieldType);
|
|
|
|
begin
|
|
{ empty }
|
|
end;
|
|
|
|
procedure TField.SetParentComponent(Value: TComponent);
|
|
|
|
begin
|
|
// if not (csLoading in ComponentState) then
|
|
DataSet := Value as TDataSet;
|
|
end;
|
|
|
|
procedure TField.SetSize(AValue: Integer);
|
|
|
|
begin
|
|
CheckInactive;
|
|
CheckTypeSize(AValue);
|
|
FSize:=AValue;
|
|
end;
|
|
|
|
procedure TField.SetText(const AValue: string);
|
|
|
|
begin
|
|
SetAsString(AValue);
|
|
end;
|
|
|
|
procedure TField.SetVarValue(const AValue: JSValue);
|
|
begin
|
|
RaiseAccessError(SJSValue);
|
|
end;
|
|
|
|
procedure TField.Validate(Buffer: Pointer);
|
|
|
|
begin
|
|
If assigned(OnValidate) Then
|
|
begin
|
|
FValueBuffer:=Buffer;
|
|
FValidating:=True;
|
|
Try
|
|
OnValidate(Self);
|
|
finally
|
|
FValidating:=False;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
class function TField.IsBlob: Boolean;
|
|
|
|
begin
|
|
Result:=False;
|
|
end;
|
|
|
|
class procedure TField.CheckTypeSize(AValue: Longint);
|
|
|
|
begin
|
|
If (AValue<>0) and Not IsBlob Then
|
|
DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
|
|
end;
|
|
|
|
// TField private methods
|
|
|
|
procedure TField.SetEditText(const AValue: string);
|
|
begin
|
|
if Assigned(OnSetText) then
|
|
OnSetText(Self, AValue)
|
|
else
|
|
SetText(AValue);
|
|
end;
|
|
|
|
function TField.GetEditText: String;
|
|
begin
|
|
SetLength(Result, 0);
|
|
if Assigned(OnGetText) then
|
|
OnGetText(Self, Result, False)
|
|
else
|
|
GetText(Result, False);
|
|
end;
|
|
|
|
function TField.GetDisplayText: String;
|
|
begin
|
|
SetLength(Result, 0);
|
|
if Assigned(OnGetText) then
|
|
OnGetText(Self, Result, True)
|
|
else
|
|
GetText(Result, True);
|
|
end;
|
|
|
|
procedure TField.SetDisplayLabel(const AValue: string);
|
|
begin
|
|
if FDisplayLabel<>AValue then
|
|
begin
|
|
FDisplayLabel:=AValue;
|
|
PropertyChanged(true);
|
|
end;
|
|
end;
|
|
|
|
procedure TField.SetDisplayWidth(const AValue: Longint);
|
|
begin
|
|
if FDisplayWidth<>AValue then
|
|
begin
|
|
FDisplayWidth:=AValue;
|
|
PropertyChanged(True);
|
|
end;
|
|
end;
|
|
|
|
function TField.GetDisplayWidth: integer;
|
|
begin
|
|
if FDisplayWidth=0 then
|
|
result:=GetDefaultWidth
|
|
else
|
|
result:=FDisplayWidth;
|
|
end;
|
|
|
|
procedure TField.SetLookup(const AValue: Boolean);
|
|
const
|
|
ValueToLookupMap: array[Boolean] of TFieldKind = (fkData, fkLookup);
|
|
begin
|
|
FieldKind := ValueToLookupMap[AValue];
|
|
end;
|
|
|
|
procedure TField.SetReadOnly(const AValue: Boolean);
|
|
begin
|
|
if (FReadOnly<>AValue) then
|
|
begin
|
|
FReadOnly:=AValue;
|
|
PropertyChanged(True);
|
|
end;
|
|
end;
|
|
|
|
procedure TField.SetVisible(const AValue: Boolean);
|
|
begin
|
|
if FVisible<>AValue then
|
|
begin
|
|
FVisible:=AValue;
|
|
PropertyChanged(True);
|
|
end;
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------
|
|
TStringField
|
|
---------------------------------------------------------------------}
|
|
|
|
|
|
constructor TStringField.Create(AOwner: TComponent);
|
|
|
|
begin
|
|
Inherited Create(AOwner);
|
|
SetDataType(ftString);
|
|
FFixedChar := False;
|
|
FTransliterate := False;
|
|
FSize := 20;
|
|
end;
|
|
|
|
procedure TStringField.SetFieldType(AValue: TFieldType);
|
|
begin
|
|
if AValue in [ftString, ftFixedChar] then
|
|
SetDataType(AValue);
|
|
end;
|
|
|
|
class procedure TStringField.CheckTypeSize(AValue: Longint);
|
|
|
|
begin
|
|
// A size of 0 is allowed, since for example Firebird allows
|
|
// a query like: 'select '' as fieldname from table' which
|
|
// results in a string with size 0.
|
|
If (AValue<0) Then
|
|
DatabaseErrorFmt(SInvalidFieldSize,[AValue])
|
|
end;
|
|
|
|
function TStringField.GetAsBoolean: Boolean;
|
|
|
|
var S : String;
|
|
|
|
begin
|
|
S:=GetAsString;
|
|
result := (Length(S)>0) and (Upcase(S[1]) in ['T',YesNoChars[True]]);
|
|
end;
|
|
|
|
function TStringField.GetAsDateTime: TDateTime;
|
|
|
|
begin
|
|
Result:=StrToDateTime(GetAsString);
|
|
end;
|
|
|
|
function TStringField.GetAsFloat: Double;
|
|
|
|
begin
|
|
Result:=StrToFloat(GetAsString);
|
|
end;
|
|
|
|
function TStringField.GetAsInteger: Longint;
|
|
|
|
begin
|
|
Result:=StrToInt(GetAsString);
|
|
end;
|
|
|
|
function TStringField.GetAsLargeInt: NativeInt;
|
|
|
|
begin
|
|
Result:=StrToInt64(GetAsString);
|
|
end;
|
|
|
|
function TStringField.GetAsString: String;
|
|
|
|
Var
|
|
V : JSValue;
|
|
|
|
begin
|
|
V:=GetData;
|
|
if isString(V) then
|
|
Result := String(V)
|
|
else
|
|
Result:='';
|
|
end;
|
|
|
|
|
|
function TStringField.GetAsJSValue: JSValue;
|
|
|
|
begin
|
|
Result:=GetData
|
|
end;
|
|
|
|
|
|
function TStringField.GetDefaultWidth: Longint;
|
|
|
|
begin
|
|
result:=Size;
|
|
end;
|
|
|
|
procedure TStringField.GetText(var AText: string; ADisplayText: Boolean);
|
|
|
|
begin
|
|
AText:=GetAsString;
|
|
end;
|
|
|
|
|
|
procedure TStringField.SetAsBoolean(AValue: Boolean);
|
|
|
|
begin
|
|
If AValue Then
|
|
SetAsString('T')
|
|
else
|
|
SetAsString('F');
|
|
end;
|
|
|
|
procedure TStringField.SetAsDateTime(AValue: TDateTime);
|
|
|
|
begin
|
|
SetAsString(DateTimeToStr(AValue));
|
|
end;
|
|
|
|
procedure TStringField.SetAsFloat(AValue: Double);
|
|
|
|
begin
|
|
SetAsString(FloatToStr(AValue));
|
|
end;
|
|
|
|
procedure TStringField.SetAsInteger(AValue: Longint);
|
|
|
|
begin
|
|
SetAsString(IntToStr(AValue));
|
|
end;
|
|
|
|
procedure TStringField.SetAsLargeInt(AValue: NativeInt);
|
|
|
|
begin
|
|
SetAsString(IntToStr(AValue));
|
|
end;
|
|
|
|
|
|
procedure TStringField.SetAsString(const AValue: String);
|
|
begin
|
|
SetData(AValue);
|
|
end;
|
|
|
|
|
|
procedure TStringField.SetVarValue(const AValue: JSValue);
|
|
begin
|
|
if isString(AVAlue) then
|
|
SetAsString(String(AValue))
|
|
else
|
|
RaiseAccessError(SFieldValueError);
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------
|
|
TNumericField
|
|
---------------------------------------------------------------------}
|
|
|
|
|
|
constructor TNumericField.Create(AOwner: TComponent);
|
|
|
|
begin
|
|
Inherited Create(AOwner);
|
|
AlignMent:=taRightJustify;
|
|
end;
|
|
|
|
class procedure TNumericField.CheckTypeSize(AValue: Longint);
|
|
begin
|
|
// This procedure is only added because some TDataset descendents have the
|
|
// but that they set the Size property as if it is the DataSize property.
|
|
// To avoid problems with those descendents, allow values <= 16.
|
|
If (AValue>16) Then
|
|
DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
|
|
end;
|
|
|
|
procedure TNumericField.RangeError(AValue, Min, Max: Double);
|
|
|
|
begin
|
|
DatabaseErrorFmt(SRangeError,[AValue,Min,Max,FieldName]);
|
|
end;
|
|
|
|
procedure TNumericField.SetDisplayFormat(const AValue: string);
|
|
|
|
begin
|
|
If FDisplayFormat<>AValue then
|
|
begin
|
|
FDisplayFormat:=AValue;
|
|
PropertyChanged(True);
|
|
end;
|
|
end;
|
|
|
|
procedure TNumericField.SetEditFormat(const AValue: string);
|
|
|
|
begin
|
|
If FEditFormat<>AValue then
|
|
begin
|
|
FEditFormat:=AValue;
|
|
PropertyChanged(True);
|
|
end;
|
|
end;
|
|
|
|
function TNumericField.GetAsBoolean: Boolean;
|
|
begin
|
|
Result:=GetAsInteger<>0;
|
|
end;
|
|
|
|
procedure TNumericField.SetAsBoolean(AValue: Boolean);
|
|
begin
|
|
SetAsInteger(ord(AValue));
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------
|
|
TIntegerField
|
|
---------------------------------------------------------------------}
|
|
|
|
|
|
constructor TIntegerField.Create(AOwner: TComponent);
|
|
|
|
begin
|
|
Inherited Create(AOwner);
|
|
SetDataType(ftInteger);
|
|
FMinRange:=Low(LongInt);
|
|
FMaxRange:=High(LongInt);
|
|
// MVC : Todo
|
|
// FValidchars:=['+','-','0'..'9'];
|
|
end;
|
|
|
|
function TIntegerField.GetAsFloat: Double;
|
|
|
|
begin
|
|
Result:=GetAsInteger;
|
|
end;
|
|
|
|
function TIntegerField.GetAsLargeInt: NativeInt;
|
|
begin
|
|
Result:=GetAsInteger;
|
|
end;
|
|
|
|
function TIntegerField.GetAsInteger: Longint;
|
|
|
|
begin
|
|
If Not GetValue(Result) then
|
|
Result:=0;
|
|
end;
|
|
|
|
function TIntegerField.GetAsJSValue: JSValue;
|
|
|
|
var L : Longint;
|
|
|
|
begin
|
|
If GetValue(L) then
|
|
Result:=L
|
|
else
|
|
Result:=Null;
|
|
end;
|
|
|
|
function TIntegerField.GetAsString: string;
|
|
|
|
var L : Longint;
|
|
|
|
begin
|
|
If GetValue(L) then
|
|
Result:=IntTostr(L)
|
|
else
|
|
Result:='';
|
|
end;
|
|
|
|
|
|
procedure TIntegerField.GetText(var AText: string; ADisplayText: Boolean);
|
|
|
|
var l : longint;
|
|
fmt : string;
|
|
|
|
begin
|
|
Atext:='';
|
|
If Not GetValue(l) then exit;
|
|
If ADisplayText or (FEditFormat='') then
|
|
fmt:=FDisplayFormat
|
|
else
|
|
fmt:=FEditFormat;
|
|
If length(fmt)<>0 then
|
|
AText:=FormatFloat(fmt,L)
|
|
else
|
|
Str(L,AText);
|
|
end;
|
|
|
|
function TIntegerField.GetValue(var AValue: Longint): Boolean;
|
|
|
|
var
|
|
V : JSValue;
|
|
|
|
begin
|
|
V:=GetData;
|
|
Result:=isInteger(V);
|
|
if Result then
|
|
AValue:=Longint(V);
|
|
end;
|
|
|
|
procedure TIntegerField.SetAsLargeInt(AValue: NativeInt);
|
|
begin
|
|
if (AValue>=FMinRange) and (AValue<=FMaxRange) then
|
|
SetAsInteger(AValue)
|
|
else
|
|
RangeError(AValue,FMinRange,FMaxRange);
|
|
end;
|
|
|
|
procedure TIntegerField.SetAsFloat(AValue: Double);
|
|
|
|
begin
|
|
SetAsInteger(Round(AValue));
|
|
end;
|
|
|
|
procedure TIntegerField.SetAsInteger(AValue: Longint);
|
|
begin
|
|
If CheckRange(AValue) then
|
|
SetData(AValue)
|
|
else
|
|
if (FMinValue<>0) or (FMaxValue<>0) then
|
|
RangeError(AValue,FMinValue,FMaxValue)
|
|
else
|
|
RangeError(AValue,FMinRange,FMaxRange);
|
|
end;
|
|
|
|
procedure TIntegerField.SetVarValue(const AValue: JSValue);
|
|
begin
|
|
if IsInteger(aValue) then
|
|
SetAsInteger(Integer(AValue))
|
|
else
|
|
RaiseAccessError(SInteger);
|
|
end;
|
|
|
|
procedure TIntegerField.SetAsString(const AValue: string);
|
|
|
|
var L,Code : longint;
|
|
|
|
begin
|
|
If length(AValue)=0 then
|
|
Clear
|
|
else
|
|
begin
|
|
Val(AValue,L,Code);
|
|
If Code=0 then
|
|
SetAsInteger(L)
|
|
else
|
|
DatabaseErrorFmt(SNotAnInteger,[AValue]);
|
|
end;
|
|
end;
|
|
|
|
Function TIntegerField.CheckRange(AValue : longint) : Boolean;
|
|
|
|
begin
|
|
if (FMinValue<>0) or (FMaxValue<>0) then
|
|
Result := (AValue>=FMinValue) and (AValue<=FMaxValue)
|
|
else
|
|
Result := (AValue>=FMinRange) and (AValue<=FMaxRange);
|
|
end;
|
|
|
|
Procedure TIntegerField.SetMaxValue (AValue : longint);
|
|
|
|
begin
|
|
If (AValue>=FMinRange) and (AValue<=FMaxRange) then
|
|
FMaxValue:=AValue
|
|
else
|
|
RangeError(AValue,FMinRange,FMaxRange);
|
|
end;
|
|
|
|
Procedure TIntegerField.SetMinValue (AValue : longint);
|
|
|
|
begin
|
|
If (AValue>=FMinRange) and (AValue<=FMaxRange) then
|
|
FMinValue:=AValue
|
|
else
|
|
RangeError(AValue,FMinRange,FMaxRange);
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------
|
|
TLargeintField
|
|
---------------------------------------------------------------------}
|
|
|
|
|
|
constructor TLargeintField.Create(AOwner: TComponent);
|
|
|
|
begin
|
|
Inherited Create(AOwner);
|
|
SetDataType(ftLargeint);
|
|
FMinRange:=Low(NativeInt);
|
|
FMaxRange:=High(NativeInt);
|
|
// MVC : Todo
|
|
// FValidchars:=['+','-','0'..'9'];
|
|
end;
|
|
|
|
function TLargeintField.GetAsFloat: Double;
|
|
|
|
begin
|
|
Result:=GetAsLargeInt;
|
|
end;
|
|
|
|
function TLargeintField.GetAsLargeInt: NativeInt;
|
|
|
|
begin
|
|
If Not GetValue(Result) then
|
|
Result:=0;
|
|
end;
|
|
|
|
function TLargeIntField.GetAsJSValue: JSValue;
|
|
|
|
var L : NativeInt;
|
|
|
|
begin
|
|
If GetValue(L) then
|
|
Result:=L
|
|
else
|
|
Result:=Null;
|
|
end;
|
|
|
|
function TLargeintField.GetAsInteger: Longint;
|
|
|
|
begin
|
|
Result:=GetAsLargeInt;
|
|
end;
|
|
|
|
function TLargeintField.GetAsString: string;
|
|
|
|
var L : NativeInt;
|
|
|
|
begin
|
|
If GetValue(L) then
|
|
Result:=IntTostr(L)
|
|
else
|
|
Result:='';
|
|
end;
|
|
|
|
procedure TLargeintField.GetText(var AText: string; ADisplayText: Boolean);
|
|
|
|
var l : NativeInt;
|
|
fmt : string;
|
|
|
|
begin
|
|
Atext:='';
|
|
If Not GetValue(l) then exit;
|
|
If ADisplayText or (FEditFormat='') then
|
|
fmt:=FDisplayFormat
|
|
else
|
|
fmt:=FEditFormat;
|
|
If length(fmt)<>0 then
|
|
AText:=FormatFloat(fmt,L)
|
|
else
|
|
Str(L,AText);
|
|
end;
|
|
|
|
function TLargeintField.GetValue(var AValue: NativeInt): Boolean;
|
|
|
|
var
|
|
P : JSValue;
|
|
|
|
begin
|
|
P:=GetData;
|
|
Result:=isInteger(P);
|
|
if Result then
|
|
AValue:=NativeInt(P);
|
|
end;
|
|
|
|
procedure TLargeintField.SetAsFloat(AValue: Double);
|
|
|
|
begin
|
|
SetAsLargeInt(Round(AValue));
|
|
end;
|
|
|
|
procedure TLargeintField.SetAsLargeInt(AValue: NativeInt);
|
|
|
|
begin
|
|
If CheckRange(AValue) then
|
|
SetData(AValue)
|
|
else
|
|
RangeError(AValue,FMinValue,FMaxValue);
|
|
end;
|
|
|
|
procedure TLargeintField.SetAsInteger(AValue: Longint);
|
|
|
|
begin
|
|
SetAsLargeInt(AValue);
|
|
end;
|
|
|
|
procedure TLargeintField.SetAsString(const AValue: string);
|
|
|
|
var L : NativeInt;
|
|
code : Longint;
|
|
|
|
begin
|
|
If length(AValue)=0 then
|
|
Clear
|
|
else
|
|
begin
|
|
Val(AValue,L,Code);
|
|
If Code=0 then
|
|
SetAsLargeInt(L)
|
|
else
|
|
DatabaseErrorFmt(SNotAnInteger,[AValue]);
|
|
end;
|
|
end;
|
|
|
|
procedure TLargeintField.SetVarValue(const AValue: JSValue);
|
|
begin
|
|
if IsInteger(Avalue) then
|
|
SetAsLargeInt(NativeInt(AValue))
|
|
else
|
|
RaiseAccessError(SLargeInt);
|
|
end;
|
|
|
|
Function TLargeintField.CheckRange(AValue : NativeInt) : Boolean;
|
|
|
|
begin
|
|
if (FMinValue<>0) or (FMaxValue<>0) then
|
|
Result := (AValue>=FMinValue) and (AValue<=FMaxValue)
|
|
else
|
|
Result := (AValue>=FMinRange) and (AValue<=FMaxRange);
|
|
end;
|
|
|
|
Procedure TLargeintField.SetMaxValue (AValue : NativeInt);
|
|
|
|
begin
|
|
If (AValue>=FMinRange) and (AValue<=FMaxRange) then
|
|
FMaxValue:=AValue
|
|
else
|
|
RangeError(AValue,FMinRange,FMaxRange);
|
|
end;
|
|
|
|
Procedure TLargeintField.SetMinValue (AValue : NativeInt);
|
|
|
|
begin
|
|
If (AValue>=FMinRange) and (AValue<=FMaxRange) then
|
|
FMinValue:=AValue
|
|
else
|
|
RangeError(AValue,FMinRange,FMaxRange);
|
|
end;
|
|
|
|
|
|
{ TAutoIncField }
|
|
|
|
constructor TAutoIncField.Create(AOwner: TComponent);
|
|
|
|
begin
|
|
Inherited Create(AOWner);
|
|
SetDataType(ftAutoInc);
|
|
end;
|
|
|
|
Procedure TAutoIncField.SetAsInteger(AValue: Longint);
|
|
|
|
begin
|
|
// Some databases allows insertion of explicit values into identity columns
|
|
// (some of them also allows (some not) updating identity columns)
|
|
// So allow it at client side and leave check for server side
|
|
//if not(FDataSet.State in [dsFilter,dsSetKey,dsInsert]) then
|
|
// DataBaseError(SCantSetAutoIncFields);
|
|
inherited;
|
|
end;
|
|
|
|
{ TFloatField }
|
|
|
|
procedure TFloatField.SetCurrency(const AValue: Boolean);
|
|
begin
|
|
if FCurrency=AValue then exit;
|
|
FCurrency:=AValue;
|
|
end;
|
|
|
|
procedure TFloatField.SetPrecision(const AValue: Longint);
|
|
begin
|
|
if (AValue = -1) or (AValue > 1) then
|
|
FPrecision := AValue
|
|
else
|
|
FPrecision := 2;
|
|
end;
|
|
|
|
function TFloatField.GetAsFloat: Double;
|
|
|
|
Var
|
|
P : JSValue;
|
|
|
|
begin
|
|
P:=GetData;
|
|
If IsNumber(P) then
|
|
Result:=Double(P)
|
|
else
|
|
Result:=0.0;
|
|
end;
|
|
|
|
function TFloatField.GetAsJSValue: JSValue;
|
|
|
|
var
|
|
P : JSValue;
|
|
|
|
begin
|
|
P:=GetData;
|
|
if IsNumber(P) then
|
|
Result:=P
|
|
else
|
|
Result:=Null;
|
|
end;
|
|
|
|
function TFloatField.GetAsLargeInt: NativeInt;
|
|
begin
|
|
Result:=Round(GetAsFloat);
|
|
end;
|
|
|
|
function TFloatField.GetAsInteger: Longint;
|
|
|
|
begin
|
|
Result:=Round(GetAsFloat);
|
|
end;
|
|
|
|
function TFloatField.GetAsString: string;
|
|
|
|
var
|
|
P : JSValue;
|
|
|
|
begin
|
|
P:=GetData;
|
|
if IsNumber(P) then
|
|
Result:=FloatToStr(Double(P))
|
|
else
|
|
Result:='';
|
|
end;
|
|
|
|
procedure TFloatField.GetText(var AText: string; ADisplayText: Boolean);
|
|
|
|
Var
|
|
fmt : string;
|
|
E : Double;
|
|
Digits : integer;
|
|
ff: TFloatFormat;
|
|
P : JSValue;
|
|
|
|
begin
|
|
AText:='';
|
|
P:=GetData;
|
|
if Not IsNumber(P) then
|
|
exit;
|
|
E:=Double(P);
|
|
If ADisplayText or (Length(FEditFormat) = 0) Then
|
|
Fmt:=FDisplayFormat
|
|
else
|
|
Fmt:=FEditFormat;
|
|
|
|
Digits := 0;
|
|
if not FCurrency then
|
|
ff := ffGeneral
|
|
else
|
|
begin
|
|
Digits := 2;
|
|
ff := ffFixed;
|
|
end;
|
|
|
|
|
|
If fmt<>'' then
|
|
AText:=FormatFloat(fmt,E)
|
|
else
|
|
AText:=FloatToStrF(E,ff,FPrecision,Digits);
|
|
end;
|
|
|
|
procedure TFloatField.SetAsFloat(AValue: Double);
|
|
|
|
begin
|
|
If CheckRange(AValue) then
|
|
SetData(AValue)
|
|
else
|
|
RangeError(AValue,FMinValue,FMaxValue);
|
|
end;
|
|
|
|
procedure TFloatField.SetAsLargeInt(AValue: NativeInt);
|
|
begin
|
|
SetAsFloat(AValue);
|
|
end;
|
|
|
|
procedure TFloatField.SetAsInteger(AValue: Longint);
|
|
|
|
begin
|
|
SetAsFloat(AValue);
|
|
end;
|
|
|
|
procedure TFloatField.SetAsString(const AValue: string);
|
|
|
|
var f : Double;
|
|
|
|
begin
|
|
If (AValue='') then
|
|
Clear
|
|
else
|
|
begin
|
|
If not TryStrToFloat(AValue,F) then
|
|
DatabaseErrorFmt(SNotAFloat, [AValue]);
|
|
SetAsFloat(f);
|
|
end;
|
|
end;
|
|
|
|
procedure TFloatField.SetVarValue(const AValue: JSValue);
|
|
begin
|
|
if IsNumber(aValue) then
|
|
SetAsFloat(Double(AValue))
|
|
else
|
|
RaiseAccessError('Float');
|
|
end;
|
|
|
|
constructor TFloatField.Create(AOwner: TComponent);
|
|
|
|
begin
|
|
Inherited Create(AOwner);
|
|
SetDataType(ftFloat);
|
|
FPrecision:=15;
|
|
// MVC
|
|
// FValidChars := [DecimalSeparator, '+', '-', '0'..'9', 'E', 'e'];
|
|
end;
|
|
|
|
Function TFloatField.CheckRange(AValue : Double) : Boolean;
|
|
|
|
begin
|
|
If (FMinValue<>0) or (FMaxValue<>0) then
|
|
Result:=(AValue>=FMinValue) and (AValue<=FMaxValue)
|
|
else
|
|
Result:=True;
|
|
end;
|
|
|
|
{ TBooleanField }
|
|
|
|
function TBooleanField.GetAsBoolean: Boolean;
|
|
|
|
var
|
|
P : JSValue;
|
|
|
|
begin
|
|
P:=GetData;
|
|
if isBoolean(P) then
|
|
Result:=Boolean(P)
|
|
else
|
|
Result:=False;
|
|
end;
|
|
|
|
function TBooleanField.GetAsJSValue: JSValue;
|
|
|
|
var
|
|
P : JSValue;
|
|
|
|
begin
|
|
P:=GetData;
|
|
if isBoolean(P) then
|
|
Result:=Boolean(P)
|
|
else
|
|
Result:=Null;
|
|
end;
|
|
|
|
function TBooleanField.GetAsString: string;
|
|
|
|
var
|
|
P : JSValue;
|
|
|
|
begin
|
|
P:=GetData;
|
|
if isBoolean(P) then
|
|
Result:=FDisplays[False,Boolean(P)]
|
|
else
|
|
result:='';
|
|
end;
|
|
|
|
function TBooleanField.GetDefaultWidth: Longint;
|
|
|
|
begin
|
|
Result:=Length(FDisplays[false,false]);
|
|
If Result<Length(FDisplays[false,True]) then
|
|
Result:=Length(FDisplays[false,True]);
|
|
end;
|
|
|
|
function TBooleanField.GetAsInteger: Longint;
|
|
begin
|
|
Result := ord(GetAsBoolean);
|
|
end;
|
|
|
|
procedure TBooleanField.SetAsInteger(AValue: Longint);
|
|
begin
|
|
SetAsBoolean(AValue<>0);
|
|
end;
|
|
|
|
procedure TBooleanField.SetAsBoolean(AValue: Boolean);
|
|
|
|
begin
|
|
SetData(AValue);
|
|
end;
|
|
|
|
procedure TBooleanField.SetAsString(const AValue: string);
|
|
|
|
var Temp : string;
|
|
|
|
begin
|
|
Temp:=UpperCase(AValue);
|
|
if Temp='' then
|
|
Clear
|
|
else if pos(Temp, FDisplays[True,True])=1 then
|
|
SetAsBoolean(True)
|
|
else if pos(Temp, FDisplays[True,False])=1 then
|
|
SetAsBoolean(False)
|
|
else
|
|
DatabaseErrorFmt(SNotABoolean,[AValue]);
|
|
end;
|
|
|
|
procedure TBooleanField.SetVarValue(const AValue: JSValue);
|
|
begin
|
|
if isBoolean(aValue) then
|
|
SetAsBoolean(Boolean(AValue))
|
|
else if isNumber(aValue) then
|
|
SetAsBoolean(Double(AValue)<>0)
|
|
end;
|
|
|
|
constructor TBooleanField.Create(AOwner: TComponent);
|
|
|
|
begin
|
|
Inherited Create(AOwner);
|
|
SetDataType(ftBoolean);
|
|
DisplayValues:='True;False';
|
|
end;
|
|
|
|
Procedure TBooleanField.SetDisplayValues(const AValue : String);
|
|
|
|
var I : longint;
|
|
|
|
begin
|
|
If FDisplayValues<>AValue then
|
|
begin
|
|
I:=Pos(';',AValue);
|
|
If (I<2) or (I=Length(AValue)) then
|
|
DatabaseErrorFmt(SInvalidDisplayValues,[AValue]);
|
|
FdisplayValues:=AValue;
|
|
// Store display values and their uppercase equivalents;
|
|
FDisplays[False,True]:=Copy(AValue,1,I-1);
|
|
FDisplays[True,True]:=UpperCase(FDisplays[False,True]);
|
|
FDisplays[False,False]:=Copy(AValue,I+1,Length(AValue)-i);
|
|
FDisplays[True,False]:=UpperCase(FDisplays[False,False]);
|
|
PropertyChanged(True);
|
|
end;
|
|
end;
|
|
|
|
{ TDateTimeField }
|
|
|
|
procedure TDateTimeField.SetDisplayFormat(const AValue: string);
|
|
begin
|
|
if FDisplayFormat<>AValue then begin
|
|
FDisplayFormat:=AValue;
|
|
PropertyChanged(True);
|
|
end;
|
|
end;
|
|
|
|
function TDateTimeField.ConvertToDateTime(aValue: JSValue; aRaiseError: Boolean): TDateTime;
|
|
begin
|
|
if JS.isNull(aValue) then
|
|
Result:=0
|
|
else if Assigned(Dataset) then
|
|
Result:=Dataset.ConvertToDateTime(Self,aValue,aRaiseError)
|
|
else
|
|
Result:=TDataset.DefaultConvertToDateTime(Self,aValue,aRaiseError);
|
|
end;
|
|
|
|
function TDateTimeField.DateTimeToNativeDateTime(aValue: TDateTime): JSValue;
|
|
begin
|
|
if Assigned(Dataset) then
|
|
Result:=Dataset.ConvertDateTimeToNative(Self,aValue)
|
|
else
|
|
Result:=TDataset.DefaultConvertDateTimeToNative(Self,aValue);
|
|
end;
|
|
|
|
function TDateTimeField.GetAsDateTime: TDateTime;
|
|
|
|
begin
|
|
Result:=ConvertToDateTime(GetData,False);
|
|
end;
|
|
|
|
procedure TDateTimeField.SetVarValue(const AValue: JSValue);
|
|
|
|
begin
|
|
SetAsDateTime(ConvertToDateTime(aValue,True));
|
|
end;
|
|
|
|
function TDateTimeField.GetAsJSValue: JSValue;
|
|
|
|
begin
|
|
Result:=GetData;
|
|
if Not isString(Result) and not IsObject(Result) then
|
|
Result:=Null;
|
|
end;
|
|
|
|
function TDateTimeField.GetDataSize: Integer;
|
|
begin
|
|
Result:=inherited GetDataSize;
|
|
end;
|
|
|
|
function TDateTimeField.GetAsFloat: Double;
|
|
|
|
begin
|
|
Result:=GetAsdateTime;
|
|
end;
|
|
|
|
|
|
function TDateTimeField.GetAsString: string;
|
|
|
|
begin
|
|
GetText(Result,False);
|
|
end;
|
|
|
|
|
|
Procedure TDateTimeField.GetText(var AText: string; ADisplayText: Boolean);
|
|
|
|
var
|
|
R : TDateTime;
|
|
F : String;
|
|
|
|
begin
|
|
R:=ConvertToDateTime(GetData,false);
|
|
If (R=0) then
|
|
AText:=''
|
|
else
|
|
begin
|
|
If (ADisplayText) and (Length(FDisplayFormat)<>0) then
|
|
F:=FDisplayFormat
|
|
else
|
|
Case DataType of
|
|
ftTime : F:=LongTimeFormat;
|
|
ftDate : F:=ShortDateFormat;
|
|
else
|
|
F:='c'
|
|
end;
|
|
AText:=FormatDateTime(F,R);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TDateTimeField.SetAsDateTime(AValue: TDateTime);
|
|
|
|
begin
|
|
SetData(DateTimeToNativeDateTime(aValue));
|
|
end;
|
|
|
|
|
|
procedure TDateTimeField.SetAsFloat(AValue: Double);
|
|
|
|
begin
|
|
SetAsDateTime(AValue);
|
|
end;
|
|
|
|
|
|
procedure TDateTimeField.SetAsString(const AValue: string);
|
|
|
|
var R : TDateTime;
|
|
|
|
begin
|
|
if AValue<>'' then
|
|
begin
|
|
R:=StrToDateTime(AValue);
|
|
SetData(DateTimeToNativeDateTime(R));
|
|
end
|
|
else
|
|
SetData(Null);
|
|
end;
|
|
|
|
|
|
constructor TDateTimeField.Create(AOwner: TComponent);
|
|
|
|
begin
|
|
Inherited Create(AOwner);
|
|
SetDataType(ftDateTime);
|
|
end;
|
|
|
|
|
|
{ TDateField }
|
|
|
|
constructor TDateField.Create(AOwner: TComponent);
|
|
|
|
begin
|
|
Inherited Create(AOwner);
|
|
SetDataType(ftDate);
|
|
end;
|
|
|
|
|
|
{ TTimeField }
|
|
|
|
constructor TTimeField.Create(AOwner: TComponent);
|
|
|
|
begin
|
|
Inherited Create(AOwner);
|
|
SetDataType(ftTime);
|
|
end;
|
|
|
|
procedure TTimeField.SetAsString(const AValue: string);
|
|
|
|
var
|
|
R : TDateTime;
|
|
|
|
begin
|
|
if AValue<>'' then
|
|
begin
|
|
R:=StrToTime(AValue);
|
|
SetData(DateTimeToNativeDateTime(R));
|
|
end
|
|
else
|
|
SetData(Null);
|
|
end;
|
|
|
|
|
|
|
|
{ TBinaryField }
|
|
|
|
class procedure TBinaryField.CheckTypeSize(AValue: Longint);
|
|
|
|
begin
|
|
// Just check for really invalid stuff; actual size is
|
|
// dependent on the record...
|
|
If AValue<1 then
|
|
DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
|
|
end;
|
|
|
|
function TBinaryField.BlobToBytes(aValue: JSValue): TBytes;
|
|
|
|
begin
|
|
if Assigned(Dataset) then
|
|
Result:=DataSet.BlobDataToBytes(aValue)
|
|
else
|
|
Result:=TDataSet.DefaultBlobDataToBytes(aValue)
|
|
end;
|
|
|
|
function TBinaryField.BytesToBlob(aValue: TBytes): JSValue;
|
|
|
|
begin
|
|
if Assigned(Dataset) then
|
|
Result:=DataSet.BytesToBlobData(aValue)
|
|
else
|
|
Result:=TDataSet.DefaultBytesToBlobData(aValue)
|
|
end;
|
|
|
|
function TBinaryField.GetAsString: string;
|
|
|
|
var
|
|
V : JSValue;
|
|
S : TBytes;
|
|
I : Integer;
|
|
|
|
begin
|
|
Result := '';
|
|
V:=GetData;
|
|
if V<>Null then
|
|
if (DataType=ftMemo) then
|
|
Result:=String(V)
|
|
else
|
|
begin
|
|
S:=BlobToBytes(V);
|
|
For I:=0 to Length(S)-1 do
|
|
Result:=TJSString(Result).Concat(TJSString.fromCharCode(S[I]));
|
|
end;
|
|
end;
|
|
|
|
|
|
function TBinaryField.GetAsJSValue: JSValue;
|
|
|
|
begin
|
|
Result:=GetData;
|
|
end;
|
|
|
|
|
|
function TBinaryField.GetValue(var AValue: TBytes): Boolean;
|
|
var
|
|
V : JSValue;
|
|
begin
|
|
V:=GetData;
|
|
Result:=(V<>Null);
|
|
if Result then
|
|
AValue:=BlobToBytes(V)
|
|
else
|
|
SetLength(AValue,0);
|
|
end;
|
|
|
|
|
|
|
|
procedure TBinaryField.SetAsString(const AValue: string);
|
|
|
|
var
|
|
B : TBytes;
|
|
i : Integer;
|
|
|
|
begin
|
|
if DataType=ftMemo then
|
|
SetData(aValue)
|
|
else
|
|
begin
|
|
SetLength(B, Length(aValue));
|
|
For I:=1 to Length(aValue) do
|
|
B[i-1]:=Ord(aValue[i]);
|
|
SetAsBytes(B);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TBinaryField.SetVarValue(const AValue: JSValue);
|
|
|
|
var
|
|
B: TBytes;
|
|
I,Len: integer;
|
|
|
|
begin
|
|
if IsArray(AValue) then
|
|
begin
|
|
Len:=Length(TJSValueDynArray(AValue));
|
|
SetLength(B, Len);
|
|
For I:=1 to Len-1 do
|
|
B[i]:=TBytes(AValue)[i];
|
|
SetAsBytes(B);
|
|
end
|
|
else if IsString(AValue) then
|
|
SetAsString(String(AValue))
|
|
else
|
|
RaiseAccessError('Blob');
|
|
end;
|
|
|
|
function TBinaryField.GetAsBytes: TBytes;
|
|
|
|
Var
|
|
V : JSValue;
|
|
|
|
begin
|
|
V:=GetData;
|
|
if Assigned(V) then
|
|
Result:=BlobToBytes(V)
|
|
else
|
|
SetLength(Result,0);
|
|
end;
|
|
|
|
procedure TBinaryField.SetAsBytes(const aValue: TBytes);
|
|
begin
|
|
SetData(BytesToBlob(aValue))
|
|
end;
|
|
|
|
|
|
constructor TBinaryField.Create(AOwner: TComponent);
|
|
|
|
begin
|
|
Inherited Create(AOwner);
|
|
end;
|
|
|
|
|
|
|
|
{ TBlobField }
|
|
|
|
constructor TBlobField.Create(AOwner: TComponent);
|
|
|
|
begin
|
|
Inherited Create(AOwner);
|
|
SetDataType(ftBlob);
|
|
end;
|
|
|
|
procedure TBlobField.Clear;
|
|
begin
|
|
SetData(Null);
|
|
end;
|
|
|
|
(*
|
|
function TBlobField.GetBlobType: TBlobType;
|
|
begin
|
|
Result:=ftBlob;
|
|
end;
|
|
|
|
procedure TBlobField.SetBlobType(AValue: TBlobType);
|
|
begin
|
|
SetFieldType(TFieldType(AValue));
|
|
end;
|
|
*)
|
|
|
|
|
|
function TBlobField.GetBlobType: TBlobType;
|
|
begin
|
|
Result:=ftBlob;
|
|
end;
|
|
|
|
procedure TBlobField.SetBlobType(AValue: TBlobType);
|
|
begin
|
|
SetFieldType(aValue);
|
|
end;
|
|
|
|
procedure TBlobField.SetDisplayValue(AValue: TBlobDisplayValue);
|
|
begin
|
|
if FDisplayValue=AValue then Exit;
|
|
FDisplayValue:=AValue;
|
|
PropertyChanged(False);
|
|
end;
|
|
|
|
class procedure TBlobField.CheckTypeSize(AValue: Longint);
|
|
begin
|
|
If AValue<0 then
|
|
DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
|
|
end;
|
|
|
|
function TBlobField.GetBlobSize: Longint;
|
|
|
|
var
|
|
B : TBytes;
|
|
|
|
begin
|
|
B:=GetAsBytes;
|
|
Result:=Length(B);
|
|
end;
|
|
|
|
|
|
function TBlobField.GetIsNull: Boolean;
|
|
|
|
begin
|
|
if Not Modified then
|
|
Result:= inherited GetIsNull
|
|
else
|
|
Result:=GetBlobSize=0;
|
|
end;
|
|
|
|
procedure TBlobField.GetText(var AText: string; ADisplayText: Boolean);
|
|
|
|
begin
|
|
Case FDisplayValue of
|
|
dvClass:
|
|
aText:=GetClassDesc;
|
|
dvFull:
|
|
aText:=GetAsString;
|
|
dvClip:
|
|
begin
|
|
aText:=GetAsString;
|
|
if aDisplayText and (Length(aText)>DisplayWidth) then
|
|
aText:=Copy(Text,1,DisplayWidth) + '...';
|
|
end;
|
|
dvFit:
|
|
begin
|
|
aText:=GetAsString;
|
|
if aDisplayText and (Length(aText)>DisplayWidth) then
|
|
aText:=GetClassDesc;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
class function TBlobField.IsBlob: Boolean;
|
|
|
|
begin
|
|
Result:=True;
|
|
end;
|
|
|
|
procedure TBlobField.SetFieldType(AValue: TFieldType);
|
|
begin
|
|
if AValue in ftBlobTypes then
|
|
SetDataType(AValue);
|
|
end;
|
|
|
|
{ TMemoField }
|
|
|
|
constructor TMemoField.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
SetDataType(ftMemo);
|
|
end;
|
|
|
|
|
|
|
|
{ TVariantField }
|
|
|
|
constructor TVariantField.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
SetDataType(ftVariant);
|
|
end;
|
|
|
|
class procedure TVariantField.CheckTypeSize(aValue: Integer);
|
|
begin
|
|
{ empty }
|
|
end;
|
|
|
|
function TVariantField.GetAsBoolean: Boolean;
|
|
begin
|
|
Result :=GetAsJSValue=True;
|
|
end;
|
|
|
|
function TVariantField.GetAsDateTime: TDateTime;
|
|
|
|
Var
|
|
V : JSValue;
|
|
|
|
begin
|
|
V:=GetData;
|
|
if Assigned(Dataset) then
|
|
Result:=Dataset.ConvertToDateTime(Self,V,True)
|
|
else
|
|
Result:=TDataset.DefaultConvertToDateTime(Self,V,True)
|
|
end;
|
|
|
|
function TVariantField.GetAsFloat: Double;
|
|
|
|
Var
|
|
V : JSValue;
|
|
|
|
begin
|
|
V:=GetData;
|
|
if isNumber(V) then
|
|
Result:=Double(V)
|
|
else if isString(V) then
|
|
Result:=parsefloat(String(V))
|
|
else
|
|
RaiseAccessError('Variant');
|
|
end;
|
|
|
|
function TVariantField.GetAsInteger: Longint;
|
|
Var
|
|
V : JSValue;
|
|
|
|
begin
|
|
V:=GetData;
|
|
if isInteger(V) then
|
|
Result:=Integer(V)
|
|
else if isString(V) then
|
|
Result:=parseInt(String(V))
|
|
else
|
|
RaiseAccessError('Variant');
|
|
end;
|
|
|
|
function TVariantField.GetAsString: string;
|
|
Var
|
|
V : JSValue;
|
|
|
|
begin
|
|
V:=GetData;
|
|
if isInteger(V) then
|
|
Result:=IntToStr(Integer(V))
|
|
else if isNumber(V) then
|
|
Result:=FloatToStr(Double(V))
|
|
else if isString(V) then
|
|
Result:=String(V)
|
|
else
|
|
RaiseAccessError('Variant');
|
|
end;
|
|
|
|
|
|
function TVariantField.GetAsJSValue: JSValue;
|
|
begin
|
|
Result:=GetData;
|
|
end;
|
|
|
|
procedure TVariantField.SetAsBoolean(aValue: Boolean);
|
|
begin
|
|
SetVarValue(aValue);
|
|
end;
|
|
|
|
procedure TVariantField.SetAsDateTime(aValue: TDateTime);
|
|
begin
|
|
SetVarValue(aValue);
|
|
end;
|
|
|
|
procedure TVariantField.SetAsFloat(aValue: Double);
|
|
begin
|
|
SetVarValue(aValue);
|
|
end;
|
|
|
|
procedure TVariantField.SetAsInteger(AValue: Longint);
|
|
begin
|
|
SetVarValue(aValue);
|
|
end;
|
|
|
|
procedure TVariantField.SetAsString(const aValue: string);
|
|
begin
|
|
SetVarValue(aValue);
|
|
end;
|
|
|
|
procedure TVariantField.SetVarValue(const aValue: JSValue);
|
|
begin
|
|
SetData(aValue);
|
|
end;
|
|
|
|
{ TFieldsEnumerator }
|
|
|
|
function TFieldsEnumerator.GetCurrent: TField;
|
|
begin
|
|
Result := FFields[FPosition];
|
|
end;
|
|
|
|
constructor TFieldsEnumerator.Create(AFields: TFields);
|
|
begin
|
|
inherited Create;
|
|
FFields := AFields;
|
|
FPosition := -1;
|
|
end;
|
|
|
|
function TFieldsEnumerator.MoveNext: Boolean;
|
|
begin
|
|
inc(FPosition);
|
|
Result := FPosition < FFields.Count;
|
|
end;
|
|
|
|
{ TFields }
|
|
|
|
constructor TFields.Create(ADataset: TDataset);
|
|
|
|
begin
|
|
FDataSet:=ADataset;
|
|
FFieldList:=TFpList.Create;
|
|
FValidFieldKinds:=[fkData..fkInternalcalc];
|
|
end;
|
|
|
|
destructor TFields.Destroy;
|
|
|
|
begin
|
|
if Assigned(FFieldList) then
|
|
Clear;
|
|
FreeAndNil(FFieldList);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TFields.ClearFieldDefs;
|
|
|
|
Var
|
|
i : Integer;
|
|
|
|
begin
|
|
For I:=0 to Count-1 do
|
|
Fields[i].FFieldDef:=Nil;
|
|
end;
|
|
|
|
procedure TFields.Changed;
|
|
|
|
begin
|
|
// Removed FDataSet.Active check, needed for Persistent fields (see bug ID 30954)
|
|
if (FDataSet <> nil) and not (csDestroying in FDataSet.ComponentState) then
|
|
FDataSet.DataEvent(deFieldListChange, 0);
|
|
If Assigned(FOnChange) then
|
|
FOnChange(Self);
|
|
end;
|
|
|
|
procedure TFields.CheckfieldKind(Fieldkind: TFieldKind; Field: TField);
|
|
|
|
begin
|
|
If Not (FieldKind in ValidFieldKinds) Then
|
|
DatabaseErrorFmt(SInvalidFieldKind,[Field.FieldName]);
|
|
end;
|
|
|
|
function TFields.GetCount: Longint;
|
|
|
|
begin
|
|
Result:=FFieldList.Count;
|
|
end;
|
|
|
|
|
|
function TFields.GetField(Index: Integer): TField;
|
|
|
|
begin
|
|
Result:=Tfield(FFieldList[Index]);
|
|
end;
|
|
|
|
procedure TFields.SetField(Index: Integer; Value: TField);
|
|
begin
|
|
Fields[Index].Assign(Value);
|
|
end;
|
|
|
|
procedure TFields.SetFieldIndex(Field: TField; Value: Integer);
|
|
var Old : Longint;
|
|
begin
|
|
Old := FFieldList.indexOf(Field);
|
|
If Old=-1 then
|
|
Exit;
|
|
// Check value
|
|
If Value<0 Then Value:=0;
|
|
If Value>=Count then Value:=Count-1;
|
|
If Value<>Old then
|
|
begin
|
|
FFieldList.Delete(Old);
|
|
FFieldList.Insert(Value,Field);
|
|
Field.PropertyChanged(True);
|
|
Changed;
|
|
end;
|
|
end;
|
|
|
|
procedure TFields.Add(Field: TField);
|
|
|
|
begin
|
|
CheckFieldName(Field.FieldName);
|
|
FFieldList.Add(Field);
|
|
Field.FFields:=Self;
|
|
Changed;
|
|
end;
|
|
|
|
procedure TFields.CheckFieldName(const Value: String);
|
|
|
|
begin
|
|
If FindField(Value)<>Nil then
|
|
DataBaseErrorFmt(SDuplicateFieldName,[Value],FDataset);
|
|
end;
|
|
|
|
procedure TFields.CheckFieldNames(const Value: String);
|
|
|
|
var
|
|
N: String;
|
|
StrPos: Integer;
|
|
|
|
begin
|
|
if Value = '' then
|
|
Exit;
|
|
StrPos := 1;
|
|
repeat
|
|
N := ExtractFieldName(Value, StrPos);
|
|
// Will raise an error if no such field...
|
|
FieldByName(N);
|
|
until StrPos > Length(Value);
|
|
end;
|
|
|
|
procedure TFields.Clear;
|
|
var
|
|
AField: TField;
|
|
begin
|
|
while FFieldList.Count > 0 do
|
|
begin
|
|
AField := TField(FFieldList.Last);
|
|
AField.FDataSet := Nil;
|
|
AField.Free;
|
|
FFieldList.Delete(FFieldList.Count - 1);
|
|
end;
|
|
Changed;
|
|
end;
|
|
|
|
function TFields.FindField(const Value: String): TField;
|
|
var S : String;
|
|
I : longint;
|
|
begin
|
|
S:=UpperCase(Value);
|
|
For I:=0 To FFieldList.Count-1 do
|
|
begin
|
|
Result:=TField(FFieldList[I]);
|
|
if S=UpperCase(Result.FieldName) then
|
|
begin
|
|
{$ifdef dsdebug}
|
|
Writeln ('Found field ',Value);
|
|
{$endif}
|
|
Exit;
|
|
end;
|
|
end;
|
|
Result:=Nil;
|
|
end;
|
|
|
|
function TFields.FieldByName(const Value: String): TField;
|
|
|
|
begin
|
|
Result:=FindField(Value);
|
|
If result=Nil then
|
|
DatabaseErrorFmt(SFieldNotFound,[Value],FDataset);
|
|
end;
|
|
|
|
function TFields.FieldByNumber(FieldNo: Integer): TField;
|
|
var i : Longint;
|
|
begin
|
|
For I:=0 to FFieldList.Count-1 do
|
|
begin
|
|
Result:=TField(FFieldList[I]);
|
|
if FieldNo=Result.FieldNo then
|
|
Exit;
|
|
end;
|
|
Result:=Nil;
|
|
end;
|
|
|
|
function TFields.GetEnumerator: TFieldsEnumerator;
|
|
|
|
begin
|
|
Result:=TFieldsEnumerator.Create(Self);
|
|
end;
|
|
|
|
procedure TFields.GetFieldNames(Values: TStrings);
|
|
var i : longint;
|
|
begin
|
|
Values.Clear;
|
|
For I:=0 to FFieldList.Count-1 do
|
|
Values.Add(Tfield(FFieldList[I]).FieldName);
|
|
end;
|
|
|
|
function TFields.IndexOf(Field: TField): Longint;
|
|
|
|
begin
|
|
Result:=FFieldList.IndexOf(Field);
|
|
end;
|
|
|
|
procedure TFields.Remove(Value : TField);
|
|
|
|
begin
|
|
FFieldList.Remove(Value);
|
|
Value.FFields := nil;
|
|
Changed;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------
|
|
TDatalink
|
|
---------------------------------------------------------------------}
|
|
|
|
Constructor TDataLink.Create;
|
|
|
|
begin
|
|
Inherited Create;
|
|
FBufferCount:=1;
|
|
FFirstRecord := 0;
|
|
FDataSource := nil;
|
|
FDatasourceFixed:=False;
|
|
end;
|
|
|
|
|
|
Destructor TDataLink.Destroy;
|
|
|
|
begin
|
|
Factive:=False;
|
|
FEditing:=False;
|
|
FDataSourceFixed:=False;
|
|
DataSource:=Nil;
|
|
Inherited Destroy;
|
|
end;
|
|
|
|
|
|
Procedure TDataLink.ActiveChanged;
|
|
|
|
begin
|
|
FFirstRecord := 0;
|
|
end;
|
|
|
|
Procedure TDataLink.CheckActiveAndEditing;
|
|
|
|
Var
|
|
B : Boolean;
|
|
|
|
begin
|
|
B:=Assigned(DataSource) and not (DataSource.State in [dsInactive, dsOpening]);
|
|
SetActive(B);
|
|
B:=Assigned(DataSource) and (DataSource.State in dsEditModes) and Not FReadOnly;
|
|
If B<>FEditing Then
|
|
begin
|
|
FEditing:=B;
|
|
EditingChanged;
|
|
end;
|
|
end;
|
|
|
|
|
|
Procedure TDataLink.CheckBrowseMode;
|
|
|
|
begin
|
|
end;
|
|
|
|
|
|
Function TDataLink.CalcFirstRecord(Index : Integer) : Integer;
|
|
begin
|
|
if DataSource.DataSet.FActiveRecord > FFirstRecord + Index + FBufferCount - 1 then
|
|
Result := DataSource.DataSet.FActiveRecord - (FFirstRecord + Index + FBufferCount - 1)
|
|
else if DataSource.DataSet.FActiveRecord < FFirstRecord + Index then
|
|
Result := DataSource.DataSet.FActiveRecord - (FFirstRecord + Index)
|
|
else Result := 0;
|
|
|
|
Inc(FFirstRecord, Index + Result);
|
|
end;
|
|
|
|
|
|
Procedure TDataLink.CalcRange;
|
|
var
|
|
aMax, aMin: integer;
|
|
begin
|
|
aMin:= DataSet.FActiveRecord - FBufferCount + 1;
|
|
If aMin < 0 Then aMin:= 0;
|
|
aMax:= Dataset.FBufferCount - FBufferCount;
|
|
If aMax < 0 then aMax:= 0;
|
|
|
|
If aMax>DataSet.FActiveRecord Then aMax:=DataSet.FActiveRecord;
|
|
If FFirstRecord < aMin Then FFirstRecord:= aMin;
|
|
If FFirstrecord > aMax Then FFirstRecord:= aMax;
|
|
|
|
If (FfirstRecord<>0) And
|
|
(DataSet.FActiveRecord - FFirstRecord < FBufferCount -1) Then
|
|
Dec(FFirstRecord, 1);
|
|
|
|
end;
|
|
|
|
|
|
Procedure TDataLink.DataEvent(Event: TDataEvent; Info: JSValue);
|
|
begin
|
|
if Event = deUpdateState then
|
|
CheckActiveAndEditing
|
|
else if Active then
|
|
case Event of
|
|
deFieldChange, deRecordChange:
|
|
if not FUpdatingRecord then
|
|
RecordChanged(TField(Info));
|
|
deDataSetChange:
|
|
begin
|
|
SetActive(DataSource.DataSet.Active);
|
|
CalcRange;
|
|
CalcFirstRecord(Integer(Info));
|
|
DatasetChanged;
|
|
end;
|
|
deDataSetScroll: DatasetScrolled(CalcFirstRecord(Integer(Info)));
|
|
deLayoutChange:
|
|
begin
|
|
CalcFirstRecord(Integer(Info));
|
|
LayoutChanged;
|
|
end;
|
|
deUpdateRecord: UpdateRecord;
|
|
deCheckBrowseMode: CheckBrowseMode;
|
|
deFocusControl: FocusControl(Info);
|
|
end;
|
|
end;
|
|
|
|
|
|
Procedure TDataLink.DataSetChanged;
|
|
|
|
begin
|
|
RecordChanged(Nil);
|
|
end;
|
|
|
|
|
|
Procedure TDataLink.DataSetScrolled(Distance: Integer);
|
|
|
|
begin
|
|
DataSetChanged;
|
|
end;
|
|
|
|
|
|
Procedure TDataLink.EditingChanged;
|
|
|
|
begin
|
|
end;
|
|
|
|
|
|
Procedure TDataLink.FocusControl(Field: JSValue);
|
|
|
|
begin
|
|
end;
|
|
|
|
|
|
Function TDataLink.GetActiveRecord: Integer;
|
|
|
|
begin
|
|
Result:=Dataset.FActiveRecord - FFirstRecord;
|
|
end;
|
|
|
|
Function TDatalink.GetDataSet : TDataset;
|
|
|
|
begin
|
|
If Assigned(Datasource) then
|
|
Result:=DataSource.DataSet
|
|
else
|
|
Result:=Nil;
|
|
end;
|
|
|
|
|
|
Function TDataLink.GetBOF: Boolean;
|
|
|
|
begin
|
|
Result:=DataSet.BOF
|
|
end;
|
|
|
|
|
|
Function TDataLink.GetBufferCount: Integer;
|
|
|
|
begin
|
|
Result:=FBufferCount;
|
|
end;
|
|
|
|
|
|
Function TDataLink.GetEOF: Boolean;
|
|
|
|
begin
|
|
Result:=DataSet.EOF
|
|
end;
|
|
|
|
|
|
Function TDataLink.GetRecordCount: Integer;
|
|
|
|
begin
|
|
Result:=Dataset.FRecordCount;
|
|
If Result>BufferCount then
|
|
Result:=BufferCount;
|
|
end;
|
|
|
|
|
|
Procedure TDataLink.LayoutChanged;
|
|
|
|
begin
|
|
DataSetChanged;
|
|
end;
|
|
|
|
|
|
Function TDataLink.MoveBy(Distance: Integer): Integer;
|
|
|
|
begin
|
|
Result:=DataSet.MoveBy(Distance);
|
|
end;
|
|
|
|
|
|
Procedure TDataLink.RecordChanged(Field: TField);
|
|
|
|
begin
|
|
end;
|
|
|
|
|
|
Procedure TDataLink.SetActiveRecord(Value: Integer);
|
|
|
|
begin
|
|
{$ifdef dsdebug}
|
|
Writeln('Datalink. Setting active record to ',Value,' with firstrecord ',ffirstrecord);
|
|
{$endif}
|
|
Dataset.FActiveRecord:=Value + FFirstRecord;
|
|
end;
|
|
|
|
|
|
Procedure TDataLink.SetBufferCount(Value: Integer);
|
|
|
|
begin
|
|
If FBufferCount<>Value then
|
|
begin
|
|
FBufferCount:=Value;
|
|
if Active then begin
|
|
DataSet.RecalcBufListSize;
|
|
CalcRange;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDataLink.SetActive(AActive: Boolean);
|
|
begin
|
|
if Active <> AActive then
|
|
begin
|
|
FActive := AActive;
|
|
// !!!: Set internal state
|
|
ActiveChanged;
|
|
end;
|
|
end;
|
|
|
|
Procedure TDataLink.SetDataSource(Value : TDatasource);
|
|
|
|
begin
|
|
if FDataSource = Value then
|
|
Exit;
|
|
if not FDataSourceFixed then
|
|
begin
|
|
if Assigned(DataSource) then
|
|
Begin
|
|
DataSource.UnregisterDatalink(Self);
|
|
FDataSource := nil;
|
|
CheckActiveAndEditing;
|
|
End;
|
|
FDataSource := Value;
|
|
if Assigned(DataSource) then
|
|
begin
|
|
DataSource.RegisterDatalink(Self);
|
|
CheckActiveAndEditing;
|
|
End;
|
|
end;
|
|
end;
|
|
|
|
Procedure TDatalink.SetReadOnly(Value : Boolean);
|
|
|
|
begin
|
|
If FReadOnly<>Value then
|
|
begin
|
|
FReadOnly:=Value;
|
|
CheckActiveAndEditing;
|
|
end;
|
|
end;
|
|
|
|
Procedure TDataLink.UpdateData;
|
|
|
|
begin
|
|
end;
|
|
|
|
|
|
|
|
Function TDataLink.Edit: Boolean;
|
|
|
|
begin
|
|
If Not FReadOnly then
|
|
DataSource.Edit;
|
|
// Triggered event will set FEditing
|
|
Result:=FEditing;
|
|
end;
|
|
|
|
|
|
Procedure TDataLink.UpdateRecord;
|
|
|
|
begin
|
|
FUpdatingRecord:=True;
|
|
Try
|
|
UpdateData;
|
|
finally
|
|
FUpdatingRecord:=False;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------
|
|
TDetailDataLink
|
|
---------------------------------------------------------------------}
|
|
|
|
Function TDetailDataLink.GetDetailDataSet: TDataSet;
|
|
|
|
begin
|
|
Result := nil;
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------
|
|
TMasterDataLink
|
|
---------------------------------------------------------------------}
|
|
|
|
constructor TMasterDataLink.Create(ADataSet: TDataSet);
|
|
|
|
begin
|
|
inherited Create;
|
|
FDetailDataSet:=ADataSet;
|
|
FFields:=TList.Create;
|
|
end;
|
|
|
|
|
|
destructor TMasterDataLink.Destroy;
|
|
|
|
begin
|
|
FFields.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
|
|
Procedure TMasterDataLink.ActiveChanged;
|
|
|
|
begin
|
|
FFields.Clear;
|
|
if Active then
|
|
try
|
|
DataSet.GetFieldList(FFields, FFieldNames);
|
|
except
|
|
FFields.Clear;
|
|
raise;
|
|
end;
|
|
if FDetailDataSet.Active and not (csDestroying in FDetailDataSet.ComponentState) then
|
|
if Active and (FFields.Count > 0) then
|
|
DoMasterChange
|
|
else
|
|
DoMasterDisable;
|
|
end;
|
|
|
|
|
|
Procedure TMasterDataLink.CheckBrowseMode;
|
|
|
|
begin
|
|
if FDetailDataSet.Active then FDetailDataSet.CheckBrowseMode;
|
|
end;
|
|
|
|
|
|
Function TMasterDataLink.GetDetailDataSet: TDataSet;
|
|
|
|
begin
|
|
Result := FDetailDataSet;
|
|
end;
|
|
|
|
|
|
Procedure TMasterDataLink.LayoutChanged;
|
|
|
|
begin
|
|
ActiveChanged;
|
|
end;
|
|
|
|
|
|
Procedure TMasterDataLink.RecordChanged(Field: TField);
|
|
|
|
begin
|
|
if (DataSource.State <> dsSetKey) and FDetailDataSet.Active and
|
|
(FFields.Count > 0) and ((Field = nil) or
|
|
(FFields.IndexOf(Field) >= 0)) then
|
|
DoMasterChange;
|
|
end;
|
|
|
|
procedure TMasterDatalink.SetFieldNames(const Value: string);
|
|
|
|
begin
|
|
if FFieldNames <> Value then
|
|
begin
|
|
FFieldNames := Value;
|
|
ActiveChanged;
|
|
end;
|
|
end;
|
|
|
|
Procedure TMasterDataLink.DoMasterDisable;
|
|
|
|
begin
|
|
if Assigned(FOnMasterDisable) then
|
|
FOnMasterDisable(Self);
|
|
end;
|
|
|
|
Procedure TMasterDataLink.DoMasterChange;
|
|
|
|
begin
|
|
If Assigned(FOnMasterChange) then
|
|
FOnMasterChange(Self);
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------
|
|
TMasterParamsDataLink
|
|
---------------------------------------------------------------------}
|
|
|
|
constructor TMasterParamsDataLink.Create(ADataSet: TDataSet);
|
|
|
|
Var
|
|
P : TParams;
|
|
|
|
begin
|
|
inherited Create(ADataset);
|
|
If (ADataset<>Nil) then
|
|
begin
|
|
P:=TParams(GetObjectProp(ADataset,'Params',TParams));
|
|
if (P<>Nil) then
|
|
Params:=P;
|
|
end;
|
|
end;
|
|
|
|
|
|
Procedure TMasterParamsDataLink.SetParams(AValue : TParams);
|
|
|
|
begin
|
|
FParams:=AValue;
|
|
If (AValue<>Nil) then
|
|
RefreshParamNames;
|
|
end;
|
|
|
|
Procedure TMasterParamsDataLink.RefreshParamNames;
|
|
|
|
Var
|
|
FN : String;
|
|
DS : TDataset;
|
|
F : TField;
|
|
I : Integer;
|
|
P : TParam;
|
|
|
|
|
|
begin
|
|
FN:='';
|
|
DS:=Dataset;
|
|
If Assigned(FParams) then
|
|
begin
|
|
F:=Nil;
|
|
For I:=0 to FParams.Count-1 do
|
|
begin
|
|
P:=FParams[i];
|
|
if not P.Bound then
|
|
begin
|
|
If Assigned(DS) then
|
|
F:=DS.FindField(P.Name);
|
|
If (Not Assigned(DS)) or (not DS.Active) or (F<>Nil) then
|
|
begin
|
|
If (FN<>'') then
|
|
FN:=FN+';';
|
|
FN:=FN+P.Name;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
FieldNames:=FN;
|
|
end;
|
|
|
|
Procedure TMasterParamsDataLink.CopyParamsFromMaster(CopyBound : Boolean);
|
|
|
|
begin
|
|
if Assigned(FParams) then
|
|
FParams.CopyParamValuesFromDataset(Dataset,CopyBound);
|
|
end;
|
|
|
|
Procedure TMasterParamsDataLink.DoMasterDisable;
|
|
|
|
begin
|
|
Inherited;
|
|
// If master dataset is closing, leave detail dataset intact (Delphi compatible behavior)
|
|
// If master dataset is reopened, relationship will be reestablished
|
|
end;
|
|
|
|
Procedure TMasterParamsDataLink.DoMasterChange;
|
|
|
|
begin
|
|
Inherited;
|
|
if Assigned(Params) and Assigned(DetailDataset) and DetailDataset.Active then
|
|
begin
|
|
DetailDataSet.CheckBrowseMode;
|
|
DetailDataset.Close;
|
|
DetailDataset.Open;
|
|
end;
|
|
end;
|
|
|
|
{ ---------------------------------------------------------------------
|
|
TDatasource
|
|
---------------------------------------------------------------------}
|
|
|
|
Constructor TDataSource.Create(AOwner: TComponent);
|
|
|
|
begin
|
|
Inherited Create(AOwner);
|
|
FDatalinks := TList.Create;
|
|
FEnabled := True;
|
|
FAutoEdit := True;
|
|
end;
|
|
|
|
|
|
Destructor TDataSource.Destroy;
|
|
|
|
begin
|
|
FOnStateCHange:=Nil;
|
|
Dataset:=Nil;
|
|
With FDataLinks do
|
|
While Count>0 do
|
|
TDatalink(Items[Count - 1]).DataSource:=Nil;
|
|
FDatalinks.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
|
|
Procedure TDatasource.Edit;
|
|
|
|
begin
|
|
If (State=dsBrowse) and AutoEdit Then
|
|
Dataset.Edit;
|
|
end;
|
|
|
|
|
|
Function TDataSource.IsLinkedTo(ADataSet: TDataSet): Boolean;
|
|
|
|
begin
|
|
Result:=False;
|
|
end;
|
|
|
|
|
|
procedure TDatasource.DistributeEvent(Event: TDataEvent; Info: JSValue);
|
|
|
|
|
|
Var
|
|
i : Longint;
|
|
|
|
begin
|
|
With FDatalinks do
|
|
begin
|
|
For I:=0 to Count-1 do
|
|
With TDatalink(Items[i]) do
|
|
If Not VisualControl Then
|
|
DataEvent(Event,Info);
|
|
For I:=0 to Count-1 do
|
|
With TDatalink(Items[i]) do
|
|
If VisualControl Then
|
|
DataEvent(Event,Info);
|
|
end;
|
|
end;
|
|
|
|
procedure TDatasource.RegisterDataLink(DataLink: TDataLink);
|
|
|
|
begin
|
|
FDatalinks.Add(DataLink);
|
|
if Assigned(DataSet) then
|
|
DataSet.RecalcBufListSize;
|
|
end;
|
|
|
|
|
|
procedure TDatasource.SetDataSet(ADataSet: TDataSet);
|
|
begin
|
|
If FDataset<>Nil Then
|
|
Begin
|
|
FDataset.UnRegisterDataSource(Self);
|
|
FDataSet:=nil;
|
|
ProcessEvent(deUpdateState,0);
|
|
End;
|
|
If ADataset<>Nil Then
|
|
begin
|
|
ADataset.RegisterDatasource(Self);
|
|
FDataSet:=ADataset;
|
|
ProcessEvent(deUpdateState,0);
|
|
End;
|
|
end;
|
|
|
|
|
|
procedure TDatasource.SetEnabled(Value: Boolean);
|
|
|
|
begin
|
|
FEnabled:=Value;
|
|
ProcessEvent(deUpdateState,0);
|
|
end;
|
|
|
|
|
|
Procedure TDatasource.DoDataChange (Info : Pointer);
|
|
|
|
begin
|
|
If Assigned(OnDataChange) Then
|
|
OnDataChange(Self,TField(Info));
|
|
end;
|
|
|
|
Procedure TDatasource.DoStateChange;
|
|
|
|
begin
|
|
If Assigned(OnStateChange) Then
|
|
OnStateChange(Self);
|
|
end;
|
|
|
|
|
|
Procedure TDatasource.DoUpdateData;
|
|
|
|
begin
|
|
If Assigned(OnUpdateData) Then
|
|
OnUpdateData(Self);
|
|
end;
|
|
|
|
|
|
procedure TDatasource.UnregisterDataLink(DataLink: TDataLink);
|
|
|
|
begin
|
|
FDatalinks.Remove(Datalink);
|
|
If Dataset<>Nil then
|
|
DataSet.RecalcBufListSize;
|
|
//Dataset.SetBufListSize(DataLink.BufferCount);
|
|
end;
|
|
|
|
|
|
procedure TDataSource.ProcessEvent(Event : TDataEvent; Info : JSValue);
|
|
|
|
Const
|
|
OnDataChangeEvents = [deRecordChange, deDataSetChange, deDataSetScroll,
|
|
deLayoutChange,deUpdateState];
|
|
|
|
Var
|
|
NeedDataChange : Boolean;
|
|
FLastState : TdataSetState;
|
|
|
|
begin
|
|
// Special UpdateState handling.
|
|
If Event=deUpdateState then
|
|
begin
|
|
NeedDataChange:=(FState=dsInactive);
|
|
FLastState:=FState;
|
|
If Assigned(Dataset) and enabled then
|
|
FState:=Dataset.State
|
|
else
|
|
FState:=dsInactive;
|
|
// Don't do events if nothing changed.
|
|
If FState=FLastState then
|
|
exit;
|
|
end
|
|
else
|
|
NeedDataChange:=True;
|
|
DistributeEvent(Event,Info);
|
|
// Extra handlers
|
|
If Not (csDestroying in ComponentState) then
|
|
begin
|
|
If (Event=deUpdateState) then
|
|
DoStateChange;
|
|
If (Event in OnDataChangeEvents) and
|
|
NeedDataChange Then
|
|
DoDataChange(Nil);
|
|
If (Event = deFieldChange) Then
|
|
DoDataCHange(Pointer(Info));
|
|
If (Event=deUpdateRecord) then
|
|
DoUpdateData;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure SkipQuotesString(S : String; var p : integer; QuoteChar : char; EscapeSlash, EscapeRepeat : Boolean);
|
|
|
|
var notRepeatEscaped : boolean;
|
|
begin
|
|
Inc(p);
|
|
repeat
|
|
notRepeatEscaped := True;
|
|
while not CharInSet(S[p],[#0, QuoteChar]) do
|
|
begin
|
|
if EscapeSlash and (S[p]='\') and (P<Length(S)) then
|
|
Inc(p,2) // make sure we handle \' and \\ correct
|
|
else
|
|
Inc(p);
|
|
end;
|
|
if S[p]=QuoteChar then
|
|
begin
|
|
Inc(p); // skip final '
|
|
if (S[p]=QuoteChar) and EscapeRepeat then // Handle escaping by ''
|
|
begin
|
|
notRepeatEscaped := False;
|
|
inc(p);
|
|
end
|
|
end;
|
|
until notRepeatEscaped;
|
|
end;
|
|
|
|
|
|
{ TParams }
|
|
|
|
Function TParams.GetItem(Index: Integer): TParam;
|
|
begin
|
|
Result:=(Inherited GetItem(Index)) as TParam;
|
|
end;
|
|
|
|
Function TParams.GetParamValue(const ParamName: string): JSValue;
|
|
begin
|
|
Result:=ParamByName(ParamName).Value;
|
|
end;
|
|
|
|
Procedure TParams.SetItem(Index: Integer; Value: TParam);
|
|
begin
|
|
Inherited SetItem(Index,Value);
|
|
end;
|
|
|
|
Procedure TParams.SetParamValue(const ParamName: string; const Value: JSValue);
|
|
begin
|
|
ParamByName(ParamName).Value:=Value;
|
|
end;
|
|
|
|
Procedure TParams.AssignTo(Dest: TPersistent);
|
|
begin
|
|
if (Dest is TParams) then
|
|
TParams(Dest).Assign(Self)
|
|
else
|
|
inherited AssignTo(Dest);
|
|
end;
|
|
|
|
Function TParams.GetDataSet: TDataSet;
|
|
begin
|
|
If (FOwner is TDataset) Then
|
|
Result:=TDataset(FOwner)
|
|
else
|
|
Result:=Nil;
|
|
end;
|
|
|
|
Function TParams.GetOwner: TPersistent;
|
|
begin
|
|
Result:=FOwner;
|
|
end;
|
|
|
|
Class Function TParams.ParamClass: TParamClass;
|
|
begin
|
|
Result:=TParam;
|
|
end;
|
|
|
|
Constructor TParams.Create(AOwner: TPersistent; AItemClass: TCollectionItemClass
|
|
);
|
|
begin
|
|
Inherited Create(AItemClass);
|
|
FOwner:=AOwner;
|
|
end;
|
|
|
|
|
|
Constructor TParams.Create(AOwner: TPersistent);
|
|
begin
|
|
Create(AOwner,ParamClass);
|
|
end;
|
|
|
|
Constructor TParams.Create;
|
|
begin
|
|
Create(Nil);
|
|
end;
|
|
|
|
Procedure TParams.AddParam(Value: TParam);
|
|
begin
|
|
Value.Collection:=Self;
|
|
end;
|
|
|
|
Procedure TParams.AssignValues(Value: TParams);
|
|
|
|
Var
|
|
I : Integer;
|
|
P,PS : TParam;
|
|
|
|
begin
|
|
For I:=0 to Value.Count-1 do
|
|
begin
|
|
PS:=Value[i];
|
|
P:=FindParam(PS.Name);
|
|
If Assigned(P) then
|
|
P.Assign(PS);
|
|
end;
|
|
end;
|
|
|
|
Function TParams.CreateParam(FldType: TFieldType; const ParamName: string;
|
|
ParamType: TParamType): TParam;
|
|
|
|
begin
|
|
Result:=Add as TParam;
|
|
Result.Name:=ParamName;
|
|
Result.DataType:=FldType;
|
|
Result.ParamType:=ParamType;
|
|
end;
|
|
|
|
Function TParams.FindParam(const Value: string): TParam;
|
|
|
|
Var
|
|
I : Integer;
|
|
|
|
begin
|
|
Result:=Nil;
|
|
I:=Count-1;
|
|
While (Result=Nil) and (I>=0) do
|
|
If (CompareText(Value,Items[i].Name)=0) then
|
|
Result:=Items[i]
|
|
else
|
|
Dec(i);
|
|
end;
|
|
|
|
Procedure TParams.GetParamList(List: TList; const ParamNames: string);
|
|
|
|
Var
|
|
P: TParam;
|
|
N: String;
|
|
StrPos: Integer;
|
|
|
|
begin
|
|
if (ParamNames = '') or (List = nil) then
|
|
Exit;
|
|
StrPos := 1;
|
|
repeat
|
|
N := ExtractFieldName(ParamNames, StrPos);
|
|
P := ParamByName(N);
|
|
List.Add(P);
|
|
until StrPos > Length(ParamNames);
|
|
end;
|
|
|
|
Function TParams.IsEqual(Value: TParams): Boolean;
|
|
|
|
Var
|
|
I : Integer;
|
|
|
|
begin
|
|
Result:=(Value.Count=Count);
|
|
I:=Count-1;
|
|
While Result and (I>=0) do
|
|
begin
|
|
Result:=Items[I].IsEqual(Value[i]);
|
|
Dec(I);
|
|
end;
|
|
end;
|
|
|
|
Function TParams.ParamByName(const Value: string): TParam;
|
|
begin
|
|
Result:=FindParam(Value);
|
|
If (Result=Nil) then
|
|
DatabaseErrorFmt(SParameterNotFound,[Value],Dataset);
|
|
end;
|
|
|
|
Function TParams.ParseSQL(SQL: String; DoCreate: Boolean): String;
|
|
|
|
var pb : TParamBinding;
|
|
rs : string;
|
|
|
|
begin
|
|
Result := ParseSQL(SQL,DoCreate,True,True,psInterbase, pb, rs);
|
|
end;
|
|
|
|
Function TParams.ParseSQL(SQL: String; DoCreate, EscapeSlash,
|
|
EscapeRepeat: Boolean; ParameterStyle: TParamStyle): String;
|
|
|
|
var pb : TParamBinding;
|
|
rs : string;
|
|
|
|
begin
|
|
Result := ParseSQL(SQL,DoCreate,EscapeSlash,EscapeRepeat,ParameterStyle,pb, rs);
|
|
end;
|
|
|
|
Function TParams.ParseSQL(SQL: String; DoCreate, EscapeSlash,
|
|
EscapeRepeat: Boolean; ParameterStyle: TParamStyle; out
|
|
ParamBinding: TParambinding): String;
|
|
|
|
var rs : string;
|
|
|
|
begin
|
|
Result := ParseSQL(SQL,DoCreate,EscapeSlash, EscapeRepeat, ParameterStyle,ParamBinding, rs);
|
|
end;
|
|
|
|
function SkipComments(S : String; Var p: Integer; EscapeSlash, EscapeRepeat : Boolean) : Boolean;
|
|
|
|
begin
|
|
Result := False;
|
|
case S[P] of
|
|
'''', '"', '`':
|
|
begin
|
|
Result := True;
|
|
// single quote, double quote or backtick delimited string
|
|
SkipQuotesString(S,p, S[p], EscapeSlash, EscapeRepeat);
|
|
end;
|
|
'-': // possible start of -- comment
|
|
begin
|
|
Inc(p);
|
|
if S[p]='-' then // -- comment
|
|
begin
|
|
Result := True;
|
|
repeat // skip until at end of line
|
|
Inc(p);
|
|
until CharInset(S[p],[#10, #13, #0]);
|
|
while CharInSet(S[p],[#10, #13]) do
|
|
Inc(p); // newline is part of comment
|
|
end;
|
|
end;
|
|
'/': // possible start of /* */ comment
|
|
begin
|
|
Inc(p);
|
|
if S[p]='*' then // /* */ comment
|
|
begin
|
|
Result := True;
|
|
Inc(p);
|
|
while p<=Length(S) do
|
|
begin
|
|
if S[p]='*' then // possible end of comment
|
|
begin
|
|
Inc(p);
|
|
if S[p]='/' then Break; // end of comment
|
|
end
|
|
else
|
|
Inc(p);
|
|
end;
|
|
if (P<=Length(s)) and (S[p]='/') then
|
|
Inc(p); // skip final /
|
|
end;
|
|
end;
|
|
end; {case}
|
|
end;
|
|
|
|
Function TParams.ParseSQL(SQL: String; DoCreate, EscapeSlash,
|
|
EscapeRepeat: Boolean; ParameterStyle: TParamStyle; out
|
|
ParamBinding: TParambinding; out ReplaceString: string): String;
|
|
|
|
type
|
|
// used for ParamPart
|
|
TStringPart = record
|
|
Start,Stop:integer;
|
|
end;
|
|
|
|
const
|
|
ParamAllocStepSize = 8;
|
|
PAramDelimiters : Array of char = (';',',',' ','(',')',#13,#10,#9,#0,'=','+','-','*','\','/','[',']','|');
|
|
|
|
var
|
|
IgnorePart:boolean;
|
|
p,ParamNameStart,BufStart:Integer;
|
|
ParamName:string;
|
|
QuestionMarkParamCount,ParameterIndex,NewLength:integer;
|
|
ParamCount:integer; // actual number of parameters encountered so far;
|
|
// always <= Length(ParamPart) = Length(Parambinding)
|
|
// Parambinding will have length ParamCount in the end
|
|
ParamPart:array of TStringPart; // describe which parts of buf are parameters
|
|
NewQueryLength:integer;
|
|
NewQuery:string;
|
|
NewQueryIndex,BufIndex,CopyLen,i:integer; // Parambinding will have length ParamCount in the end
|
|
tmpParam:TParam;
|
|
|
|
begin
|
|
if DoCreate then Clear;
|
|
// Parse the SQL and build ParamBinding
|
|
ParamCount:=0;
|
|
NewQueryLength:=Length(SQL);
|
|
SetLength(ParamPart,ParamAllocStepSize);
|
|
SetLength(ParamBinding,ParamAllocStepSize);
|
|
QuestionMarkParamCount:=0; // number of ? params found in query so far
|
|
|
|
ReplaceString := '$';
|
|
if ParameterStyle = psSimulated then
|
|
while pos(ReplaceString,SQL) > 0 do ReplaceString := ReplaceString+'$';
|
|
|
|
p:=1;
|
|
BufStart:=p; // used to calculate ParamPart.Start values
|
|
repeat
|
|
while SkipComments(SQL,p,EscapeSlash,EscapeRepeat) do ;
|
|
case SQL[p] of
|
|
':','?': // parameter
|
|
begin
|
|
IgnorePart := False;
|
|
if SQL[p]=':' then
|
|
begin // find parameter name
|
|
Inc(p);
|
|
if charInSet(SQL[p],[':','=',' ']) then // ignore ::, since some databases uses this as a cast (wb 4813)
|
|
begin
|
|
IgnorePart := True;
|
|
Inc(p);
|
|
end
|
|
else
|
|
begin
|
|
if (SQL[p]='"') then // Check if the parameter-name is between quotes
|
|
begin
|
|
ParamNameStart:=p;
|
|
SkipQuotesString(SQL,p,'"',EscapeSlash,EscapeRepeat);
|
|
// Do not include the quotes in ParamName, but they must be included
|
|
// when the parameter is replaced by some place-holder.
|
|
ParamName:=Copy(SQL,ParamNameStart+1,p-ParamNameStart-2);
|
|
end
|
|
else
|
|
begin
|
|
ParamNameStart:=p;
|
|
while not CharInSet(SQL[p], ParamDelimiters) do
|
|
Inc(p);
|
|
ParamName:=Copy(SQL,ParamNameStart,p-ParamNameStart);
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
Inc(p);
|
|
ParamNameStart:=p;
|
|
ParamName:='';
|
|
end;
|
|
if not IgnorePart then
|
|
begin
|
|
Inc(ParamCount);
|
|
if ParamCount>Length(ParamPart) then
|
|
begin
|
|
NewLength:=Length(ParamPart)+ParamAllocStepSize;
|
|
SetLength(ParamPart,NewLength);
|
|
SetLength(ParamBinding,NewLength);
|
|
end;
|
|
if DoCreate then
|
|
begin
|
|
// Check if this is the first occurance of the parameter
|
|
tmpParam := FindParam(ParamName);
|
|
// If so, create the parameter and assign the Parameterindex
|
|
if not assigned(tmpParam) then
|
|
ParameterIndex := CreateParam(ftUnknown, ParamName, ptInput).Index
|
|
else // else only assign the ParameterIndex
|
|
ParameterIndex := tmpParam.Index;
|
|
end
|
|
// else find ParameterIndex
|
|
else
|
|
begin
|
|
if ParamName<>'' then
|
|
ParameterIndex:=ParamByName(ParamName).Index
|
|
else
|
|
begin
|
|
ParameterIndex:=QuestionMarkParamCount;
|
|
Inc(QuestionMarkParamCount);
|
|
end;
|
|
end;
|
|
if ParameterStyle in [psPostgreSQL,psSimulated] then
|
|
begin
|
|
i:=ParameterIndex+1;
|
|
repeat
|
|
inc(NewQueryLength);
|
|
i:=i div 10;
|
|
until i=0;
|
|
end;
|
|
// store ParameterIndex in FParamIndex, ParamPart data
|
|
ParamBinding[ParamCount-1]:=ParameterIndex;
|
|
ParamPart[ParamCount-1].Start:=ParamNameStart-BufStart;
|
|
ParamPart[ParamCount-1].Stop:=p-BufStart+1;
|
|
// update NewQueryLength
|
|
Dec(NewQueryLength,p-ParamNameStart);
|
|
end;
|
|
end;
|
|
#0:
|
|
Break; // end of SQL
|
|
else
|
|
Inc(p);
|
|
end;
|
|
until false;
|
|
SetLength(ParamPart,ParamCount);
|
|
SetLength(ParamBinding,ParamCount);
|
|
if ParamCount<=0 then
|
|
NewQuery:=SQL
|
|
else
|
|
begin
|
|
// replace :ParamName by ? for interbase and by $x for postgresql/psSimulated
|
|
// (using ParamPart array and NewQueryLength)
|
|
if (ParameterStyle = psSimulated) and (length(ReplaceString) > 1) then
|
|
inc(NewQueryLength,(paramcount)*(length(ReplaceString)-1));
|
|
|
|
SetLength(NewQuery,NewQueryLength);
|
|
NewQueryIndex:=1;
|
|
BufIndex:=1;
|
|
for i:=0 to High(ParamPart) do
|
|
begin
|
|
CopyLen:=ParamPart[i].Start-BufIndex;
|
|
NewQuery:=NewQuery+Copy(SQL,BufIndex,CopyLen);
|
|
Inc(NewQueryIndex,CopyLen);
|
|
case ParameterStyle of
|
|
psInterbase : begin
|
|
NewQuery:=NewQuery+'?';
|
|
Inc(NewQueryIndex);
|
|
end;
|
|
psPostgreSQL,
|
|
psSimulated : begin
|
|
ParamName := IntToStr(ParamBinding[i]+1);
|
|
NewQuery:=StringOfChar('$',Length(ReplaceString));
|
|
NewQuery:=NewQuery+ParamName;
|
|
end;
|
|
end;
|
|
BufIndex:=ParamPart[i].Stop;
|
|
end;
|
|
CopyLen:=Length(SQL)+1-BufIndex;
|
|
if (CopyLen>0) then
|
|
NewQuery:=NewQuery+Copy(SQL,BufIndex,CopyLen);
|
|
end;
|
|
Result:=NewQuery;
|
|
end;
|
|
|
|
|
|
Procedure TParams.RemoveParam(Value: TParam);
|
|
begin
|
|
Value.Collection:=Nil;
|
|
end;
|
|
|
|
{ TParam }
|
|
|
|
Function TParam.GetDataSet: TDataSet;
|
|
begin
|
|
If Assigned(Collection) and (Collection is TParams) then
|
|
Result:=TParams(Collection).GetDataset
|
|
else
|
|
Result:=Nil;
|
|
end;
|
|
|
|
Function TParam.IsParamStored: Boolean;
|
|
begin
|
|
Result:=Bound;
|
|
end;
|
|
|
|
Procedure TParam.AssignParam(Param: TParam);
|
|
begin
|
|
if Not Assigned(Param) then
|
|
begin
|
|
Clear;
|
|
FDataType:=ftunknown;
|
|
FParamType:=ptUnknown;
|
|
Name:='';
|
|
Size:=0;
|
|
Precision:=0;
|
|
NumericScale:=0;
|
|
end
|
|
else
|
|
begin
|
|
FDataType:=Param.DataType;
|
|
if Param.IsNull then
|
|
Clear
|
|
else
|
|
FValue:=Param.FValue;
|
|
FBound:=Param.Bound;
|
|
Name:=Param.Name;
|
|
if (ParamType=ptUnknown) then
|
|
ParamType:=Param.ParamType;
|
|
Size:=Param.Size;
|
|
Precision:=Param.Precision;
|
|
NumericScale:=Param.NumericScale;
|
|
end;
|
|
end;
|
|
|
|
Procedure TParam.AssignTo(Dest: TPersistent);
|
|
begin
|
|
if (Dest is TField) then
|
|
AssignToField(TField(Dest))
|
|
else
|
|
inherited AssignTo(Dest);
|
|
end;
|
|
|
|
Function TParam.GetAsBoolean: Boolean;
|
|
begin
|
|
If IsNull then
|
|
Result:=False
|
|
else
|
|
Result:=FValue=true;
|
|
end;
|
|
|
|
Function TParam.GetAsBytes: TBytes;
|
|
begin
|
|
if IsNull then
|
|
Result:=nil
|
|
else if isArray(FValue) then
|
|
Result:=TBytes(FValue)
|
|
end;
|
|
|
|
Function TParam.GetAsDateTime: TDateTime;
|
|
begin
|
|
If IsNull then
|
|
Result:=0.0
|
|
else
|
|
Result:=TDateTime(FValue);
|
|
end;
|
|
|
|
Function TParam.GetAsFloat: Double;
|
|
begin
|
|
If IsNull then
|
|
Result:=0.0
|
|
else
|
|
Result:=Double(FValue);
|
|
end;
|
|
|
|
Function TParam.GetAsInteger: Longint;
|
|
begin
|
|
If IsNull or not IsInteger(FValue) then
|
|
Result:=0
|
|
else
|
|
Result:=Integer(FValue);
|
|
end;
|
|
|
|
Function TParam.GetAsLargeInt: NativeInt;
|
|
begin
|
|
If IsNull or not IsInteger(FValue) then
|
|
Result:=0
|
|
else
|
|
Result:=NativeInt(FValue);
|
|
end;
|
|
|
|
|
|
Function TParam.GetAsMemo: string;
|
|
begin
|
|
If IsNull or not IsString(FValue) then
|
|
Result:=''
|
|
else
|
|
Result:=String(FValue);
|
|
end;
|
|
|
|
Function TParam.GetAsString: string;
|
|
|
|
begin
|
|
If IsNull or not IsString(FValue) then
|
|
Result:=''
|
|
else
|
|
Result:=String(FValue);
|
|
end;
|
|
|
|
Function TParam.GetAsJSValue: JSValue;
|
|
begin
|
|
if IsNull then
|
|
Result:=Null
|
|
else
|
|
Result:=FValue;
|
|
end;
|
|
Function TParam.GetDisplayName: string;
|
|
begin
|
|
if (FName<>'') then
|
|
Result:=FName
|
|
else
|
|
Result:=inherited GetDisplayName
|
|
end;
|
|
|
|
Function TParam.GetIsNull: Boolean;
|
|
begin
|
|
Result:= JS.IsNull(FValue);
|
|
end;
|
|
|
|
Function TParam.IsEqual(AValue: TParam): Boolean;
|
|
begin
|
|
Result:=(Name=AValue.Name)
|
|
and (IsNull=AValue.IsNull)
|
|
and (Bound=AValue.Bound)
|
|
and (DataType=AValue.DataType)
|
|
and (ParamType=AValue.ParamType)
|
|
and (GetValueType(FValue)=GetValueType(AValue.FValue))
|
|
and (FValue=AValue.FValue);
|
|
end;
|
|
|
|
Procedure TParam.SetAsBlob(const AValue: TBlobData);
|
|
begin
|
|
FDataType:=ftBlob;
|
|
Value:=AValue;
|
|
end;
|
|
|
|
Procedure TParam.SetAsBoolean(AValue: Boolean);
|
|
begin
|
|
FDataType:=ftBoolean;
|
|
Value:=AValue;
|
|
end;
|
|
|
|
procedure TParam.SetAsBytes(const AValue: TBytes);
|
|
begin
|
|
|
|
end;
|
|
|
|
Procedure TParam.SetAsDate(const AValue: TDateTime);
|
|
begin
|
|
FDataType:=ftDate;
|
|
Value:=AValue;
|
|
end;
|
|
|
|
Procedure TParam.SetAsDateTime(const AValue: TDateTime);
|
|
begin
|
|
FDataType:=ftDateTime;
|
|
Value:=AValue;
|
|
end;
|
|
|
|
Procedure TParam.SetAsFloat(const AValue: Double);
|
|
begin
|
|
FDataType:=ftFloat;
|
|
Value:=AValue;
|
|
end;
|
|
|
|
Procedure TParam.SetAsInteger(AValue: Longint);
|
|
begin
|
|
FDataType:=ftInteger;
|
|
Value:=AValue;
|
|
end;
|
|
|
|
Procedure TParam.SetAsLargeInt(AValue: NativeInt);
|
|
begin
|
|
FDataType:=ftLargeint;
|
|
Value:=AValue;
|
|
end;
|
|
|
|
Procedure TParam.SetAsMemo(const AValue: string);
|
|
begin
|
|
FDataType:=ftMemo;
|
|
Value:=AValue;
|
|
end;
|
|
|
|
Procedure TParam.SetAsString(const AValue: string);
|
|
begin
|
|
if FDataType <> ftFixedChar then
|
|
FDataType := ftString;
|
|
Value:=AValue;
|
|
end;
|
|
|
|
|
|
Procedure TParam.SetAsTime(const AValue: TDateTime);
|
|
begin
|
|
FDataType:=ftTime;
|
|
Value:=AValue;
|
|
end;
|
|
|
|
Procedure TParam.SetAsJSValue(const AValue: JSValue);
|
|
|
|
begin
|
|
FValue:=AValue;
|
|
FBound:=not JS.IsNull(AValue);
|
|
if FBound then
|
|
case GetValueType(aValue) of
|
|
jvtBoolean : FDataType:=ftBoolean;
|
|
jvtInteger : FDataType:=ftInteger;
|
|
jvtFloat : FDataType:=ftFloat;
|
|
jvtObject,jvtArray : FDataType:=ftBlob;
|
|
end;
|
|
end;
|
|
|
|
Procedure TParam.SetDataType(AValue: TFieldType);
|
|
|
|
|
|
begin
|
|
FDataType:=AValue;
|
|
|
|
end;
|
|
|
|
Procedure TParam.SetText(const AValue: string);
|
|
begin
|
|
Value:=AValue;
|
|
end;
|
|
|
|
constructor TParam.Create(ACollection: TCollection);
|
|
begin
|
|
inherited Create(ACollection);
|
|
ParamType:=ptUnknown;
|
|
DataType:=ftUnknown;
|
|
FValue:=Null;
|
|
end;
|
|
|
|
constructor TParam.Create(AParams: TParams; AParamType: TParamType);
|
|
begin
|
|
Create(AParams);
|
|
ParamType:=AParamType;
|
|
end;
|
|
|
|
Procedure TParam.Assign(Source: TPersistent);
|
|
begin
|
|
if (Source is TParam) then
|
|
AssignParam(TParam(Source))
|
|
else if (Source is TField) then
|
|
AssignField(TField(Source))
|
|
else if (source is TStrings) then
|
|
AsMemo:=TStrings(Source).Text
|
|
else
|
|
inherited Assign(Source);
|
|
end;
|
|
|
|
Procedure TParam.AssignField(Field: TField);
|
|
begin
|
|
if Assigned(Field) then
|
|
begin
|
|
// Need TField.Value
|
|
AssignFieldValue(Field,Field.Value);
|
|
Name:=Field.FieldName;
|
|
end
|
|
else
|
|
begin
|
|
Clear;
|
|
Name:='';
|
|
end
|
|
end;
|
|
|
|
Procedure TParam.AssignToField(Field : TField);
|
|
|
|
begin
|
|
if Assigned(Field) then
|
|
case FDataType of
|
|
ftUnknown : DatabaseErrorFmt(SUnknownParamFieldType,[Name],DataSet);
|
|
// Need TField.AsSmallInt
|
|
// Need TField.AsWord
|
|
ftInteger,
|
|
ftAutoInc : Field.AsInteger:=AsInteger;
|
|
ftFloat : Field.AsFloat:=AsFloat;
|
|
ftBoolean : Field.AsBoolean:=AsBoolean;
|
|
ftBlob,
|
|
ftString,
|
|
ftMemo,
|
|
ftFixedChar: Field.AsString:=AsString;
|
|
ftTime,
|
|
ftDate,
|
|
ftDateTime : Field.AsDateTime:=AsDateTime;
|
|
end;
|
|
end;
|
|
|
|
Procedure TParam.AssignFromField(Field : TField);
|
|
|
|
begin
|
|
if Assigned(Field) then
|
|
begin
|
|
FDataType:=Field.DataType;
|
|
case Field.DataType of
|
|
ftUnknown : DatabaseErrorFmt(SUnknownParamFieldType,[Name],DataSet);
|
|
ftInteger,
|
|
ftAutoInc : AsInteger:=Field.AsInteger;
|
|
ftFloat : AsFloat:=Field.AsFloat;
|
|
ftBoolean : AsBoolean:=Field.AsBoolean;
|
|
ftBlob,
|
|
ftString,
|
|
ftMemo,
|
|
ftFixedChar: AsString:=Field.AsString;
|
|
ftTime,
|
|
ftDate,
|
|
ftDateTime : AsDateTime:=Field.AsDateTime;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
Procedure TParam.AssignFieldValue(Field: TField; const AValue: JSValue);
|
|
|
|
begin
|
|
If Assigned(Field) then
|
|
begin
|
|
|
|
if (Field.DataType = ftString) and TStringField(Field).FixedChar then
|
|
FDataType := ftFixedChar
|
|
else if (Field.DataType = ftMemo) and (Field.Size > 255) then
|
|
FDataType := ftString
|
|
else
|
|
FDataType := Field.DataType;
|
|
if JS.IsNull(AValue) then
|
|
Clear
|
|
else
|
|
Value:=AValue;
|
|
|
|
Size:=Field.DataSize;
|
|
FBound:=True;
|
|
|
|
end;
|
|
end;
|
|
|
|
Procedure TParam.Clear;
|
|
begin
|
|
FValue:=Null;
|
|
end;
|
|
|
|
|
|
Procedure TParams.CopyParamValuesFromDataset(ADataSet: TDataSet;
|
|
CopyBound: Boolean);
|
|
|
|
Var
|
|
I : Integer;
|
|
P : TParam;
|
|
F : TField;
|
|
|
|
begin
|
|
If assigned(ADataSet) then
|
|
For I:=0 to Count-1 do
|
|
begin
|
|
P:=Items[i];
|
|
if CopyBound or (not P.Bound) then
|
|
begin
|
|
// Master dataset must be active and unbound parameters must have fields
|
|
// with same names in master dataset (Delphi compatible behavior)
|
|
F:=ADataSet.FieldByName(P.Name);
|
|
P.AssignField(F);
|
|
If Not CopyBound then
|
|
P.Bound:=False;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ TDataSetField }
|
|
|
|
constructor TDataSetField.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
|
|
SetDataType(ftDataSet);
|
|
end;
|
|
|
|
procedure TDataSetField.Bind(Binding: Boolean);
|
|
begin
|
|
inherited;
|
|
if Assigned(FNestedDataSet) then
|
|
if Binding then
|
|
begin
|
|
if FNestedDataSet.State = dsInActive then
|
|
FNestedDataSet.Open;
|
|
end
|
|
else
|
|
FNestedDataSet.Close;
|
|
end;
|
|
|
|
procedure TDataSetField.AssignNestedDataSet(Value: TDataSet);
|
|
begin
|
|
if Assigned(FNestedDataSet) then
|
|
begin
|
|
FNestedDataSet.Close;
|
|
FNestedDataSet.FDataSetField := nil;
|
|
if Assigned(DataSet) then
|
|
DataSet.NestedDataSets.Remove(FNestedDataSet);
|
|
end;
|
|
|
|
if Assigned(Value) then
|
|
DataSet.NestedDataSets.Add(Value);
|
|
|
|
FNestedDataSet := Value;
|
|
end;
|
|
|
|
destructor TDataSetField.Destroy;
|
|
begin
|
|
AssignNestedDataSet(nil);
|
|
|
|
inherited;
|
|
end;
|
|
|
|
end.
|