db.pas

这是不可多得的源代码

{ *************************************************************************** }
{                                                                             }
{ Kylix and Delphi Cross-Platform Visual Component Library                    }
{                                                                             }
{ Copyright (c) 1995, 2001 Borland Software Corporation                       }
{                                                                             }
{ *************************************************************************** }


unit DB;

{$R-,T-,H+,X+}

interface

{$IFDEF MSWINDOWS}
uses Windows, SysUtils, Classes, Variants, MaskUtils, SqlTimSt, FMTBcd;
{$ENDIF}
{$IFDEF LINUX}
uses Libc, SysUtils, Classes, Variants, SqlTimSt, FMTBcd;
{$ENDIF}

type

{ Forward declarations }

  TField = class;
  TObjectField = class;
  TDataLink = class;
  TDataSource = class;
  TDataSet = class;
  TFieldDefs = class;
  TIndexDefs = class;

{ Exception classes }

  EDatabaseError = class(Exception);

{ EUpdateError }

  EUpdateError = class(EDatabaseError)
  private
    FErrorCode: Integer;
    FPreviousError: Integer;
    FContext: string;
    FOriginalException: Exception;
  public
    constructor Create(NativeError, Context: string;
      ErrCode, PrevError: Integer; E: Exception);
    destructor Destroy; override;
    property Context: string read FContext;
    property ErrorCode: Integer read FErrorCode;
    property PreviousError: Integer read FPreviousError;
    property OriginalException: Exception read FOriginalException;
  end;

{ Misc DataSet types }

  TFieldType = (ftUnknown, ftString, ftSmallint, ftInteger, ftWord,
    ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime,
    ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo,
    ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, ftWideString,
    ftLargeint, ftADT, ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob,
    ftVariant, ftInterface, ftIDispatch, ftGuid, ftTimeStamp, ftFMTBcd);

  TDataSetState = (dsInactive, dsBrowse, dsEdit, dsInsert, dsSetKey,
    dsCalcFields, dsFilter, dsNewValue, dsOldValue, dsCurValue, dsBlockRead,
    dsInternalCalc, dsOpening);

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

  TUpdateStatus = (usUnmodified, usModified, usInserted, usDeleted);
  TUpdateStatusSet = set of TUpdateStatus;

  TUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApplied);

  TUpdateRecordTypes = set of (rtModified, rtInserted, rtDeleted, rtUnmodified);

  TUpdateMode = (upWhereAll, upWhereChanged, upWhereKeyOnly);

  TUpdateKind = (ukModify, ukInsert, ukDelete);

  TUpdateErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError;
    UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction) of object;

  TUpdateRecordEvent = procedure(DataSet: TDataSet; UpdateKind: TUpdateKind;
    var UpdateAction: TUpdateAction) of object;

{ TCustomConnection }

  TLoginEvent = procedure(Sender: TObject; Username, Password: string) of object;
  TConnectChangeEvent = procedure(Sender: TObject; Connecting: Boolean) of object;

  TCustomConnection = class(TComponent)
  private
    FClients: TList;
    FDataSets: TList;
    FConnectEvents: TList;
    FLoginPrompt: Boolean;
    FStreamedConnected: Boolean;
    FAfterConnect: TNotifyEvent;
    FAfterDisconnect: TNotifyEvent;
    FBeforeConnect: TNotifyEvent;
    FBeforeDisconnect: TNotifyEvent;
    FOnLogin: TLoginEvent;
  protected
    procedure DoConnect; virtual;
    procedure DoDisconnect; virtual;
    function GetConnected: Boolean; virtual;
    function GetDataSet(Index: Integer): TDataSet; virtual;
    function GetDataSetCount: Integer; virtual;
    procedure Loaded; override;
    procedure RegisterClient(Client: TObject; Event: TConnectChangeEvent = nil); virtual;
    procedure SetConnected(Value: Boolean); virtual;
    procedure SendConnectEvent(Connecting: Boolean);
    property StreamedConnected: Boolean read FStreamedConnected write FStreamedConnected;
    procedure UnRegisterClient(Client: TObject); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Open; overload;
    procedure Close;
    property Connected: Boolean read GetConnected write SetConnected default False;
    property DataSets[Index: Integer]: TDataSet read GetDataSet;
    property DataSetCount: Integer read GetDataSetCount;
    property LoginPrompt: Boolean read FLoginPrompt write FLoginPrompt default False;
    property AfterConnect: TNotifyEvent read FAfterConnect write FAfterConnect;
    property BeforeConnect: TNotifyEvent read FBeforeConnect write FBeforeConnect;
    property AfterDisconnect: TNotifyEvent read FAfterDisconnect write FAfterDisconnect;
    property BeforeDisconnect: TNotifyEvent read FBeforeDisconnect write FBeforeDisconnect;
    property OnLogin: TLoginEvent read FOnLogin write FOnLogin;
  end;

