hbcore.pas

Midas.dll全部源码

{*******************************************************}
{                                                       }
{         Vladimir Gaitanoff HyperBase                  }
{                                                       }
{         Database Core                                 }
{                                                       }
{         Copyright (c) 1997,99 Vladimir Gaitanoff      }
{                                                       }
{*******************************************************}

{$I HB.INC}
{$D-,L-}

unit hbCore;

interface

uses Windows, ActiveX, hbIntf, hbTypes, Classes, ComObj,Variants,
vg3SysUtils, vg2BCDUtils,vg2CanExpr,vg2Classes;

type
  TDSCursor = class;

{ TDSBase }

  TDSBase = class(TComObject, IDSBase, IDSBase5, IDSWriter)
  private
    FFields: DSFLDDescList;
    FIndexes: DSIDXDescList;
    FCursor, FMDCursor, FAICursor: IDSCursor;
    FLastUsedIndex: Integer;

    FName: string;
    FRecBufSize: Integer;
    FRecords: TList;
    FCursors: TList;
    FChangeCount: Integer;
    FChanges: TList;
    FChangesDS, FChangesVL: TList;
    FBlobs: TList;

    FLogChanges: Boolean;
    FReadOnly, FStreamedReadOnly: Boolean;
    FIsDelta: Boolean;
    FNoMetaData: Boolean;
    FDSIsPartial: Boolean;
    FLCID: Integer;
    FBlobsInDelta: DWord;
    FMDOptions: DWord;
    FXMLStreamMode: DWord;

    FAutoIncDisabled: Boolean;
    FAutoIncCounter: Integer;

    FConstrDisabled: Boolean;

    FRecNoCounter: Integer;

    FNotifyDisableCount: Integer;

    { Calculated fields }
    FCiClientData: DWord;         { Client data }
    FCpfCalc     : pfDSCalcField; { Callback function, NULL to remove }

    { Attributes }
    FAttrInfos: TAttrInfos;

    { Reconcile }
    FRiClientData: DWord;
    FpfReconcile: pfDSReconcile;
    FResponses: TList;
    FRCursor: IDSCursor;

    { Constraints }
    FConstrErrorMsg: string;

    { Embedded datasets }
    FParentDS: TDSBase;
    FParentFieldNo: DWord;
    FChilds: DSBASEList;
    FLinkFieldNo: DWord;
    FLinkFieldCreated: Boolean;

    { Writer }
    FWHasMetaData, FWHasChildren: Boolean;
    FWDataSet: TDSBase;
    FWDataSetFieldNo: Integer;
    FWDataSetAttrInfos: PAttrInfos;
    FWStates: TList;
    FWRecNos: TList;
    FWStateReached: Boolean;
    FWChanges: TChangeInfos;
    FWFldDatas: TMemoryStream;

    FWFldDescs: TFldInfos;
    FWAttrInfos: TAttrInfos;

    FRecsWritten: TList;

    procedure AddFieldInternal(ParentID: Word; pFldDes: pDSFLDDesc;
      CreateEmbedded: Boolean);
    procedure GetFieldDescList(var AFields: DSFLDDescList; Recurse, Response: Boolean);

    { Streaming: reading }
    procedure WriterStart;
    procedure WriterCreateMetaData;
    procedure WriterApply;
    procedure WriterCreateRecord(Recs: TList; Index: Integer);
    procedure WriterFree;

    { Streaming: writing }
    procedure WriteColumn(const Writer: IDSWriter; var DescNo: Integer; DoWrite: Boolean);
    procedure WriteMetaData(const Writer: IDSWriter; Root: Boolean);
    procedure WriteChangeLog(const Writer: IDSWriter);

    procedure WriteDataSet(const Writer: IDSWriter; pRecBufM: PChar);
    procedure WriteField(const Writer: IDSWriter; pRecBuf: PChar; FieldNo: DWord);
    procedure WriteRecord(const Writer: IDSWriter; pRecBuf: PChar);

    procedure Clear;

    procedure CursorNeeded(var ACursor: IDSCursor);

    { Change log }
    procedure AddChange(Change: PChangeInfo);
    procedure DelChange(Change: PChangeInfo);
    function HasChangeEntry(RecNo: Integer): Boolean;
    procedure AddChangeDS(DataSet: TDSBase; Change: PChangeInfo);
    procedure DelChangeDS(DataSet: TDSBase; Change: PChangeInfo);
    procedure LogChange(RecAttr: DSAttr; OldSeqNo, NewSeqNo: Integer);
    procedure ClearChangeLog;
    function FindChangeEntry(var Start: Integer; NewSeqNo: Integer): PChangeInfo;
    procedure DestroyChangeEntry(var Change: PChangeInfo; Decrement: Boolean; DeltaRecs: TList = nil);
    procedure ClearParentChangeEntry(ParentSeqNo: Integer);
    procedure UndoChangeEntry(Change: PChangeInfo; var RecNo: Integer; Commited: Boolean);
    function InternalUndoLastChange(var RecNo: Integer; Commited: Boolean): DBResult;
    function UndoLastChange(var RecNo: Integer; Commited: Boolean): DBResult;

    procedure InsertCursor(ACursor: TDSCursor);
    procedure RemoveCursor(ACursor: TDSCursor);

    procedure DisableNotify;
    procedure EnableNotify;
    procedure NotifyCursors(Event: Integer; Data1, Data2, Data3: Integer);

    function InitRecord(pRecBuf: PChar): DBResult;
    procedure AllocRecord(var P: PChar);
    procedure FreeRecord(var P: PChar);
    procedure AssignFields(pRecDst, pRecSrc: PChar; ChangesOnly: Boolean = False; SkipLinks: Boolean = False);
    procedure CopyRecord(Source, Dest: PChar);

    procedure RemoveRecord(RecNo: DWord; pRecBuf: PChar = nil; DeltaRecs: TList = nil);
    function BlankNotChanged(pRecBuf, pRecOrg: PChar; CheckOnly: Boolean): Boolean;

    procedure CheckNotReadOnly;
    procedure CheckBlobFetched(pRecBuf: PChar; iFldNo: DWord);

    function RevertRecord(RecNo: Integer): DBResult;

    { Constraints }
    function GetMaxAutoInc(FieldNo: DWord): Integer;
    procedure CheckRequired(pRecBuf: PChar; AutoInc: Boolean);
    procedure CheckConstraints(pRecBuf, ConstrType: PChar; Defaults: Boolean);
    procedure CheckUnique(pRecBuf, pRecOrg: PChar);

    procedure CalculateFields(pRecBuf: PChar);
    procedure InternalInsertRecord(pRecBuf: PChar; var NewRecNo: Integer);
    function InsertRecord(pRecBuf: PChar; var NewRecNo: Integer; CommitTables: Boolean = True): DBResult;
    function ModifyRecord(RecNo: DWord; pRecBuf: PChar; var NewRecNo: Integer; CommitTables: Boolean = True; Detail: Boolean = True): DBResult;
    function DeleteRecord(RecNo: DWord): DBResult;

    function GetRecord(RecNo: DWord; pRecBuf: PChar): DBResult;
    procedure GetRecordOrg(RecNo: DWord; var OrgRecNo: DWord; pRecBuf: PChar = nil);
    function GetRecordPtr(RecNo: Integer): PChar;

    function GetField(pRecBuf: Pointer; iFieldNo: DWord;
      pFldBuf: Pointer; var bBlank: Bool): DBResult;

    procedure PutFieldBuff(pRecBuf: Pointer; iFieldNo: DWord; pFldBuf: Pointer);

    function PutFieldInternal(pRecBuf: Pointer; iFieldNo: DWord;
      pFldBuf: Pointer): DBResult;
    function PutField(pRecBuf: Pointer; iFieldNo: DWord;
      pFldBuf: Pointer): DBResult;

    procedure PutBlankParent(pRecBuf: PChar; iFldNo: DWord);
    procedure PutBlankValues(pRecBuf: Pointer; iFldNo, iBlankValue: DWord);
    procedure PutBlankInternal(pRecBuf: Pointer; iFldNo, iBlankValue: DWord);

    procedure CommitRecord(pRecBuf: PChar; CommitTables: Boolean = True);

    function GetBlobLen(pRecBuf: Pointer; iFieldNo: DWord;
      var iLength: DWord): DBResult;
    function GetBlob(pRecBuf: Pointer; iFieldNo, iOffSet: DWord;
      pBuf: Pointer; var iLength: DWord): DBResult;
    function PutBlobInternal(pRecBuf: Pointer; iFieldNo, iOffSet: DWord;
      pBuf: Pointer; iLength: DWord): DBResult;
    function PutBlob(pRecBuf: Pointer; iFieldNo, iOffSet: DWord;
      pBuf: Pointer; iLength: DWord): DBResult;

    procedure CheckInactiveIndex(szName: PChar);
    function FindIndex(pszName: PChar): Integer;
    procedure GetIndexDesc(IndexNo: DWord; p1: PDSIDXDesc);
    procedure UpdateLinkedIndex(var IdxDesc: DSIDXDesc);

    { Comparing records }
    function FldCmpEx(iFldType: DWord; pFld1, pFld2: Pointer; iUnits1,
      iUnits2: DWord; CaseIns: Bool): Integer;
    function CmpRecsEx(IndexDS: pDSIDXDesc; iFields, iPartLen: Integer;
      pRec1, pRec2: PChar): Integer;

    procedure CalcKeySize(var IndexDS: DSIDXDesc);
    function ExtractKey(pRecBuf, pKeyBuf: PChar; const IndexDS: DSIDXDesc): DBResult;

    { Delta & Reconcile }
    procedure GetDeltaRecords(pRecBufM: PChar; Recs: TList);
    procedure InitDelta(Delta: TDSBase; pRecBufM, pRecBufM2: PChar; BlobsInDelta: DWord);
    procedure MergeRecord(Attr: DSAttr; RecNo: DWord; pNewRec: PChar; DeltaRecs: TList);
    procedure ClearChanges(Attr: DSAttr; RecNo: DWord; pRecOrg: PChar = nil; DeltaRecs: TList = nil; RollingBack: Boolean = False);
    function GetResponses(DeltaDS, ErrorDS: TDSBase; FieldNums: TList;
      iClientData: DWord; pfReconcile_MD: pfDSReconcile_MD): Boolean;
    procedure MergeRecords(DeltaDS: TDSBase);

    function ReconcileCallback(iRslt: Integer; iUpdateKind: DSAttr;
      iResAction: dsCBRType; iErrCode: Integer; pErrMessage, pErrContext: PChar;
      pRecUpd, pRecOrg, pRecConflict: Pointer; iLevels: Integer;
      piFieldIDs: PInteger): dsCBRType; stdcall;

      { Refresh record }
    procedure AppendChildren(pRecBuf: PChar; Source: TDSBase);

    function GetRowRequestPacket(   { Get packet describing the curent 'path',
                                      for delayed fetching/refreshing }
        RecNo           : DWord;
        IndexDS         : pDSIDXDesc;
        bKeysOnly       : Bool;     { Only include unique keys in packet }
        bFetchAllBlobs  : Bool;     { fetch all blobs for 'current'record }
        bFetchAllDetails: Bool;     { fetch all details for 'current' record }
        bInclMetaData   : Bool;     { Include metadata in packet }
        out Packet      : PSafeArray{ returns datapacket with row description }
    ): DBResult; stdcall;
    
    { Embedded datasets }

    procedure CreateEmbeddedDS(Index: Integer);
    function GetEmbeddedDSBase(iFieldNo: DWord): TDSBase;
    function GetEmbeddedDSBaseByDescNo(DescNo: Integer): TDSBase;
    function GetParentSeqNo(pRecBuf: PChar): DWord;
  protected
    { IDSBase }

    function Create(                { Create empty dataset }
        iFields  : DWord;           { Number of fields }
        pFldDes  : pDSFLDDesc;      { Array of field descriptors }
        pszName  : PChar            { Name (optional) }
    ): DBResult; overload; stdcall;

    function AddField(              { Add a field to the dataset }
        pFldDes  : pDSFLDDesc       { Field descriptor }
    ): DBResult; stdcall;

    function AppendData(            { Appends data packet to dataset. }
        Packet   : PSafeArray;      { Data packet }
        bEof     : Bool             { If True, this is last packet }
    ): DBResult; stdcall;

    function GetOptParameter(       { Returns optional parameter (unknown to dataset) }
        iNo      : DWord;           { Number 1..iOptAttr }
        iFldNo   : DWord;           { 0 if not field attribute }
    var ppName   : Pointer;         { returns ptr to name }
    var piType   : DWord;           { returns type }
    var piLen    : DWord;           { returns length }
    var ppValue  : Pointer          { returns ptr to value }
    ): DBResult; stdcall;

    function AddOptParameter(       { Adds optional parameter to dataset }
        iFldNo   : DWord;           { 0 if not field attribute }
        pszAttr  : PChar;           { ptr to name }
        iType    : DWord;           { type }
        iLen     : DWord;           { length }
        pValue   : Pointer          { ptr to value }
    ): DBResult; stdcall;

    function GetProps(              { Get dataset properties }
    var Prop : DSProps
    ): DBResult; stdcall;

    function GetFieldDescs(         { Get field descriptors }
        Fields  : pDSFLDDesc        { Array of fields descriptors (output) }
    ): DBResult; stdcall;

    function GetIndexDescs(         { Get index descriptors }
        p1: PDSIDXDesc              { Array of index descriptors (output) }
    ): DBResult; stdcall;

    function GetDelta(              { Extract delta from dataset }
    out DsDelta: IDSBase            { Delta in a dataset }
    ): DBResult; stdcall;

    function StreamDS(              { Create data packet from the dataset }
    out Packet  : PSafeArray        { Return data packet }
    ): DBResult; stdcall;

    function AcceptChanges: DBResult; stdcall; { Accept all current changes }

    function PutBlank(              { Put blank value }
        pRecBuf      : Pointer;     { RecBuf OR }
        iRecNo       : DWord;       { iRecNo }
        iFldNo       : DWord;
        iBlankValue  : DWord
    ): DBResult; stdcall;

    function CreateIndex(           { Create, and add an index }
    const IdxDesc  : DSIDXDesc
    ): DBResult; stdcall;

    function RemoveIndex(           { Remove index of given name }
        pszName  : PChar
    ): DBResult; stdcall;

    function GetErrorString(        { Retrieve error string }
        iErrCode  : DBResult;
        pString   : PChar
    ): DBResult; stdcall;

    function FldCmp(                { Compare field values returns 0 if equal }
        iFldType  : DWord;          { Fieldtype }
        pFld1     : Pointer;        { NULL if blank }
        pFld2     : Pointer;        { NULL if blank }
        iUnits1   : DWord;
        iUnits2   : DWord
    ): Integer; stdcall;

    function GetProp(               { Get property }
        eProp       : DSProp;
        piPropValue : Pointer
    ): DBResult; stdcall;

    function SetProp(               { Set property }
        eProp      : DSProp;
        iPropValue : DWord
    ): DBResult; stdcall;

    function SetFieldCalculation(   { Register fieldcalculation on this field }
        iClientData  : DWord;       { Client data }
        pfCalc       : pfDSCalcField { Callback function, NULL to remove }
    ): DBResult; stdcall;

    function Reconcile(             { Reconcile update errors }
        DeltaPacket   : PSafeArray; { Delta data packet }
        ErrorPacket   : PSafeArray; { NULL if all changes accepted }
        iClientData   : DWord;
        pfReconcile   : pfDSReconcile { Callback-fn (called for each error) }
    ): DBResult; stdcall;

    { Place Holders for aggregate functions that were moved into DSCursor }
    function Reserved1(Input: Pointer): DBResult; stdcall;
    function Reserved2(Input: Pointer): DBResult; stdcall;
    function Reserved3(Input: Pointer): DBResult; stdcall;

    function Refresh(               { Refresh dataset }
        NewPacket    : PSafeArray;  { New updated packet }
        iClientData  : DWord;       { Client data }
        pfReconcile  : pfDSReconcile { Callback for resolving conflicts }
    ): DBResult; stdcall;

    function Reset: DBResult; overload; stdcall; { Remove all data from dataset }

    function RollBack(              { Rollback changes to this savepoint }
        iSavePoint  : SAVEPOINT
    ): DBResult; stdcall;

    function GetEmbeddedDS(
        iFieldID  : DWord;          { FieldID of embedded table (0 : get the first one) }
    out DsDet     : IDSBase         { Returns the ds of the embedded table }
    ): DBResult; stdcall;

    function MakeEmbedded(
        DsDet             : IDSBase;  { Embed this dataset }
        iFieldsLink       : DWord;
        piFieldsM         : PDWord;   { Fields in Master }
        piFieldsD         : PDWord;   { Fields in Detail }
        pMasterFieldName  : PChar;    { Name of new link field in master, NULL if using default name }
        pDetailFieldName  : PChar     { Name of new link field in detail, NULL if using defaultname }
    ): DBResult; stdcall;

    function RefreshRecords(            { Refresh specific records }
        NewDataPacket   : PSafeArray;   { Datapacket containing refreshed records }
        iRecNo          : DWord;        { Refresh this specific record (0 if more than one.Unique key req.) }
        iClientData     : DWord;
        pfReconcile     : pfDSReconcile { (NULL) Callback for resolving conflicts }
    ): DBResult; stdcall;

    function ReleaseBlobs(          { Release all uncommitted blobs }
        iBlobId  : DWord            { 0: all uncommitted blobs, otherwise : specific blob }
    ): DBResult; stdcall;

    function Clone(                 { Clones the structure of the dsbase, including details if any }
         iPType : DWord;            { 0:normal-ds, 1:delta-ds, 2:error-ds }
         bRecurse : Bool;           { TRUE:create complete tree-structure }
         bCloneOptParams: Bool;     { TRUE:clone all optional parameters (normal only) }
         var DataSet: IDSBase       { Returned dsbase }
    ): DBResult; stdcall;

    function Reconcile_MD(
        pDsRec          : IDSBase;           { Ds for info }
        pDeltaPacket    : PSafeArray;        { Delta pickle }
        pErrorPacket    : PSafeArray;        { NULL if all changes accepted }
        iClientData     : DWord;
        pfReconcile_MD  : pfDSReconcile_MD   { Callback-fn (called for each error) }
    ): DBResult; stdcall;

    { IDSWriter }

    function Init_Sequential(   { Initialze by sequentially adding columns }
        Version: DWord;
        Columns: Word
    ): DBResult; stdcall;

    function Init(
        Version: DWord;
        Columns: Word;
        FieldDesc: PDSDataPacketFldDesc
    ): DBResult; stdcall;