dbtables.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

    property BeforeInsert;
    property AfterInsert;
    property BeforeEdit;
    property AfterEdit;
    property BeforePost;
    property AfterPost;
    property BeforeCancel;
    property AfterCancel;
    property BeforeDelete;
    property AfterDelete;
    property BeforeScroll;
    property AfterScroll;
    property BeforeRefresh;
    property AfterRefresh;
    property OnCalcFields;
    property OnDeleteError;
    property OnEditError;
    property OnNewRecord;
    property OnPostError;
    property OnUpdateError: TUpdateErrorEvent read FOnUpdateError write SetOnUpdateError;
    property OnUpdateRecord: TUpdateRecordEvent read FOnUpdateRecord write FOnUpdateRecord;
  end;

{ TNestedTable }

  TNestedTable = class(TBDEDataSet)
  protected
    function CreateHandle: HDBICur; override;
    procedure DoAfterPost; override;
    procedure DoBeforeInsert; override;
    procedure InternalPost; override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property DataSetField;
    property ObjectView default True;
  end;

{ TDBDataSet }

  TDBFlags = set of 0..15;

  TDBDataSet = class(TBDEDataSet)
  private
    FAutoRefresh: Boolean;
    FDBFlags: TDBFlags;
    FUpdateMode: TUpdateMode;
    FDatabase: TDatabase;
    FDatabaseName: string;
    FSessionName: string;
    procedure CheckDBSessionName;
    function GetDBHandle: HDBIDB;
    function GetDBLocale: TLocale;
    function GetDBSession: TSession;
    procedure SetDatabaseName(const Value: string);
    procedure SetSessionName(const Value: string);
    procedure SetUpdateMode(const Value: TUpdateMode);
    procedure SetAutoRefresh(const Value: Boolean);
    procedure SetupAutoRefresh;
  protected
    { IProviderSupport }
    procedure PSEndTransaction(Commit: Boolean); override;
    function PSExecuteStatement(const ASQL: string; AParams: TParams;
      ResultSet: Pointer = nil): Integer; override;
    procedure PSGetAttributes(List: TList); override;
    function PSGetQuoteChar: string; override;
    function PSInTransaction: Boolean; override;
    function PSIsSQLBased: Boolean; override;
    procedure PSStartTransaction; override;
    function PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean; override;
  protected
    procedure CloseCursor; override;
    function ConstraintsStored: Boolean;
    procedure Disconnect; virtual;
    procedure OpenCursor(InfoQuery: Boolean); override;
    function SetDBFlag(Flag: Integer; Value: Boolean): Boolean; virtual;
    procedure SetHandle(Value: HDBICur);
    property DBFlags: TDBFlags read FDBFlags;
    property UpdateMode: TUpdateMode read FUpdateMode write SetUpdateMode default upWhereAll;
  public
    constructor Create(AOwner: TComponent); override;
    function CheckOpen(Status: DBIResult): Boolean;
    procedure CloseDatabase(Database: TDatabase);
    function OpenDatabase: TDatabase;
    property Database: TDatabase read FDatabase;
    property DBHandle: HDBIDB read GetDBHandle;
    property DBLocale: TLocale read GetDBLocale;
    property DBSession: TSession read GetDBSession;
    property Handle: HDBICur read GetHandle write SetHandle;
  published
    property AutoRefresh: Boolean read FAutoRefresh write SetAutoRefresh default False;
    property DatabaseName: string read FDatabaseName write SetDatabaseName;
    property Filter;
    property Filtered;
    property FilterOptions;
    property SessionName: string read FSessionName write SetSessionName;
    property OnFilterRecord;
  end;