{ TNamedItem }

  TNamedItem = class(TCollectionItem)
  private
    FName: string;
  protected
    function GetDisplayName: string; override;
    procedure SetDisplayName(const Value: string); override;
  published
    property Name: string read FName write SetDisplayName;
  end;

{ TDefCollection }

  TDefUpdateMethod = procedure of object;

  TDefCollection = class(TOwnedCollection)
  private
    FDataSet: TDataSet;
    FUpdated: Boolean;
    FOnUpdate: TNotifyEvent;
    FInternalUpdateCount: Integer;
  protected
    procedure DoUpdate(Sender: TObject);
    procedure SetItemName(AItem: TCollectionItem); override;
    procedure Update(AItem: TCollectionItem); override;
    procedure UpdateDefs(AMethod: TDefUpdateMethod);
    property OnUpdate: TNotifyEvent read FOnUpdate write FOnUpdate;
  public
    constructor Create(ADataSet: TDataSet; AOwner: TPersistent;
      AClass: TCollectionItemClass);
    function Find(const AName: string): TNamedItem;
    procedure GetItemNames(List: TStrings);
    function IndexOf(const AName: string): Integer;
    property DataSet: TDataSet read FDataSet;
    property Updated: Boolean read FUpdated write FUpdated;
  end;

{ TFieldDef }

  TFieldClass = class of TField;

  TFieldAttribute = (faHiddenCol, faReadonly, faRequired, faLink, faUnNamed, faFixed);
  TFieldAttributes = set of TFieldAttribute;

  TFieldDef = class(TNamedItem)
  private
    FChildDefs: TFieldDefs;
    FPrecision: Integer;
    FFieldNo: Integer;
    FSize: Integer;
    FInternalCalcField: Boolean;
    FDataType: TFieldType;
    FAttributes: TFieldAttributes;
    function CreateFieldComponent(Owner: TComponent;
      ParentField: TObjectField = nil; FieldName: string = ''): TField;
    function GetChildDefs: TFieldDefs;
    function GetFieldClass: TFieldClass;
    function GetFieldNo: Integer;
    function GetParentDef: TFieldDef;
    function GetRequired: Boolean;
    function GetSize: Integer;
    procedure ReadRequired(Reader: TReader);
    procedure SetAttributes(Value: TFieldAttributes);
    procedure SetChildDefs(Value: TFieldDefs);
    procedure SetDataType(Value: TFieldType);
    procedure SetPrecision(Value: Integer);
    procedure SetRequired(Value: Boolean);
    procedure SetSize(Value: Integer);
  protected
    procedure DefineProperties(Filer: TFiler); override;
  public
    constructor Create(Owner: TFieldDefs; const Name: string;
      DataType: TFieldType; Size: Integer; Required: Boolean; FieldNo: Integer); reintroduce; overload;
    destructor Destroy; override;
    function AddChild: TFieldDef;
    procedure Assign(Source: TPersistent); override;
    function CreateField(Owner: TComponent; ParentField: TObjectField = nil;
      const FieldName: string = ''; CreateChildren: Boolean = True): TField;
    function HasChildDefs: Boolean;
    property FieldClass: TFieldClass read GetFieldClass;
    property FieldNo: Integer read GetFieldNo write FFieldNo stored False;
    property InternalCalcField: Boolean read FInternalCalcField write FInternalCalcField;
    property ParentDef: TFieldDef read GetParentDef;
    property Required: Boolean read GetRequired write SetRequired;
  published
    property Attributes: TFieldAttributes read FAttributes write SetAttributes default [];
    property ChildDefs: TFieldDefs read GetChildDefs write SetChildDefs stored HasChildDefs;
    property DataType: TFieldType read FDataType write SetDataType default ftUnknown;
    property Precision: Integer read FPrecision write SetPrecision default 0;
    property Size: Integer read GetSize write SetSize default 0;
  end;

