hbcore.pas

Midas.dll全部源码

    function AddAttribute(      { Add an optional parameter }
        AAttrArea: TPcktAttrArea;
        AAttr: PChar;
        AAttrType: DWord;
        ALen: DWord;
        AValue: Pointer
    ): DBResult; stdcall;

    function GetDataPacket(     { Return pointer to the finished 'safearray' }
    var SA: PSafeArray
    ): DBResult; stdcall;

    function GetSize(           { Get the size of the safearray. }
    var DataPacketSize: DWord
    ): DBResult; stdcall;

    function IDSWriter.PutField = WriterPutField;          { Add this field to the data stream. }

    function WriterPutField(          { Add this field to the data stream. }
        AFldStatus: TPcktFldStatus;
        ALen: DWord;
        ASrc: Pointer
    ): DBResult; stdcall;

    function AddColumnDesc(     { Add a column descriptor. }
      const AFldDes: TDSDataPacketFldDesc
    ): DBResult; stdcall;

    { Reset all data (in order to create partial data).  Datapackets will not
      contain meta-info. Last created datapacket must be released by caller. }
    function IDSWriter.Reset = WriterReset;

    function WriterReset: DBResult; stdcall;

    { Return number of fielddescriptors, including embedded tables etc. }

    function GetColumnCount(var Count: DWord): DBResult; stdcall;

    function GetColumnDescs(    { Return all fielddescriptors }
        FieldDes: PDSDataPacketFldDesc
    ): DBResult; stdcall;

    function IDSWriter.GetErrorString = GetErrorString;

   { Signals last row for a nested table, in case rowcount was not known
     in advance }
   function EndOfNestedRows: DBResult; stdcall;


  public
    procedure Initialize; override;
    destructor Destroy; override;
  end;

