sqlexpr.pas

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

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


unit SqlExpr;

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

interface

{$IFDEF MSWINDOWS}
uses Windows, SysUtils, Variants, Classes, DB, DBCommon, DBXpress, SqlTimSt;
{$ENDIF}
{$IFDEF LINUX}
uses Libc, SysUtils, Variants, Classes, DB, DBCommon, DBXpress, SqlTimSt;
{$ENDIF}

const

  SSelect         =   'select';               { Do not localize }
  SSelectStar     =   ' select * ';           { Do not localize }
  SSelectStarFrom =   ' select * from ';      { Do not localize }
  SWhere          =   ' where ';              { Do not localize }
  SAnd            =   ' and ';                { Do not localize }
  SOrderBy        =   ' order by ';           { Do not localize }
  SParam          =   '?';                    { Do not localize }
  DefaultCursor   =   0;
  HourGlassCursor =   -11;

{ Default Max BlobSize }

  DefaultMaxBlobSize = -1;   // values are in K; -1 means retrieve actual size

{ Default RowsetSize }

  DefaultRowsetSize = 20;

  TErrorMessageSize = 2048;

{ FieldType Mappings }

  FldTypeMap: TFieldMap = (
    fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
    fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
    fldVARBYTES, fldINT32, fldBLOB, fldBLOB, fldBLOB, fldBLOB, fldBLOB,
    fldBLOB, fldBLOB, fldCURSOR, fldZSTRING, fldZSTRING, fldINT64, fldADT,
    fldArray, fldREF, fldTABLE, fldBLOB, fldBLOB, fldUNKNOWN, fldUNKNOWN,
    fldUNKNOWN, fldZSTRING, fldDATETIME, fldFMTBCD);

  FldSubTypeMap: array[TFieldType] of Word = (
    0, 0, 0, 0, 0, 0, 0, fldstMONEY, 0, 0, 0, 0, 0, 0, fldstAUTOINC,
    fldstBINARY, fldstMEMO, fldstGRAPHIC, fldstFMTMEMO, fldstOLEOBJ,
    fldstDBSOLEOBJ, fldstTYPEDBINARY, 0, fldstFIXED, fldstUNICODE,
    0, 0, 0, 0, 0, fldstHBINARY, fldstHMEMO, 0, 0, 0, 0, 0, 0);

  DataTypeMap: array[0..MAXLOGFLDTYPES - 1] of TFieldType = (
    ftUnknown, ftString, ftDate, ftBlob, ftBoolean, ftSmallint,
    ftInteger, ftFloat, ftBCD, ftBytes, ftTime, ftDateTime,
    ftWord, ftInteger, ftUnknown, ftVarBytes, ftUnknown, ftCursor,
    ftLargeInt, ftLargeInt, ftADT, ftArray, ftReference, ftDataSet,
    ftTimeStamp, ftFMTBCD);

  BlobTypeMap: array[fldstMEMO..fldstBFILE] of TFieldType = (
    ftMemo, ftBlob, ftFmtMemo, ftParadoxOle, ftGraphic, ftDBaseOle,
    ftTypedBinary, ftBlob, ftBlob, ftBlob, ftBlob, ftOraClob, ftOraBlob,
    ftBlob, ftBlob);

type

{ Forward declarations }

  TSQLConnection = class;
  TCustomSQLDataSet = class;
  TSQLDataSet = class;
  TSQLQuery = class;
  TSQLStoredProc = class;
  TSQLTable = class;

  TLocaleCode = Integer;

  TSQLExceptionType = (exceptConnection, exceptCommand, exceptCursor, exceptMetaData, exceptUseLast);

  TSQLTraceFlag = (traceQPREPARE, traceQEXECUTE, traceERROR,
    traceSTMT, traceCONNECT, traceTRANSACT, traceBLOB, traceMISC, traceVENDOR,
    traceDATAIN, traceDATAOUT);

  TSQLTraceFlags = set of TSQLTraceFlag;

  PSPParamDesc = ^SPParamDesc;
  SPParamDesc = packed record           { Stored Proc Descriptor }
    iParamNum       : Word;             { Field number (1..n) }
    szName          : string;           { Field name }
    iArgType        : TParamType;       { Field type }
    iDataType       : TFieldType;       { Field type }
    iUnits1         : SmallInt;         { Number of Chars, digits etc }
    iUnits2         : SmallInt;         { Decimal places etc. }
    iLen            : LongWord;         { Length in bytes  }
  end;

