dbtables.pas

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

  protected
    function CreateHandle: HDBICur; override;
    procedure DefineProperties(Filer: TFiler); override;
    procedure Disconnect; override;
    function GetParamsCount: Word;
    function SetDBFlag(Flag: Integer; Value: Boolean): Boolean; override;
    procedure SetOverLoad(Value: Word);
    procedure SetProcName(const Value: string);
    procedure SetPrepared(Value: Boolean);
    procedure SetPrepare(Value: Boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CopyParams(Value: TParams);
    function DescriptionsAvailable: Boolean;
    procedure ExecProc;
    function ParamByName(const Value: string): TParam;
    procedure Prepare;
    procedure GetResults;
    procedure UnPrepare;
    property Handle: HDBICur read GetHandle;
    property ParamCount: Word read GetParamsCount;
    property StmtHandle;
    property Prepared: Boolean read FPrepared write SetPrepare;
  published
    property StoredProcName: string read FProcName write SetProcName;
    property Overload: Word read FOverload write SetOverload default 0;
    property Params: TParams read FParams write SetParamsList stored False;
    property ParamBindMode: TParamBindMode read FBindMode write FBindMode default pbByName;
    property UpdateObject;
  end;

{ TQuery }

  TQuery = class(TDBDataSet)
  private
    FSQL: TStrings;
    FPrepared: Boolean;
    FParams: TParams;
    FText: string;
    FDataLink: TDataLink;
    FLocal: Boolean;
    FRowsAffected: Integer;
    FUniDirectional: Boolean;
    FRequestLive: Boolean;
    FSQLBinary: PChar;
    FConstrained: Boolean;
    FParamCheck: Boolean;
    FExecSQL: Boolean;
    FCheckRowsAffected: Boolean;
    function CreateCursor(GenHandle: Boolean): HDBICur;
    function GetQueryCursor(GenHandle: Boolean): HDBICur;
    function GetRowsAffected: Integer;
    procedure PrepareSQL(Value: PChar);
    procedure QueryChanged(Sender: TObject);
    procedure ReadBinaryData(Stream: TStream);
    procedure ReadParamData(Reader: TReader);
    procedure RefreshParams;
    procedure SetDataSource(Value: TDataSource);
    procedure SetQuery(Value: TStrings);
    procedure SetParamsList(Value: TParams);
    procedure SetParamsFromCursor;
    procedure SetPrepared(Value: Boolean);
    procedure SetPrepare(Value: Boolean);
    procedure WriteBinaryData(Stream: TStream);
    procedure WriteParamData(Writer: TWriter);
  protected
    { IProviderSupport }
    procedure PSExecute; override;
    function PSGetDefaultOrder: TIndexDef; override;
    function PSGetParams: TParams; override;
    function PSGetTableName: string; override;
    procedure PSSetCommandText(const CommandText: string); override;
    procedure PSSetParams(AParams: TParams); override;
  protected
    function CreateHandle: HDBICur; override;
    procedure DefineProperties(Filer: TFiler); override;
    procedure Disconnect; override;
    procedure FreeStatement; virtual;
    function GetDataSource: TDataSource; override;
    function GetParamsCount: Word;
    function SetDBFlag(Flag: Integer; Value: Boolean): Boolean; override;
    procedure GetStatementHandle(SQLText: PChar); virtual;
    property DataLink: TDataLink read FDataLink;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ExecSQL;
    procedure GetDetailLinkFields(MasterFields, DetailFields: TList); override;
    function ParamByName(const Value: string): TParam;
    procedure Prepare;
    procedure UnPrepare;
    property Prepared: Boolean read FPrepared write SetPrepare;
    property ParamCount: Word read GetParamsCount;
    property Local: Boolean read FLocal;
    property StmtHandle;
    property Text: string read FText;
    property RowsAffected: Integer read GetRowsAffected;
    property SQLBinary: PChar read FSQLBinary write FSQLBinary;
  published
    property Constrained: Boolean read FConstrained write FConstrained default False;
    property Constraints stored ConstraintsStored;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property ParamCheck: Boolean read FParamCheck write FParamCheck default True;
    property RequestLive: Boolean read FRequestLive write FRequestLive default False;
    property SQL: TStrings read FSQL write SetQuery;
    { This property must be listed after the SQL property for Delphi 1.0 compatibility }
    property Params: TParams read FParams write SetParamsList stored False;
    property UniDirectional: Boolean read FUniDirectional write FUniDirectional default False;
    property UpdateMode;
    property UpdateObject;
end;

{ TUpdateSQL }

  TUpdateSQL = class(TSQLUpdateObject)
  private
    FDataSet: TDataSet;
    FDatabaseName: string;
    FSessionName: string;
    FQueries: array[TUpdateKind] of TQuery;
    FSQLText: array[TUpdateKind] of TStrings;
    function GetQuery(UpdateKind: TUpdateKind): TQuery;
    function GetSQLIndex(Index: Integer): TStrings;
    procedure SetSQL(UpdateKind: TUpdateKind; Value: TStrings);
    procedure SetSQLIndex(Index: Integer; Value: TStrings);
  protected
    function GetSQL(UpdateKind: TUpdateKind): TStrings; override;
    function GetDataSet: TDataSet; override;
    procedure SetDataSet(ADataSet: TDataSet); override;
    procedure SQLChanged(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Apply(UpdateKind: TUpdateKind); override;
    procedure ExecSQL(UpdateKind: TUpdateKind); virtual; 
    procedure SetParams(UpdateKind: TUpdateKind); virtual; 
    property DatabaseName: string read FDatabaseName write FDatabaseName; 
    property DataSet;
    property Query[UpdateKind: TUpdateKind]: TQuery read GetQuery;
    property SQL[UpdateKind: TUpdateKind]: TStrings read GetSQL write SetSQL;
    property SessionName: string read FSessionName write FSessionName; 
  published
    property ModifySQL: TStrings index 0 read GetSQLIndex write SetSQLIndex;
    property InsertSQL: TStrings index 1 read GetSQLIndex write SetSQLIndex;
    property DeleteSQL: TStrings index 2 read GetSQLIndex write SetSQLIndex;
  end;

{ TBlobStream }

  TBlobStream = class(TStream)
  private
    FField: TBlobField;
    FDataSet: TBDEDataSet;
    FBuffer: PChar;
    FMode: TBlobStreamMode;
    FFieldNo: Integer;
    FOpened: Boolean;
    FModified: Boolean;
    FPosition: Longint;
    FBlobData: TBlobData;
    FCached: Boolean;
    FCacheSize: Longint;
    function GetBlobSize: Longint;
  public
    constructor Create(Field: TBlobField; Mode: TBlobStreamMode);
    destructor Destroy; override;
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;
    procedure Truncate;
  end;

function AnsiToNative(Locale: TLocale; const AnsiStr: string;
  NativeStr: PChar; MaxLen: Integer): PChar;
procedure NativeToAnsi(Locale: TLocale; NativeStr: PChar;
  var AnsiStr: string);
procedure AnsiToNativeBuf(Locale: TLocale; Source, Dest: PChar; Len: Integer);
procedure NativeToAnsiBuf(Locale: TLocale; Source, Dest: PChar; Len: Integer);

function NativeCompareStr(Locale: TLocale; const S1, S2: string; Len: Integer): Integer;
function NativeCompareStrBuf(Locale: TLocale; const S1, S2: PChar; Len: Integer): Integer;
function NativeCompareText(Locale: TLocale; const S1, S2: string; Len: Integer): Integer;
function NativeCompareTextBuf(Locale: TLocale; const S1, S2: PChar; Len: Integer): Integer;

function GetFieldSource(ADataSet: TDataSet; var ADataSources:  DataSources): Boolean;

procedure DbiError(ErrorCode: DBIResult);
procedure Check(Status: DBIResult);
procedure RegisterBDEInitProc(const InitProc: TBDEInitProc);

const
  { Backward compatibility for TConfigMode }
  cmVirtual = [cfmVirtual];
  cmPersistent = [cfmPersistent];
  cmSession = [cfmSession];
  cmAll = [cfmVirtual, cfmPersistent, cfmSession];

var
  Session: TSession;
  Sessions: TSessionList;
  GetObjectContextProc: function: IUnknown;

implementation

uses DBConsts, bdeconst, ActiveX;

const
  TableTypeDriverNames: array[TTableType] of PChar =
    (szPARADOX, szPARADOX, szDBASE, szFOXPRO, szASCII);

var
  FCSect: TRTLCriticalSection;
  CSNativeToAnsi: TRTLCriticalSection;
  CSAnsiToNative: TRTLCriticalSection;
  TimerID: Word = 0;
  SQLDelay: DWORD = 50;
  StartTime: DWORD = 0;
  BDEInitProcs: TList;

{ TQueryDataLink }

type
  TQueryDataLink = class(TDetailDataLink)
  private
    FQuery: TQuery;
  protected
    procedure ActiveChanged; override;
    procedure RecordChanged(Field: TField); override;
    function GetDetailDataSet: TDataSet; override;
    procedure CheckBrowseMode; override;
  public
    constructor Create(AQuery: TQuery);
  end;

{ Utility routines }

function DefaultSession: TSession;
begin
  Result := DBTables.Session;
end;

procedure RegisterBDEInitProc(const InitProc: TBDEInitProc);
begin
  if not Assigned(BDEInitProcs) then
    BDEInitProcs := TList.Create;
  BDEInitProcs.Add(@InitProc);
end;

procedure CheckIndexOpen(Status: DBIResult);
begin
  if (Status <> 0) and (Status <> DBIERR_INDEXOPEN) then
    DbiError(Status);
end;

function GetFieldSource(ADataSet: TDataSet; var ADataSources:  DataSources): Boolean;
var
  Current: PChar;
  Field: TField;
  Values: array[0..4] of string;
  I: Integer;

  function GetPChar(const S: string): PChar;
  begin
    if S <> '' then Result := PChar(Pointer(S)) else Result := '';
  end;

  procedure Split(const S: string);
  begin
    Current := PChar(Pointer(S));
  end;

  function NextItem: string;
  var
    C: PChar;
    I: PChar;
    Terminator: Char;
    Ident: array[0..1023] of Char;
  begin
    Result := '';
    C := Current;
    I := Ident;
    while C^ in ['.',' ',#0] do
      if C^ = #0 then Exit else Inc(C);
    Terminator := '.';
    if C^ = '"' then
    begin
      Terminator := '"';
      Inc(C);
    end;
    while not (C^ in [Terminator, #0]) do
    begin
      if C^ in LeadBytes then
      begin
        I^ := C^;
        Inc(C);
        Inc(I);
      end
      else if C^ = '\' then
      begin
        Inc(C);
        if C^ in LeadBytes then
        begin
          I^ := C^;
          Inc(C);
          Inc(I);
        end;
        if C^ = #0 then Dec(C);
      end;
      I^ := C^;
      Inc(C);
      Inc(I);
    end;
    SetString(Result, Ident, I - Ident);
    if (Terminator = '"') and (C^ <> #0) then Inc(C);
    Current := C;
  end;

  function PopValue: PChar;
  begin
    if I >= 0 then
    begin
      Result := GetPChar(Values[I]);
      Dec(I);
    end else Result := '';
  end;

begin
  Result := False;
  Field := ADataSet.FindField(ADataSources.szSourceFldName);
  if (Field = nil) or (Field.Origin = '') then Exit;
  Split(Field.Origin);
  I := -1;
  repeat
    Inc(I);
    Values[I] := NextItem;
  until (Values[I] = '') or (I = High(Values));
  if I = High(Values) then Exit;
  Dec(I);
  StrCopy(ADataSources.szOrigFldName, PopValue);
  StrCopy(ADataSources.szTblName, PopValue);
  StrCopy(ADataSources.szDbName, PopValue);
  Result := (ADataSources.szOrigFldName[0] <> #0) and
    (ADataSources.szTblName[0] <> #0);
end;

procedure ApplicationHandleException(Sender: TObject);
begin
  if Assigned(Classes.ApplicationHandleException) then
    Classes.ApplicationHandleException(Sender);
end;

{ Parameter binding routines }