{ TDSCursor }

  TDSCursor = class(TComObject, IDSCursor, IDSCursor5)
  private
    FIndexDS: DSIDXDesc;
    FDSBase: TDSBase;
    FIsDelta: Boolean;
    FIDSBase: IDSBase;
    FFields: DSFLDDescList;
    FRecNums: TList;
    FRecPos: Integer;
    FInUndo: Boolean;
    FDefaultOrder, FChangeIndex: Boolean;
    FCrack: Boolean;

    { Range }
    FKeyFields: DWord;
    FKeyRec1, FKeyRec2: PChar;
    FKeyRec1Incl, FKeyRec2Incl: Boolean;

    { Filters }
    FExprEval: Tvg2ExprEvaluator;
    FFClientData: DWord;       { Client supplied data }
    FFFilter: pfDSFilter;      { ptr to filter function }

    { Change callback }
    FCNClientData: DWord;
    FCNCallBack: pfCHANGECallBack;

    { Aggregates }
    FAggs, FAggsValid: TList;

    { Linked cursors }
    FMaster: TDSCursor;
    FMasterRecBuf: PChar;
    FDetails: TList;
    FFieldsM: DWordList;
    FFieldsD: DWordList;

    { Records and their order }
    function CurrentSeqNo: DWord;
    procedure SetRecPos(Value: Integer);

    function AcceptsRecord(pRecBuf: PChar): Boolean;

    { Records and order }
    procedure CheckIndexed;
    procedure CheckIndexWritable;

    function InternalMoveToKey(SearchCond: DBSearchCond; iFields,
      iPartLen: DWord; pKeyBuf, pRecBuf: Pointer; var RecNo: Integer): DBResult;
    function InsertRecNo(RecNo: Integer): Integer;
    procedure RemoveRecNo(RecNo: Integer);

    procedure Clear;
    procedure Rebuild;
    procedure Sort;

    procedure CheckCursorPos;
    procedure UpdateCursorPos;

    procedure RangeDropped;
    procedure NotifyChanged;
    procedure Notify(const Event, Data1, Data2, Data3: Integer);

    { Comparing records }
    function CmpRecsIndexEx(pRec1, pRec2: PChar; iFields: DWord): Integer;
    function CmpRecsIndex(pRec1, pRec2: PChar): Integer;
    function CmpRecsIndexDef(pRec1, pRec2: PChar): Integer;

    function GetCurrentRecordPtr(var pRecBuf: PChar): DBResult;

    { Aggregates }
    procedure GetAggBounds(iFields: Integer; RecNo: DWord; var R1, R2: DWord);
    procedure InvalidateAggs;

    { Linked cursors }
    procedure CheckFetched;
    procedure InsertCursor(ACursor: TDSCursor);
    procedure RemoveCursor(ACursor: TDSCursor);
    procedure ResyncDetails;

    property RecPos: Integer read FRecPos write SetRecPos;
  protected

    function InitCursor(            { Associate Cursor with a DataSet }
       DataSet: IDSBase
    ): DBResult; stdcall;

    function CloneCursor(           { Clone cursor from cursor }
       Cursor: IDSCursor
    ): DBResult; stdcall;

    function GetCursorProps(        { Get cursor properties }
    var p1: DSProps
    ): DBResult; stdcall;

    function GetIndexDescs(         { Get index descriptors }
        bCurrentOnly  : Bool;       { Only return 'current' indexdesc, otherwise all }
    var IdxDesc       : DSIDXDesc
    ): DBResult; stdcall;

    function GetFieldDescs(         { Get field descriptors }
        p1  : pDSFLDDesc
    ): DBResult; stdcall;

    function GetCurrentRecord(      { Return record at current cursorposition }
        pRecBuf  : Pointer
    ): DBResult; stdcall;

    function GetRecordBlock(        { Return block of records }
        piRecs   : PDWord;
        pRecBuf  : Pointer
    ): DBResult; stdcall;

    function GetCurrentBookMark(    { Get bookmark for current position }
        pBookMark  : Pointer
    ): DBResult; stdcall;

    function GetSequenceNumber(     { Get Sequence number of current position }
    var iSeq  : DWord
    ): DBResult; stdcall;

    function GetRecordAttribute(    { Get record attribute of current position }
    var Attr  : DSAttr
    ): DBResult; stdcall;

    function GetRecordCount(        { Number of records in active view }
    var iRecs  : Integer
    ): DBResult; stdcall;

    function MoveToBOF: DBResult; stdcall; { Set to beginning of table (BOF) }

    function MoveToEOF: DBResult; stdcall; { Set to end of table (EOF) }

    function MoveRelative(i: Integer): DBResult; stdcall;

    function MoveToSeqNo(i: DWord): DBResult; stdcall;

    function MoveToBookMark(        { Goto bookmark }
      pBookMark: Pointer
    ): DBResult; stdcall;

    function MoveToKey(             { Goto key }
        SearchCond  : DBSearchCond;
        iFields     : DWord;
        iPartLen    : DWord;
        pRecBuf     : Pointer
    ): DBResult; stdcall;

    function CompareBookMarks(      { Compare two bookmark (positions) -1, 0, 1 }
        pBookMark1  : Pointer;
        pBookMark2  : Pointer;
    var iCmp        : Integer
    ): DBResult; stdcall;

    function ExtractKey(            { Extract key from record }
        pRecBuf  : Pointer;
        pKeyBuf  : Pointer
    ): DBResult; stdcall;

    function GetRecordForKey(       { Return (first) record with given key }
        iFields   : DWord;
        iPartLen  : DWord;
        pKey      : Pointer;
        pRecBuf   : Pointer
    ): DBResult; stdcall;

    function GetField(              { Extract field value from record buffer }
        pRecBuf   : Pointer;
        iFieldNo  : DWord;
        pFldBuf   : Pointer;
    var bBlank    : Bool            { Returns TRUE/FALSE if blank }
    ): DBResult; stdcall;

    function PutField(              { Put field value into record buffer }
        pRecBuf   : Pointer;
        iFieldNo  : DWord;
        pFldBuf   : Pointer         { If NULL, adds a blank value }
    ): DBResult; stdcall;

    { Blob functions }

    function GetBlobLen(            { Return length of blob }
        pRecBuf   : Pointer;
        iFieldNo  : DWord;
    var iLength   : DWord
    ): DBResult; stdcall;

    function GetBlob(               { Return blob }
        pRecBuf   : Pointer;
        iFieldNo  : DWord;
        iOffSet   : DWord;          { Starting position }
        pBuf      : Pointer;
    var iLength   : DWord          { No of bytes to be read/ returns number read }
    ): DBResult; stdcall;

    function PutBlob(               { Write blob data }
        pRecBuf   : Pointer;
        iFieldNo  : DWord;
        iOffSet   : DWord;          { Starting position }
        pBuf      : Pointer;
        iLength   : DWord
    ): DBResult; stdcall;

    function InitRecord(            { Initialize record buffer (for insertion) }
        pRecBuf  : Pointer
    ): DBResult; stdcall;

    function DeleteRecord: DBResult; stdcall; { Delete current record }

    function ModifyRecord(          { Modify current record }
        pRecBuf  : Pointer
    ): DBResult; stdcall;

    function InsertRecord(          { Insert new record }
        pRecBuf  : Pointer
    ): DBResult; stdcall;

    function UndoLastChange(        { Undo last update }
        bFollowChange  : Bool
    ): DBResult; stdcall;

    function AddFilter(             { Add a canexpr-filter to this cursor }
        pcanExpr  : Pointer;        { Can expr }
        iLen      : DWord;          { Length of canexpr }
    var hFilter   : hDSFilter
    ): DBResult; stdcall;

    function DropFilter(            { Drop a filter }
       hFilter  : hDSFilter
    ): DBResult; stdcall;

    function SetRange(              { Set a range on a cursor }
        iFields    : DWord;
        pKey1      : Pointer;
        bKey1Incl  : Bool;
        pKey2      : Pointer;
        bKey2Incl  : Bool
    ): DBResult; stdcall;

    function DropRange: DBResult; stdcall; { Remove current range }

    function SortOnFields(          { Sort on fields }
        iFields    : DWord;
        piFields   : PDWord;        { NULL -> all fields }
        pDescending: PBool;         { NULL -> all ascending }
        pCaseInsensitive: PBool     { NULL -> all case-sensitive }
    ): DBResult; stdcall;

    function UseIndexOrder(         { Switch to index order }
        pszName  : PChar
    ): DBResult; stdcall;

    function SetNotifyCallBack(     { Called when posting changes to dataset }
        iClientData  : DWord;
        pfCallBack   : pfCHANGECallBack   { Call back fn being registered }
    ): DBResult; stdcall;

    function AddFilterCallBack(     { Add a canexpr-filter to this cursor }
        iClientData  : DWord;     { Client supplied data }
        pfFilter     : pfDSFilter;  { ptr to filter function }
    var hFilter      : hDSFilter
    ): DBResult; stdcall;

    function VerifyField(           { Verify if field value is valid }
        iFieldNo  : DWord;
        pFldBuf   : Pointer
    ): DBResult; stdcall;

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

    function RevertRecord: DBResult; stdcall; { Restore current record }

    function LocateWithFilter(
        pCanExpr  : Pointer;        { NULL -> use previous }
        iLen      : DWord           { Length of canexpr }
    ): DBResult; stdcall;

    function AddAggregate(
        iFlds     : DWord;          { Defines grouping  (0 if global) }
        iCanLen   : DWord;          { Length of canexpr (0 if grouping only) }
        pCanExpr  : Pointer;        { Canexpression for aggregate }
    var hAgg      : hDSAggregate    { returns aggregate handle }
    ): DBResult; stdcall;

    function DropAggregate(
        hAgg  : hDSAggregate
    ): DBResult; stdcall;

    function GetAggregateValue(
        hAgg     : hDSAggregate;
        pValue   : Pointer;
    var bBlank   : Bool
    ): DBResult; stdcall;

    function GetAggregateDesc(
        hAgg   : hDSAggregate;
    var Desc   : DSFLDDesc
    ): DBResult; stdcall;

    function MoveToNextSubGroup(
        iFields  : DWord
    ): DBResult; stdcall;

    function GetSubGroupState(
        iFields        : DWord;
    var iSubGroupState : GROUPSTATE
    ): DBResult; stdcall;

    function LinkCursors(
        iFieldsM   : DWord;
        piFieldsM  : PDWord;         { Fields in Master }
        piFieldsD  : PDWord;         { Fields in Detail }
        hCurDet    : IDSCursor       { Detail cursor to link }
    ): DBResult; stdcall;

    function ResyncWithMaster: DBResult; stdcall; { If this is a detail, reset range }

    function SetProp(               { Set property }
        eProp       : CURProp;      { Property to set }
        iPropValue  : DWord         { Property value (or pointer to value) }
    ): DBResult; stdcall;

   function GetRecordNumber(  { Return record number of current record, if any }
        var iRecNo: DWord
    ): DBResult; stdcall;


    function GetRowRequestPacket(   { Get packet describing the curent 'path',
                                      for delayed fetching/refreshing }
        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;

   function RefreshRecord( { Refresh details/blobs for this record, and all
                             'current' records above, if any }
        Packet  : PSafeArray        { New updated pickle }
    ): DBResult; stdcall;

  public
    procedure Initialize; override;
    destructor Destroy; override;
  end;

const
  Counter: Integer = 0;

implementation
uses SysUtils, hbCLSID, hbConsts, hbErrors, hbUtils, hbStream;

function BaseFromIDS(Base: IDSBase): TDSBase;
begin
  Base.GetProp(DSProp(-1), @Result);
end;

function CursorFromIDS(Cursor: IDSCursor): TDSCursor;
begin
  Cursor.GetProp(CURProp(-1), @Result);
end;

function CreateDSBase: IDSBase;
begin