{ TSQLBlobStream }

  TSQLBlobStream = class(TMemoryStream)
  private
    FDataSet: TCustomSQLDataSet;
    FField: TBlobField;
    FFieldNo: Integer;
  public
    constructor Create(Field: TBlobField; Mode: TBlobStreamMode = bmRead);
    destructor Destroy; override;
    procedure ReadBlobData;
  end;

  TConnectionUserType = (eUserMonitor, eUserDataSet);

{ TSQLMonitor }

  pSQLTRACEDesc = ^SQLTRACEDesc;
  SQLTRACEDesc = packed record             { trace callback info }
    pszTrace        : array [0..1023] of Char;
    eTraceCat       : TRACECat;
    ClientData      : Integer;
    uTotalMsgLen    : Word;
  end;

  TTraceEvent = procedure(Sender: TObject; CBInfo: pSQLTraceDesc; var LogTrace: Boolean) of object;
  TTraceLogEvent = procedure(Sender: TObject; CBInfo: pSQLTraceDesc) of object;

  TSQLMonitor = class(TComponent)
  private
    FActive: Boolean;
    FAutoSave: Boolean;
    FFileName: string;
    FKeepConnection: Boolean;
    FMaxTraceCount: Integer;
    FOnTrace: TTraceEvent;
    FOnLogTrace: TTraceLogEvent;
    FSQLConnection: TSQLConnection;
    FStreamedActive: Boolean;
    FTraceFlags: TSQLTraceFlags;
    FTraceList: TStrings;
    procedure CheckInactive;
    function GetTraceCount: Integer;
  protected
    function InvokeCallBack(CallType: TRACECat; CBInfo: Pointer): CBRType; stdcall;
    procedure SetActive(Value: Boolean);
    procedure SetSQLConnection(Value: TSQLConnection);
    procedure SetStreamedActive;
    procedure SetTraceList(Value: TStrings);
    procedure SetFileName(const Value: String);
    procedure SwitchConnection(const Value: TSQLConnection);
    procedure Trace(Desc: pSQLTraceDesc; LogTrace: Boolean); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure LoadFromFile(AFileName: string);
    procedure SaveToFile(AFileName: string);
    property MaxTraceCount: Integer read FMaxTraceCount write FMaxTraceCount;
    property TraceCount: Integer read GetTraceCount;
  published
    property Active: Boolean read FActive write SetActive default False;
    property AutoSave: Boolean read FAutoSave write FAutoSave default False;
    property FileName: string read FFileName write SetFileName;
    property OnLogTrace: TTraceLogEvent read FOnLogTrace write FOnLogTrace;
    property OnTrace: TTraceEvent read FOnTrace write FOnTrace;
{   property TraceFlags not supported in DBExpress 1.0 }
    property TraceList: TStrings read FTraceList write SetTraceList stored False;
    property SQLConnection: TSQLConnection read FSQLConnection write SetSQLConnection;
  end;