{ TFieldDefs }

  TFieldDefs = class(TDefCollection)
  private
    FParentDef: TFieldDef;
    FHiddenFields: Boolean;
    function GetFieldDef(Index: Integer): TFieldDef;
    procedure SetFieldDef(Index: Integer; Value: TFieldDef);
    procedure SetHiddenFields(Value: Boolean);
  protected
    procedure FieldDefUpdate(Sender: TObject);
    procedure ChildDefUpdate(Sender: TObject);
    procedure SetItemName(AItem: TCollectionItem); override;
  public
    constructor Create(AOwner: TPersistent);
    function AddFieldDef: TFieldDef;
    function Find(const Name: string): TFieldDef;
    procedure Update; reintroduce;
    { procedure Add kept for compatability - AddFieldDef is the better way }
    procedure Add(const Name: string; DataType: TFieldType; Size: Integer = 0;
      Required: Boolean = False);
    property HiddenFields: Boolean read FHiddenFields write SetHiddenFields;
    property Items[Index: Integer]: TFieldDef read GetFieldDef write SetFieldDef; default;
    property ParentDef: TFieldDef read FParentDef;
  end;

{ TIndexDef }

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

  TIndexDef = class(TNamedItem)
  private
    FSource: string;
    FFieldExpression: string;
    FDescFields: string;
    FCaseInsFields: string;
    FOptions: TIndexOptions;
    FGroupingLevel: Integer;
    function GetExpression: string;
    function GetFields: string;
    procedure SetDescFields(const Value: string);
    procedure SetCaseInsFields(const Value: string);
    procedure SetExpression(const Value: string);
    procedure SetFields(const Value: string);
    procedure SetOptions(Value: TIndexOptions);
    procedure SetSource(const Value: string);
  protected
    function GetDisplayName: string; override;
  public
    constructor Create(Owner: TIndexDefs; const Name, Fields: string;
      Options: TIndexOptions); reintroduce; overload;
    procedure Assign(ASource: TPersistent); override;
    property FieldExpression: string read FFieldExpression;
  published
    property CaseInsFields: string read FCaseInsFields write SetCaseInsFields;
    property DescFields: string read FDescFields write SetDescFields;
    property Expression: string read GetExpression write SetExpression;
    property Fields: string read GetFields write SetFields;
    property Options: TIndexOptions read FOptions write SetOptions default [];
    property Source: string read FSource write SetSource;
    property GroupingLevel: Integer read FGroupingLevel write FGroupingLevel default 0;
  end;

{ TIndexDefs }

  TIndexDefs = class(TDefCollection)
  private
    function GetIndexDef(Index: Integer): TIndexDef;
    procedure SetIndexDef(Index: Integer; Value: TIndexDef);
  public
    constructor Create(ADataSet: TDataSet);
    function AddIndexDef: TIndexDef;
    function Find(const Name: string): TIndexDef;
    procedure Update; reintroduce;
    function FindIndexForFields(const Fields: string): TIndexDef;
    function GetIndexForFields(const Fields: string;
      CaseInsensitive: Boolean): TIndexDef;
    { procedure Add kept for compatability - AddIndexDef is the better way }
    procedure Add(const Name, Fields: string; Options: TIndexOptions);
    property Items[Index: Integer]: TIndexDef read GetIndexDef write SetIndexDef; default;
  end;

{ TFlatList }

  TFlatList = class(TStringList)
  private
    FDataSet: TDataSet;
    FLocked: Boolean;
    FUpdated: Boolean;
  protected
    procedure ListChanging(Sender: TObject);
    function FindItem(const Name: string; MustExist: Boolean): TObject;
    function GetCount: Integer; override;
    function GetUpdated: Boolean; virtual;
    procedure UpdateList; virtual; abstract;
    property Updated: Boolean read GetUpdated write FUpdated;
    property Locked: Boolean read FLocked write FLocked;
  public
    constructor Create(ADataSet: TDataSet);
    procedure Update;
    property DataSet: TDataSet read FDataSet;
  end;