db.pas

这是不可多得的源代码

{ TFieldDefList }

  TFieldDefList = class(TFlatList)
  private
    function GetFieldDef(Index: Integer): TFieldDef;
  protected
    function GetUpdated: Boolean; override;
    procedure UpdateList; override;
  public
    function FieldByName(const Name: string): TFieldDef;
    function Find(const Name: string): TFieldDef; reintroduce;
    property FieldDefs[Index: Integer]: TFieldDef read GetFieldDef; default;
  end;

{ TFieldList }

  TFieldList = class(TFlatList)
  private
    function GetField(Index: Integer): TField;
  protected
    procedure UpdateList; override;
  public
    function FieldByName(const Name: string): TField;
    function Find(const Name: string): TField; reintroduce;
    property Fields[Index: Integer]: TField read GetField; default;
  end;

{ TFields }

  TFieldKind = (fkData, fkCalculated, fkLookup, fkInternalCalc, fkAggregate);
  TFieldKinds = set of TFieldKind;

  TFields = class(TObject)
  private
    FList: TList;
    FDataSet: TDataSet;
    FSparseFields: Integer;
    FOnChange: TNotifyEvent;
    FValidFieldKinds: TFieldKinds;
  protected
    procedure Changed;
    procedure CheckFieldKind(FieldKind: TFieldKind; Field: TField);
    function GetCount: Integer;
    function GetField(Index: Integer): TField;
    procedure SetField(Index: Integer; Value: TField);
    procedure SetFieldIndex(Field: TField; Value: Integer);
    property SparseFields: Integer read FSparseFields write FSparseFields;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property ValidFieldKinds: TFieldKinds read FValidFieldKinds write FValidFieldKinds;
  public
    constructor Create(ADataSet: TDataSet);
    destructor Destroy; override;
    procedure Add(Field: TField);
    procedure CheckFieldName(const FieldName: string);
    procedure CheckFieldNames(const FieldNames: string);
    procedure Clear;
    function FindField(const FieldName: string): TField;
    function FieldByName(const FieldName: string): TField;
    function FieldByNumber(FieldNo: Integer): TField;
    procedure GetFieldNames(List: TStrings);
    function IndexOf(Field: TField): Integer;
    procedure Remove(Field: TField);
    property Count: Integer read GetCount;
    property DataSet: TDataSet read FDataSet;
    property Fields[Index: Integer]: TField read GetField write SetField; default;
  end;