{ TSQLConnection }

  TLocale = Pointer;

  EConnectFlag = (eConnect, eReconnect, eDisconnect);

  TSchemaType = (stNoSchema, stTables, stSysTables, stProcedures, stColumns,
    stProcedureParams, stIndexes, stPackages);

  TConnectionState = (csStateClosed, csStateOpen, csStateConnecting,
    csStateExecuting, csStateFetching, csStateDisconnecting);

  TTableScope = (tsSynonym, tsSysTable, tsTable, tsView);

  TTableScopes = set of TTableScope;

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

  TSQLConnectionLoginEvent = procedure(Database: TSQLConnection;
    LoginParams: TStrings) of object;

  TSQLConnection = class(TCustomConnection)
  private
    FActiveStatements: LongWord;
    FAutoClone: Boolean;
    FCloneParent: TSQLConnection;
    FConnectionState: TConnectionState;
    FConnectionName: string;
    FConnectionRegistryFile: string;
    FDriverName: string;
    FDriverRegistryFile: string;
    FGetDriverFunc: string;
    FTransactionCount: Integer;
    FIsCloned: Boolean;
    FISQLConnection: ISQLConnection;
    FKeepConnection: Boolean;
    FLastError: string;  // DBExpress GetError() clears error; need to save last
    FLibraryName: string;
    FLoadParamsOnConnect: Boolean;
    FMonitorUsers: TList;
    FOnLogin: TSQLConnectionLoginEvent;
    FParams: TStrings;
    FParamsLoaded: Boolean;
    FMaxStmtsPerConn: LongWord;
    FQuoteChar: String;
    FRefCount: Integer;
    FSQLDllHandle: THandle;
    FSQLDriver: ISQLDriver;
    FSQLHourGlass: Boolean;
    FSQLMetaData: ISQLMetaData;
    FSupportsMultiTrans: LongBool;
    FTableScope: TTableScopes;
    FTraceCallbackEvent: TSQLCallbackEvent;
    FTraceClientData: Integer;
    FTransactionsSupported: LongBool;
    FVendorLib: string;
    FTransIsoLevel: TTransIsolationLevel;
    procedure CheckActive;
    procedure CheckInactive;
    procedure CheckLoginParams;
    procedure ClearConnectionUsers;
    procedure ClearMonitors;
    procedure FreeSchemaTable(DataSet: TCustomSQLDataSet);
    function GetConnectionForStatement: TSQLConnection;
    function GetConnectionName: string;
    function GetFDriverRegistryFile: string;
    function GetLocaleCode: TLocaleCode;
    function GetInTransaction: Boolean;
    function GetLibraryName: string;
    procedure GetLoginParams(LoginParams: TStrings);
    function GetQuoteChar: string;
    function GetVendorLib: string;
    procedure Login(LoginParams: TStrings);
    function OpenSchemaTable(eKind: TSchemaType; SInfo: string; SQualifier: string = '';SPackage: string = ''): TCustomSQLDataSet;overload;
    function OpenSchemaTable(eKind: TSchemaType; SInfo: string; SQualifier: string = ''; SPackage: string = ''; SSchemaName: string = ''): TCustomSQLDataSet;overload;
    procedure RegisterTraceMonitor(Client: TObject);
    procedure RegisterTraceCallback(Value: Boolean);
    procedure SetConnectionParams;
    procedure SetConnectionName(Value: string);
    procedure SetDriverName(Value: string);
    procedure SetKeepConnection(Value: Boolean);
    procedure SetParams(Value: TStrings);
    procedure SetCursor(CursorType: Integer);
    procedure SetLocaleCode(Value: TLocaleCode);
//    function SQLTraceCallback(CBInfo: Pointer): CBRType;
    procedure UnregisterTraceMonitor(Client: TObject);
  protected
    function Check(status: SQLResult): SQLResult;
    procedure CheckConnection(eFlag: eConnectFlag);
    procedure CheckDisconnect; virtual;
    procedure ConnectionOptions; virtual;
    procedure DoConnect; override;
    procedure DoDisconnect; override;
    function GetConnected: Boolean; override;
    function GetDataSet(Index: Integer): TCustomSQLDataSet; reintroduce;
    procedure Loaded; override;
    procedure LoadSQLDll;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    procedure OpenSchema(eKind: TSchemaType; sInfo: string; List: TStrings); overload;
    procedure OpenSchema(eKind: TSchemaType; sInfo, SSchemaName: string; List: TStrings); overload;
    procedure SQLError(OpStatus: SQLResult; eType: TSQLExceptionType; const Command: ISQLCommand = nil);
    property Connection: ISQLConnection read FISQLConnection;
    property ConnectionRegistryFile: string read FConnectionRegistryFile;
    property Driver: ISQLDriver read FSQLDriver;
    property DriverRegistryFile: string read GetFDriverRegistryFile;
    property LastError: string read FLastError write FLastError;
    property QuoteChar: String read FQuoteChar;
    property SQLDllHandle: THandle read FSQLDllHandle write FSQlDllHandle;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function CloneConnection: TSQLConnection;
    procedure CloseDataSets;
    procedure Commit( TransDesc: TTransactionDesc);
    function Execute(const SQL: string; Params: TParams;
      ResultSet: Pointer = nil): Integer;
    function ExecuteDirect(const SQL: string): Integer;
    procedure GetFieldNames(const TableName: string; List: TStrings);
    procedure GetIndexNames(const TableName: string; List: TStrings); overload;
    procedure GetIndexNames(const TableName, SchemaName: string; List: TStrings); overload;
    procedure GetProcedureNames(List: TStrings); overload;
    procedure GetProcedureNames(const PackageName: string; List: TStrings); overload;
    procedure GetProcedureNames(const PackageName, SchemaName: string; List: TStrings); overload;
    procedure GetPackageNames(List: TStrings);
    procedure GetProcedureParams(ProcedureName : string; List: TList); overload;
    procedure GetProcedureParams(ProcedureName, PackageName:string; List: TList); overload;
    procedure GetProcedureParams(ProcedureName, PackageName, SchemaName:string; List: TList); overload;
    procedure GetTableNames(List: TStrings; SystemTables: Boolean = False); overload;
    procedure GetTableNames(List: TStrings; SchemaName:string; SystemTables: Boolean = False); overload;
    procedure LoadParamsFromIniFile( FFileName: string = '');
    procedure Rollback( TransDesc: TTransactionDesc);
    procedure SetTraceCallbackEvent(Event: TSQLCallbackEvent; IClientInfo: Integer);
    procedure StartTransaction( TransDesc: TTransactionDesc);
    property ActiveStatements: LongWord read FActiveStatements;
    property AutoClone: Boolean read FAutoClone write FAutoClone default True;
    property ConnectionState: TConnectionState read FConnectionState write FConnectionState;
    property DataSets[Index: Integer]: TCustomSQLDataSet read GetDataSet;
    property InTransaction: Boolean read GetInTransaction;
    property LocaleCode: TLocaleCode read GetLocaleCode write SetLocaleCode default TLocaleCode(0);
    property MaxStmtsPerConn: LongWord read FMaxStmtsPerConn;
    property MetaData: ISQLMetaData read FSQLMetaData;
    property MultipleTransactionsSupported: LongBool read FSupportsMultiTrans;
    property ParamsLoaded: Boolean read FParamsLoaded write FParamsLoaded;
    property SQLConnection: ISQLConnection read FISQLConnection write FISQLConnection;
    property SQLHourGlass: Boolean read FSQLHourGlass write FSQLHourGlass default True;
    property TraceCallbackEvent: TSQLCallbackEvent read FTraceCallbackEvent;
    property TransactionsSupported: LongBool read FTransactionsSupported;
