zquery.pas

控件名称：WINZEOS.ZIP 2002年08月03日 作者：CapellaDevelopment Zeos系列构件套件包含一组可直接存取Linux知名的免费数据库MySQL、Postgre

{********************************************************}
{                                                        }
{                 Zeos Database Objects                  }
{               Abstract Dataset component               }
{                                                        }
{       Copyright (c) 1999-2001 Sergey Seroukhov         }
{    Copyright (c) 1999-2001 Zeos Development Group      }
{                                                        }
{********************************************************}

unit ZQuery;

interface

{$IFNDEF LINUX}
{$INCLUDE ..\ZeosDef.inc}
{$ELSE}
{$INCLUDE ../ZeosDef.inc}
{$ENDIF}

uses
 Windows, DbTables, Variants, FmtBcd, SysUtils, DB, Classes, ZDirSql, 
 DBCommon, ZToken, ZSqlExtra, ZBlobStream, ZConnect, ZTransact,
 ZUpdateSql, ZParser, ZSqlTypes, ZSqlParser, ZSqlBuffer, ZSqlItems;

{$IFNDEF LINUX}
{$INCLUDE ..\Zeos.inc}
{$ELSE}
{$INCLUDE ../Zeos.inc}
{$ENDIF}

type

{$IFNDEF WINDOWS}
  TUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApplied);
{$ENDIF}

  { Supported databases }
  TZDatabaseType = TDatabaseType;

  { Link options }
  TZLinkOption = (loLinkRequery, loCascadeUpdate, loCascadeDelete, loAlwaysResync);
  TZLinkOptions = set of TZLinkOption;

  { General dataset options }
  TZDatasetOption = (doParamsAsIs, doHourGlass, doQueryAllRecords,
    doAutoFillDefs, doCalcDefault, doQuickOpen, doEnableAutoInc,
    doUseRowId, doCursorFetch, doSqlFilter, doRefreshAfterPost, doRefreshBeforeEdit);
  TZDatasetOptions = set of TZDatasetOption;

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

  TZUpdateRecordTypes = ZSqlTypes.TZUpdateRecordTypes;

  { Progress event types }
  TZProgressStage = (psStarting, psRunning, psEnding);
  TZProgressProc = (ppFetching, ppClosing);
  TZProgressEvent = procedure (Sender: TObject; Stage: TZProgressStage;
    Proc: TZProgressProc; Position, Max: Integer; var Cancel: Boolean) of object;

  TZDataset = class;

  { Query datalink class }
  TZQueryDataLink = class(TDataLink)
  private
    FQuery: TZDataset;
  protected
    procedure ActiveChanged; override;
    procedure RecordChanged(Field: TField); override;
  public
    constructor Create(AQuery: TZDataset);
  end;

  { Abstract query with descendant of TDataSet }
  TZDataset = class(TDataSet)
  private
    { Internal fields }
    FAutoOpen: Boolean;
    FAutoStart: Boolean;
    FNewValueState: Boolean;
    FDatabaseType: TZDatabaseType;
    FVersion: Integer;
    { Query fields }
    FSqlParser: TSqlParser;
    FSqlBuffer: TSqlBuffer;
    FCacheBuffer: TSqlBuffer;
    FTableName: string;
    FDefaultIndex : Boolean;
    FRowsAffected: Integer;
    FRequestLive: Boolean;
    { Params fields }
    FParams: TParams;
    FParamCheck: Boolean;
    { Internal connections }
    FDatabase: TZDatabase;
    FTransact: TZTransact;
    FQuery: TDirQuery;
    { IndexDefs support }
    FIndexDefs: TIndexDefs;
    FIndexName: string;
    FFieldsIndex: Boolean;
    { Other fields }
    FCurRec: Integer;
    FOptions: TZDatasetOptions;
    FParser: TZParser;
    FCCParser: TZParser;
    FFiltered: Boolean;
    FFetchAll: Boolean;
    { Updates properties }
    FCachedUpdates: Boolean;
    FOnApplyUpdateError: TDataSetErrorEvent;
    FOnUpdateRecord: TUpdateRecordEvent;
    FUpdateObject: TZUpdateSql;
    { Master-detail properties }
    FLinkCheck:   Boolean;
    FLinkFields:  string;
    FLinkOptions: TZLinkOptions;
    FMasterIndex: Integer;
    FMasterFields: TFieldList;
    FMasterFieldCount: Integer;
    FMasterLink: TMasterDataLink;
    FDetailFields: array[0..MAX_FIELD_COUNT] of string;
    { Internal data-link support }
    FDataLink: TZQueryDataLink;
    { Other fields }
    FOnProgress: TZProgressEvent;

    { IndexDefs support methods }
    procedure SetIndexDefs(Value: TIndexDefs);
    function GetIndexName: string;
    procedure SetIndexName(const Value: string);
    function GetIndexFieldNames: string;
    procedure SetIndexFieldNames(const Value: string);
    function GetIndexFieldCount: Integer;
    function GetIndexField(Index: Integer): TField;
    procedure SetIndexField(Index: Integer; Value: TField);
    procedure SetIndex(const Value: string; FieldsIndex: Boolean);
    { Private property processing methods }
    function GetParamsCount: Word;
    function GetUpdatesPending: Boolean;
    function GetSql: TStrings;
    function GetReadOnly: Boolean;
    procedure SetParamsList(Value: TParams);
    procedure SetSql(Value: TStrings);
    procedure SetTableName(Value: string);
    procedure SetReadOnly(Value: Boolean);
    procedure SetUpdateObject(Value: TZUpdateSql);
    function GetUpdateRecord: TZUpdateRecordTypes;
    procedure SetUpdateRecord(Value: TZUpdateRecordTypes);
    procedure SetOptions(Value: TZDatasetOptions);
  protected
    { Private methods for master-detail support }
    function GetLinkFields: string;
    function GetMasterDataSource: TDataSource;
    procedure SetLinkFields(Value: string);
    procedure SetMasterDataSource(Value: TDataSource);
    procedure UpdateLinkFields;
    procedure MasterChanged(Sender: TObject);
    procedure MasterDisabled(Sender: TObject);
    procedure MasterCascade;
    procedure MasterRequery;
    function MasterStateCheck(Dataset: TDataset): Boolean;
    procedure MasterDefine;
    { Private methods for data-link support }
    function GetDataLinkSource: TDataSource;
    procedure SetDataLinkSource(Value: TDataSource);
    procedure ParamsRequery;
    procedure RefreshParams;
    { Private methods for getting fields }
    function CheckRecordByFilter(RecNo: LongInt): Boolean;
    procedure QueryRecords(Force: Boolean);
    procedure QueryOneRecord;
    { Other private methods }
    procedure ShortRefresh;
    function RefreshCurrentRow(RecordData: PRecordData): Boolean;
{$IFNDEF VER100}
    procedure ResetAggField(Field: TField); override;
    function GetAggregateValue(Field: TField): Variant; override;
{$ENDIF}
    procedure SqlFilterRefresh;
  protected
    { Wrapping main fields }
    property DatabaseObj: TZDatabase read FDatabase write FDatabase;
    property TransactObj: TZTransact read FTransact write FTransact;
    property Query: TDirQuery read FQuery write FQuery;
    property FetchAll: Boolean read FFetchAll write FFetchAll;
    property FilterMark: Boolean read FFiltered write FFiltered;
  protected
    { Private property processing methods }
    procedure SetDatabase(Value: TZDatabase);
    procedure SetTransact(Value: TZTransact);

    procedure ChangeAddBuffer(AddRecord: PRecordData); virtual;
    procedure CreateConnections; virtual;
    procedure FormSqlQuery(OldData, NewData: PRecordData); virtual;
    function FormatFieldsList(Value: string): string;
    function FormTableSqlOrder: string;
    procedure QueryRecord; virtual; abstract;
    { Methods for query fieds description }
    procedure DefineTableKeys(Table: string; Unique: Boolean;
      var FieldList: TFieldList; var FieldCount: Integer);
    function FormSqlWhere(Table: string; RecordData: PRecordData): string;
    { Methods for internal fields processing }
    function EvaluteDef(Value: string): string;
    { Overrided methods for fields processing }
    function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean):
      TGetResult; override;
    function GetRecordSize: Word; override;
    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
    function GetFieldClass(FieldType: TFieldType): TFieldClass; override;

    function AllocRecordBuffer: PChar; override;
    procedure CloseBlob(Field: TField); override;
    procedure FreeRecordBuffer(var Buffer: PChar); override;
    { Overrided methods for implement general dataset operation }
    procedure Loaded; override;
    procedure InternalOpen; override;
    procedure InternalClose; override;
    procedure InternalFirst; override;
    procedure InternalLast; override;
    procedure InternalEdit; override;
    procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
    procedure InternalPost; override;
    procedure InternalDelete; override;
    procedure InternalInitRecord(Buffer: PChar); override;
    procedure InternalUpdate;
    procedure InternalGotoBookmark(Bookmark: Pointer); override;
    procedure InternalRefresh; override;
    procedure InternalHandleException; override;
    procedure InternalSetToRecord(Buffer: PChar); override;
    { Other internal methods }
    function InternalLocate(KeyFields: string; KeyValues: Variant;
      Options: TLocateOptions): LongInt;
    procedure InternalFormKeyValues(RecordData: PRecordData; Unique: Boolean;
      var KeyFields: string; var KeyValues: Variant);
    procedure InternalSort(Fields: string; SortType: TSortType);
    { Overrided methods for bookmarks processing }
    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
    function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
    { Overrided methods for searching and filtering }
    function FindRecord(Restart, GoForward: Boolean): Boolean; override;
    procedure SetFiltered(Value: Boolean); override;
    procedure SetFilterText(const Value: string); override;
    { Overrided methods for navigation }
    function GetCanModify: Boolean; override;
    function GetRecNo: Integer; override;
    function GetRecordCount: Integer; override;
    procedure SetRecNo(Value: Integer); override;
    function IsCursorOpen: Boolean; override;
    { Methods for caching updates support }
    procedure ClearBuffer;
    procedure FlushBuffer; virtual;
    procedure CheckContraints;
    procedure UpdateAfterPost(OldData, NewData: PRecordData); virtual;
    procedure UpdateAfterInit(RecordData: PRecordData); virtual;
    procedure Flush;
    { Other protected methods }
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure DoProgress(Stage: TZProgressStage; Proc: TZProgressProc;
      Position: Integer);
    {$IFNDEF VER100}
    procedure DefineProperties(Filer: TFiler); override;
    procedure ReadParamData(Reader: TReader);
    procedure WriteParamData(Writer: TWriter);
    {$ENDIF}
    procedure AutoFillObjects;
    procedure InternalInitFieldDefs; override;
    procedure UpdateIndexDefs; override;
    procedure UpdateFieldDef(FieldDesc: PFieldDesc; var FieldType: TFieldType;
      var FieldSize: Integer); virtual;
    function ConvertToSqlEnc(Value: string): string;
    function ConvertFromSqlEnc(Value: string): string;
    function ValueToRowId(Value: string): TRowId; virtual;
    function RowIdToValue(Value: TRowId): string; virtual;
  protected
    {$IFDEF WITH_IPROVIDER}
    { Provider support }
    procedure PSEndTransaction(Commit: Boolean); override;
    function PSGetTableName: string; override;
    function PSGetQuoteChar: string; override;
    function PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError; override;
    function PSIsSqlBased: Boolean; override;
    function PSIsSqlSupported: Boolean; override;
    procedure PSStartTransaction; override;
    procedure PSReset; override;
    function PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean; override;
    { ADO support }
    procedure PSExecute; override;
    procedure PSGetAttributes(List: TList); override;
    function PSGetDefaultOrder: TIndexDef; override;
    function PSGetKeyFields: string; override;
    function PSGetParams: TParams; override;
    function PSGetIndexDefs(IndexTypes: TIndexOptions = [ixPrimary..ixNonMaintained]): TIndexDefs; override;
    procedure PSSetParams(AParams: TParams); override;
    {$ENDIF}

    { Hided properties }
    property TableName: string read FTableName write SetTableName;
    property RequestLive: Boolean read FRequestLive write FRequestLive;
    property DefaultIndex: Boolean read FDefaultIndex write FDefaultIndex;
    { Data-link support }
    property DataSource: TDataSource read GetDataLinkSource write SetDataLinkSource;
  public
    { Class constructors and destructors }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    { Special properties }
    property SqlParser: TSqlParser read FSqlParser;
    property SqlBuffer: TSqlBuffer read FSqlBuffer;
    property CacheBuffer: TSqlBuffer read FCacheBuffer;
    property CurRec: Integer read FCurRec write FCurRec;

    { Abstract method for implementing in descendant classes }
    procedure AddTableFields(Table: string; SqlFields: TSqlFields);
      virtual; abstract;
    procedure AddTableIndices(Table: string; SqlFields: TSqlFields;
      SqlIndices: TSqlIndices); virtual; abstract;
    function CheckTableExistence(Table: string): Boolean; virtual;
    { Extra functions }
    function StringToSql(Value: string): string;
    function ParamToSql(Value: Variant): string;
    function ValueToSql(Value: Variant): string;
    function ProcessIdent(Value: string): string; virtual;
    function FieldValueToSql(Value: string; FieldDesc: PFieldDesc): string; virtual;
    { Buffer support methods }
    procedure CopyRecord(SqlBuffer: TSqlBuffer; Source, Dest: PRecordData); virtual;
    procedure FreeRecord(SqlBuffer: TSqlBuffer; Value: PRecordData); virtual;

    { Public executing methods }
    procedure ExecSql; virtual;
    function  RowsAffected: LongInt;
    { Public methods for record sorting and searching }
    procedure SortInverse;
    procedure SortClear;
    procedure SortByField(Fields: string);
    procedure SortDescByField(Fields: string);
    function Locate(const KeyFields: string; const KeyValues: Variant;
      Options: TLocateOptions): Boolean; override;
    function Lookup(const KeyFields: string; const KeyValues: Variant;
      const ResultFields: string): Variant; override;
    function IsSequenced: Boolean; override;
    function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override;
    function BookmarkValid(Bookmark: TBookmark): Boolean; override;
    { Public methods for caching updates support }
    procedure ApplyUpdates;
    procedure CommitUpdates;
    procedure CancelUpdates;
    procedure RevertRecord;
    function UpdateStatus: TUpdateStatus; {$IFNDEF VER100} override; {$ENDIF}
    { Public methods for params processing }
    function ParamByName(const Value: string): TParam;
    { Public methods for blob processing }
    function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
    { Other public methods }
    function GetActiveRecBuf(var Value: PRecordData): Boolean;
    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
    procedure DataEvent(Event: TDataEvent; Info: Longint); override;
    { File storing data methods }
    procedure SaveToStream(Stream: TStream);
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToFile(FileName: string);
    procedure LoadFromFile(FileName: string);
    { IndexDefs support methods }
    procedure GetIndexNames(List: TStrings);
    procedure FormKeyValues(var KeyFields: string; var KeyValues: Variant); virtual;

    { Public properties }
    property UpdatesPending: Boolean read GetUpdatesPending;
    property Active;
    property Sql: TStrings read GetSql write SetSql;
    property ReadOnly: Boolean read GetReadOnly write SetReadOnly;
    property DatabaseType: TZDatabaseType read FDatabaseType write FDatabaseType;
    property AutoOpen: Boolean read FAutoOpen;
    { Sql parameter properties }
    property Params: TParams read FParams write SetParamsList stored False;
    property ParamCheck: Boolean read FParamCheck write FParamCheck default True;
    property ParamCount: Word read GetParamsCount;
    { IndexDefs support properties }
    property IndexFieldCount: Integer read GetIndexFieldCount;
    property IndexFields[Index: Integer]: TField read GetIndexField write SetIndexField;
  published
    { General Sql properties }
    property Database: TZDatabase read FDatabase write SetDatabase;
    property Transaction: TZTransact read FTransact write SetTransact;
    property UpdateObject: TZUpdateSql read FUpdateObject write SetUpdateObject;
    property Version: Integer read FVersion;

    property CachedUpdates: Boolean read FCachedUpdates write FCachedUpdates;
    property ShowRecordTypes: TZUpdateRecordTypes read GetUpdateRecord
      write SetUpdateRecord;
    property Options: TZDatasetOptions read FOptions write SetOptions;
    { Master-detail support properties }
    property LinkFields: string read GetLinkFields write SetLinkFields;
    property LinkOptions: TZLinkOptions read FLinkOptions write FLinkOptions;
    property MasterSource: TDataSource read GetMasterDataSource
      write SetMasterDataSource;

    property FieldDefs stored False;
    property Constraints;

    { IndexDefs support properties }
    property IndexDefs: TIndexDefs read FIndexDefs write SetIndexDefs stored False;
    property IndexName: string read GetIndexName write SetIndexName;
    property IndexFieldNames: string read GetIndexFieldNames write SetIndexFieldNames;
    { New data update events }
    property OnApplyUpdateError: TDataSetErrorEvent read FOnApplyUpdateError
      write FOnApplyUpdateError;
    property OnUpdateRecord: TUpdateRecordEvent read FOnUpdateRecord
      write FOnUpdateRecord;
    { Progress event }
    property OnProgress: TZProgressEvent read FOnProgress write FOnProgress;
    { Inherited DataSet properties }
    property AutoCalcFields;
    property BeforeOpen;
    property AfterOpen;
    property BeforeClose;
    property AfterClose;
    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 OnCalcFields;
    property OnDeleteError;
    property OnEditError;
    property OnPostError;
    property OnFilterRecord;
    property OnNewRecord;
    property Filter;
    property Filtered;
    property FilterOptions;
  end;

  TZBCDField = class(TBCDField)
  protected