{ TField }

  TProviderFlag = (pfInUpdate, pfInWhere, pfInKey, pfHidden);
  TProviderFlags = set of TProviderFlag;

  TFieldNotifyEvent = procedure(Sender: TField) of object;
  TFieldGetTextEvent = procedure(Sender: TField; var Text: string;
    DisplayText: Boolean) of object;
  TFieldSetTextEvent = procedure(Sender: TField; const Text: string) of object;
  TFieldRef = ^TField;
  TFieldChars = set of Char;
  TAutoRefreshFlag = (arNone, arAutoInc, arDefault);

  PLookupListEntry = ^TLookupListEntry;
  TLookupListEntry = record
    Key: Variant;
    Value: Variant;
  end;

  TLookupList = class(TObject)
  private
    FList: TList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(const AKey, AValue: Variant);
    procedure Clear;
    function ValueOfKey(const AKey: Variant): Variant;
  end;

  TField = class(TComponent)
  private
    FAutoGenerateValue: TAutoRefreshFlag;
    FDataSet: TDataSet;
    FFieldName: string;
    FFields: TFields;
    FDataType: TFieldType;
    FReadOnly: Boolean;
    FFieldKind: TFieldKind;
    FAlignment: TAlignment;
    FVisible: Boolean;
    FRequired: Boolean;
    FValidating: Boolean;
    FSize: Integer;
    FOffset: Integer;
    FFieldNo: Integer;
    FDisplayWidth: Integer;
    FDisplayLabel: string;
{$IFDEF MSWINDOWS}
    FEditMask: TEditMask;
{$ENDIF}
{$IFDEF LINUX}
    FEditMask: string;
{$ENDIF}
    FValueBuffer: Pointer;
    FLookupDataSet: TDataSet;
    FKeyFields: string;
    FLookupKeyFields: string;
    FLookupResultField: string;
    FLookupCache: Boolean;
    FLookupList: TLookupList;
    FAttributeSet: string;
    FCustomConstraint: string;
    FImportedConstraint: string;
    FConstraintErrorMessage: string;
    FDefaultExpression: string;
    FOrigin: string;
    FProviderFlags: TProviderFlags;
    FParentField: TObjectField;
    FValidChars: TFieldChars;
    FOnChange: TFieldNotifyEvent;
    FOnValidate: TFieldNotifyEvent;
    FOnGetText: TFieldGetTextEvent;
    FOnSetText: TFieldSetTextEvent;
    procedure CalcLookupValue;
    function GetCalculated: Boolean;
    function GetDisplayLabel: string;
    function GetDisplayName: string;
    function GetDisplayText: string;
    function GetDisplayWidth: Integer;
    function GetEditText: string;
    function GetFullName: string;
    function GetIndex: Integer;
    function GetIsIndexField: Boolean;
    function GetLookup: Boolean;
    function GetLookupList: TLookupList;
    function GetCurValue: Variant;
    function GetNewValue: Variant;
    function GetOldValue: Variant;
    function IsDisplayLabelStored: Boolean;
    function IsDisplayWidthStored: Boolean;
    procedure ReadAttributeSet(Reader: TReader);
    procedure ReadCalculated(Reader: TReader);
    procedure ReadLookup(Reader: TReader);
    procedure SetAlignment(Value: TAlignment);
    procedure SetCalculated(Value: Boolean);
    procedure SetDisplayLabel(Value: string);
    procedure SetDisplayWidth(Value: Integer);
{$IFDEF MSWINDOWS}
    procedure SetEditMask(const Value: TEditMask);
{$ENDIF}
{$IFDEF LINUX}
    procedure SetEditMask(const Value: string);
{$ENDIF}
    procedure SetEditText(const Value: string);
    procedure SetFieldName(const Value: string);
    procedure SetIndex(Value: Integer);
    procedure SetLookup(Value: Boolean);
    procedure SetLookupDataSet(Value: TDataSet);
    procedure SetLookupKeyFields(const Value: string);
    procedure SetLookupResultField(const Value: string);
    procedure SetKeyFields(const Value: string);
    procedure SetLookupCache(const Value: Boolean);
    procedure SetNewValue(const Value: Variant);
    procedure SetReadOnly(const Value: Boolean);
    procedure SetVisible(Value: Boolean);
    procedure ValidateLookupInfo(All: Boolean);
    procedure WriteAttributeSet(Writer: TWriter);
    procedure WriteCalculated(Writer: TWriter);
    procedure WriteLookup(Writer: TWriter);
  protected
    function AccessError(const TypeName: string): EDatabaseError; dynamic;
    procedure Bind(Binding: Boolean); virtual;
    procedure CheckInactive;
    class procedure CheckTypeSize(Value: Integer); virtual;
    procedure Change; virtual;
    procedure DataChanged;
    procedure DefineProperties(Filer: TFiler); override;
    procedure FreeBuffers; virtual;
    function GetAsBCD: TBcd; virtual;
    function GetAsBoolean: Boolean; virtual;
    function GetAsByteArray: Variant; virtual;
    function GetAsCurrency: Currency; virtual;
    function GetAsDateTime: TDateTime; virtual;
    function GetAsFloat: Double; virtual;
    function GetAsInteger: Longint; virtual;
    function GetAsSqlTimeStamp: TSQLTimeStamp; virtual;
    function GetAsString: string; virtual;
    function GetAsVariant: Variant; virtual;
    function GetCanModify: Boolean; virtual;
    function GetClassDesc: string; virtual;
    function GetDataSize: Integer; virtual;
    procedure CopyData(Source, Dest: Pointer); virtual;
    function GetDefaultWidth: Integer; virtual;
    function GetFieldNo: Integer; virtual;
    function GetHasConstraints: Boolean; virtual;
    function GetIsNull: Boolean; virtual;
    function GetSize: Integer; virtual;
    procedure GetText(var Text: string; DisplayText: Boolean); virtual;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    procedure PropertyChanged(LayoutAffected: Boolean);
    procedure ReadState(Reader: TReader); override;
    procedure SetAsBCD(const Value: TBcd); virtual;
    procedure SetAsBoolean(Value: Boolean); virtual;
    procedure SetAsByteArray(const Value: Variant); virtual;
    procedure SetAsCurrency(Value: Currency); virtual;
    procedure SetAsDateTime(Value: TDateTime); virtual;
    procedure SetAsFloat(Value: Double); virtual;
    procedure SetAsInteger(Value: Longint); virtual;
    procedure SetAsSQLTimeStamp(const Value: TSQLTimeStamp); virtual;
    procedure SetAsString(const Value: string); virtual;
    procedure SetAsVariant(const Value: Variant); virtual;
    procedure SetDataSet(ADataSet: TDataSet); virtual;
    procedure SetDataType(Value: TFieldType);
    procedure SetFieldKind(Value: TFieldKind); virtual;
    procedure SetParentComponent(AParent: TComponent); override;
    procedure SetParentField(AField: TObjectField); virtual;
    procedure SetSize(Value: Integer); virtual;
    procedure SetText(const Value: string); virtual;
    procedure SetVarValue(const Value: Variant); virtual;
    procedure SetAutoGenerateValue(const Value: TAutoRefreshFlag);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure AssignValue(const Value: TVarRec);
    procedure Clear; virtual;
    procedure FocusControl;
    function GetData(Buffer: Pointer; NativeFormat: Boolean = True): Boolean;
    function GetParentComponent: TComponent; override;
    function HasParent: Boolean; override;
    class function IsBlob: Boolean; virtual;
    function IsValidChar(InputChar: Char): Boolean; virtual;
    procedure RefreshLookupList;
    procedure SetData(Buffer: Pointer; NativeFormat: Boolean = True);
    procedure SetFieldType(Value: TFieldType); virtual;
    procedure Validate(Buffer: Pointer);
    property AsBCD: TBcd read GetAsBCD write SetAsBCD;
    property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;
    property AsCurrency: Currency read GetAsCurrency write SetAsCurrency;
    property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
    property AsSQLTimeStamp: TSQLTimeStamp read GetAsSQLTimeStamp write SetAsSQLTimeStamp;
    property AsFloat: Double read GetAsFloat write SetAsFloat;
    property AsInteger: Longint read GetAsInteger write SetAsInteger;
    property AsString: string read GetAsString write SetAsString;
    property AsVariant: Variant read GetAsVariant write SetAsVariant;
    property AttributeSet: string read FAttributeSet write FAttributeSet;
    property Calculated: Boolean read GetCalculated write SetCalculated default False;
    property CanModify: Boolean read GetCanModify;
    property CurValue: Variant read GetCurValue;
    property DataSet: TDataSet read FDataSet write SetDataSet stored False;
    property DataSize: Integer read GetDataSize;
    property DataType: TFieldType read FDataType;
    property DisplayName: string read GetDisplayName;
    property DisplayText: string read GetDisplayText;
{$IFDEF MSWINDOWS}
    property EditMask: TEditMask read FEditMask write SetEditMask;
    property EditMaskPtr: TEditMask read FEditMask;
{$ENDIF}
{$IFDEF LINUX}
    property EditMask: string read FEditMask write SetEditMask;
    property EditMaskPtr: string read FEditMask;
{$ENDIF}
    property FieldNo: Integer read GetFieldNo;
    property FullName: string read GetFullName;
    property IsIndexField: Boolean read GetIsIndexField;
    property IsNull: Boolean read GetIsNull;
    property Lookup: Boolean read GetLookup write SetLookup;
    property LookupList: TLookupList read GetLookupList;
    property NewValue: Variant read GetNewValue write SetNewValue;
    property Offset: Integer read FOffset;
    property OldValue: Variant read GetOldValue;
    property ParentField: TObjectField read FParentField write SetParentField;
    property Size: Integer read GetSize write SetSize;
    property Text: string read GetEditText write SetEditText;
    property ValidChars: TFieldChars read FValidChars write FValidChars;
    property Value: Variant read GetAsVariant write SetAsVariant;
  published
    property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
    property AutoGenerateValue: TAutoRefreshFlag read FAutoGenerateValue write SetAutoGenerateValue default arNone;
    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 GetDisplayLabel write SetDisplayLabel
      stored IsDisplayLabelStored;
    property DisplayWidth: Integer read GetDisplayWidth write SetDisplayWidth
      stored IsDisplayWidthStored;
    property FieldKind: TFieldKind read FFieldKind write SetFieldKind default fkData;
    property FieldName: string read FFieldName write SetFieldName;
    property HasConstraints: Boolean read GetHasConstraints default False;
    property Index: Integer read GetIndex write SetIndex stored False;
    property ImportedConstraint: string read FImportedConstraint write FImportedConstraint;
    property LookupDataSet: TDataSet read FLookupDataSet write SetLookupDataSet;
    property LookupKeyFields: string read FLookupKeyFields write SetLookupKeyFields;
    property LookupResultField: string read FLookupResultField write SetLookupResultField;
    property KeyFields: string read FKeyFields write SetKeyFields;
    property LookupCache: Boolean read FLookupCache write SetLookupCache default False;
    property Origin: string read FOrigin write FOrigin;
    property ProviderFlags: TProviderFlags read FProviderFlags write FProviderFlags default [pfInWhere, pfInUpdate];
    property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
    property Required: Boolean read FRequired write FRequired default False;
    property Visible: Boolean read FVisible write SetVisible default True;
    property OnChange: TFieldNotifyEvent read FOnChange write FOnChange;
    property OnGetText: TFieldGetTextEvent read FOnGetText write FOnGetText;
    property OnSetText: TFieldSetTextEvent read FOnSetText write FOnSetText;
    property OnValidate: TFieldNotifyEvent read FOnValidate write FOnValidate;
  end;

{ TStringField }

  TStringField = class(TField)
  private
    FFixedChar: Boolean;
    FTransliterate: Boolean;
  protected