{ TTable }

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

  TIndexDescList = array of IDXDesc;

  TValCheckList = array of VCHKDesc;

  TIndexFiles = class(TStringList)
  private
    FOwner: TTable;
  public
    constructor Create(AOwner: TTable);
    function Add(const S: string): Integer; override;
    procedure Clear; override;
    procedure Delete(Index: Integer); override;
    procedure Insert(Index: Integer; const S: string); override;
  end;

  TTable = class(TDBDataSet)
  private
    FStoreDefs: Boolean;
    FIndexDefs: TIndexDefs;
    FMasterLink: TMasterDataLink;
    FDefaultIndex: Boolean;
    FExclusive: Boolean;
    FReadOnly: Boolean;
    FTableType: TTableType;
    FFieldsIndex: Boolean;
    FTableName: TFileName;
    FIndexName: TIndexName;
    FIndexFiles: TStrings;
    FLookupHandle: HDBICur;
    FLookupKeyFields: string;
    FTableLevel: Integer;
    FLookupCaseIns: Boolean;
    FNativeTableName: DBITBLNAME;
    procedure CheckMasterRange;
    procedure DecodeIndexDesc(const IndexDesc: IDXDesc;
      var Source, Name, FieldExpression, DescFields: string;
      var Options: TIndexOptions);
    function FieldDefsStored: Boolean;
    function GetDriverTypeName(Buffer: PChar): PChar;
    function GetExists: Boolean;
    function GetIndexFieldNames: string;
    function GetIndexName: string;
    procedure GetIndexParams(const IndexName: string; FieldsIndex: Boolean;
      var IndexedName, IndexTag: string);
    function GetMasterFields: string;
    function GetTableTypeName: PChar;
    function GetTableLevel: Integer;
    function IndexDefsStored: Boolean;
    function IsXBaseTable: Boolean;
    procedure MasterChanged(Sender: TObject);
    procedure MasterDisabled(Sender: TObject);
    procedure SetDataSource(Value: TDataSource);
    procedure SetExclusive(Value: Boolean);
    procedure SetIndexDefs(Value: TIndexDefs);
    procedure SetIndex(const Value: string; FieldsIndex: Boolean);
    procedure SetIndexFieldNames(const Value: string);
    procedure SetIndexFiles(Value: TStrings);
    procedure SetIndexName(const Value: string);
    procedure SetMasterFields(const Value: string);
    procedure SetReadOnly(Value: Boolean);
    procedure SetTableLock(LockType: TLockType; Lock: Boolean);
    procedure SetTableName(const Value: TFileName);
    procedure SetTableType(Value: TTableType);
    function SetTempLocale(ActiveCheck: Boolean): TLocale;
    procedure RestoreLocale(LocaleSave: TLocale);
    procedure UpdateRange;
  protected
    { IProviderSupport }
    function PSGetDefaultOrder: TIndexDef; override;
    function PSGetKeyFields: string; override;
    function PSGetTableName: string; override;
    function PSGetIndexDefs(IndexTypes: TIndexOptions): TIndexDefs; override;
    procedure PSSetCommandText(const CommandText: string); override;
    procedure PSSetParams(AParams: TParams); override;
  protected
    function CreateHandle: HDBICur; override;
    procedure DataEvent(Event: TDataEvent; Info: Longint); override;
    procedure DefChanged(Sender: TObject); override;
    procedure DestroyHandle; override;
    procedure DestroyLookupCursor; override;
    procedure DoOnNewRecord; override;
    procedure EncodeFieldDesc(var FieldDesc: FLDDesc;
      const Name: string; DataType: TFieldType; Size, Precision: Integer);
    procedure EncodeIndexDesc(var IndexDesc: IDXDesc;
      const Name, FieldExpression: string; Options: TIndexOptions;
      const DescFields: string = '');
    function GetCanModify: Boolean; override;
    function GetDataSource: TDataSource; override;
    function GetHandle(const IndexName, IndexTag: string): HDBICur;
    function GetLanguageDriverName: string;
    function GetLookupCursor(const KeyFields: string;
      CaseInsensitive: Boolean): HDBICur; override;
    procedure InitFieldDefs; override;
    function GetFileName: string;
    function GetTableType: TTableType;
    function IsProductionIndex(const IndexName: string): Boolean;
    function NativeTableName: PChar;
    procedure PrepareCursor; override;
    procedure UpdateIndexDefs; override;
    property MasterLink: TMasterDataLink read FMasterLink;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function BatchMove(ASource: TBDEDataSet; AMode: TBatchMode): Longint;
    procedure AddIndex(const Name, Fields: string; Options: TIndexOptions;
      const DescFields: string = '');
    procedure ApplyRange;
    procedure CancelRange;
    procedure CloseIndexFile(const IndexFileName: string);
    procedure CreateTable;
    procedure DeleteIndex(const Name: string);
    procedure DeleteTable;
    procedure EditKey;
    procedure EditRangeEnd;
    procedure EditRangeStart;
    procedure EmptyTable;
    function FindKey(const KeyValues: array of const): Boolean;
    procedure FindNearest(const KeyValues: array of const);
    procedure GetDetailLinkFields(MasterFields, DetailFields: TList); override;
    procedure GetIndexNames(List: TStrings);
    procedure GotoCurrent(Table: TTable);
    function GotoKey: Boolean;
    procedure GotoNearest;
    procedure LockTable(LockType: TLockType);
    procedure OpenIndexFile(const IndexName: string);
    procedure RenameTable(const NewTableName: string);
    procedure SetKey;
    procedure SetRange(const StartValues, EndValues: array of const);
    procedure SetRangeEnd;
    procedure SetRangeStart;
    procedure UnlockTable(LockType: TLockType);
    property Exists: Boolean read GetExists;
    property IndexFieldCount: Integer read GetIndexFieldCount;
    property IndexFields[Index: Integer]: TField read GetIndexField write SetIndexField;
    property KeyExclusive: Boolean read GetKeyExclusive write SetKeyExclusive;
    property KeyFieldCount: Integer read GetKeyFieldCount write SetKeyFieldCount;
    property TableLevel: Integer read GetTableLevel write FTableLevel;
  published
    property Constraints stored ConstraintsStored;
    property DefaultIndex: Boolean read FDefaultIndex write FDefaultIndex default True;
    property Exclusive: Boolean read FExclusive write SetExclusive default False;
    property FieldDefs stored FieldDefsStored;
    property IndexDefs: TIndexDefs read FIndexDefs write SetIndexDefs stored IndexDefsStored;
    property IndexFieldNames: string read GetIndexFieldNames write SetIndexFieldNames;
    property IndexFiles: TStrings read FIndexFiles write SetIndexFiles;
    property IndexName: string read GetIndexName write SetIndexName;
    property MasterFields: string read GetMasterFields write SetMasterFields;
    property MasterSource: TDataSource read GetDataSource write SetDataSource;
    property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
    property StoreDefs: Boolean read FStoreDefs write FStoreDefs default False;
    property TableName: TFileName read FTableName write SetTableName;
    property TableType: TTableType read FTableType write SetTableType default ttDefault;
    property UpdateMode;
    property UpdateObject;
  end;