//    property Locale: TLocale read FLocale;
  published
    property ConnectionName: string read GetConnectionName write SetConnectionName;
    property DriverName: string read FDriverName write SetDriverName;
    property GetDriverFunc: string read FGetDriverFunc write FGetDriverFunc;
    property KeepConnection: Boolean read FKeepConnection write SetKeepConnection default True;
    property LibraryName: string read GetLibraryName write FLibraryName;
    property LoadParamsOnConnect: Boolean read FLoadParamsOnConnect write FLoadParamsOnConnect default False;
    property LoginPrompt default True;
    property Params: TStrings read FParams write SetParams;
    property TableScope: TTableScopes read FTableScope write FTableScope default [tsTable, tsView];
    property VendorLib: string read GetVendorLib write FVendorLib;
    property AfterConnect;
    property AfterDisconnect;
    property BeforeConnect;
    property BeforeDisconnect;
    property OnLogin: TSQLConnectionLoginEvent read FOnLogin write FOnLogin;
    property Connected;
  end;

{ TSQLDataLink }

  TSQLDataLink = class(TDetailDataLink)
  private
    FSQLDataSet: TCustomSQLDataSet;
  protected
    procedure ActiveChanged; override;
    procedure CheckBrowseMode; override;
    function GetDetailDataSet: TDataSet; override;
    procedure RecordChanged(Field: TField); override;
  public
    constructor Create(ADataSet: TCustomSQLDataSet);
  end;

{ TCustomSQLDataSet }

  TSQLCommandType = (ctQuery, ctTable, ctStoredProc);

  TSQLSchemaInfo = record
    FType: TSchemaType;
    ObjectName: string;
    Pattern: string;
    PackageName : string;
  end;

  TFieldDescList = array of FLDDesc;

  TCustomSQLDataSet = class(TDataSet)
  private
    FBlobBuffer: TBlobByteData;
    FCalcFieldsBuffer: PChar;
    FCheckRowsAffected: Boolean;
    FClonedConnection: TSqlConnection;
    FCommandText: string;
    FCommandType: TSQLCommandType;
    FCurrentBlobSize: LongWord;
    FDataLink: TDataLink;
    FDesignerData: string;
    FGetNextRecordSet: Boolean;
    FIndexDefs: TIndexDefs;
    FIndexDefsLoaded: Boolean;