{ TBatchMove }

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

{ TStoredProc }

  TParamBindMode = (pbByName, pbByNumber);

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

  TServerDescList = array of TServerDesc;
  TSPParamDescList = array of SPParamDesc;

  TStoredProc = class(TDBDataSet)
  private
    FProcName: string;
    FParams: TParams;
    FParamDescs: TSPParamDescList;
    FServerDescs: TServerDescList;
    FRecordBuffer: array of Char;
    FOverLoad: Word;
    FPrepared: Boolean;
    FQueryMode: Boolean;
    FBindMode: TParamBindMode;
    procedure BindParams;
    function CheckServerParams: Boolean;
    function CreateCursor(GenHandle: Boolean): HDBICur;
    procedure CreateParamDesc;
    procedure FreeStatement;
    function GetCursor(GenHandle: Boolean): HDBICur;
    procedure PrepareProc;
    procedure ReadParamData(Reader: TReader);
    procedure SetParamsList(Value: TParams);
    procedure SetServerParams;
    procedure WriteParamData(Writer: TWriter);
  protected
    { IProviderSupport }
    procedure PSExecute; override;
    function PSGetTableName: string; override;
    function PSGetParams: TParams; override;
    procedure PSSetCommandText(const CommandText: string); override;
    procedure PSSetParams(AParams: TParams); override;