dsintf.pas

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

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

    function LinkCursors(
        iFieldsM   : LongWord;
        piFieldsM  : PLongWord;         { Fields in Master }
        piFieldsD  : PLongWord;         { 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  : LongWord         { Property value (or pointer to value) }
    ): DBResult; stdcall;

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


    function GetRowRequestPacket(   { Get packet describing the curent 'path',
                                      for delayed fetching/refreshing }
        bKeysOnly       : LongBool;     { Only include unique keys in packet }
        bFetchAllBlobs  : LongBool;     { fetch all blobs for 'current'record }
        bFetchAllDetails: LongBool;     { fetch all details for 'current' record }
        bInclMetaData   : LongBool;     { 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;

  end;

{ IDSWriter }

  IDSWriter = interface(IUnknown)
    ['{9E8D2FA6-591C-11D0-BF52-0020AF32BD64}']

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

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

    function AddAttribute(      { Add an optional parameter }
        AttrArea: TPcktAttrArea;
        Attr: PChar;
        AttrType: LongWord;
        Len: LongWord;
        Value: 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: LongWord
    ): DBResult; stdcall;


    function PutField(          { Add this field to the data stream. }
        FldStatus: TPcktFldStatus;
        Len: LongWord;
        Src: Pointer
    ): DBResult; stdcall;

    function AddColumnDesc(     { Add a column descriptor. }
      const FldDes: 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 Reset: DBResult; stdcall;

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

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


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

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

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

   function SetXMLMode(iMode: Integer): DBResult; stdcall;

   function GetXMLMode: LongWord; stdcall;

  end;

const
  CLSID_DSBase: TGUID   = '{9E8D2FA1-591C-11D0-BF52-0020AF32BD64}';
  CLSID_DSCursor: TGUID = '{9E8D2FA3-591C-11D0-BF52-0020AF32BD64}';
  CLSID_DSWriter: TGUID = '{9E8D2FA5-591C-11D0-BF52-0020AF32BD64}';

{ Utility Routines }
procedure FreeDataPacket(var DataPacket: TDataPacket);
function VarToDataPacket(const V: OleVariant): TDataPacket;
function DataPacketSize(const DataPacket: TDataPacket): Integer;
procedure DataPacketToVariant(const DataPacket: TDataPacket; var V: OleVariant);
procedure CreateDbClientObject(const CLSID, IID: TGUID; out Obj);
function VariantArrayToString(const V: OleVariant): string;
function StringToVariantArray(const S: string): OleVariant;

procedure RegisterMidasLib(GetClassProc: Pointer);

implementation

{$IFDEF MSWINDOWS}
uses ComObj, MidConst, SysUtils;
{$ENDIF}
{$IFDEF LINUX}
uses MidConst, SysUtils, Types;
{$ENDIF}

{ Utility Routines }

var
  Loading: TRTLCriticalSection;
  DbClientHandle: THandle = THandle(0);
  DllGetClassObject: function(const CLSID, IID: TGUID; var Obj): HResult; stdcall;

{$IFDEF MSWINDOWS}
procedure CheckDbClient(const CLSID: TGUID);
var
  Size: Integer;
  FileName: string;
begin
  if DbClientHandle = 0 then
  begin
    EnterCriticalSection(Loading);
    try
      if DbClientHandle = 0 then
      begin
        Size := 256;
        SetLength(FileName, Size);
        if RegQueryValue(HKEY_CLASSES_ROOT, PChar(Format('CLSID\%s\InProcServer32',
          [GUIDToString(CLSID)])), PChar(FileName), Size) = ERROR_SUCCESS then
          SetLength(FileName, Size) else
        begin
          FileName := MIDAS_DLL;
          try
            RegisterComServer(FileName);
          except
          end;
        end;
        DbClientHandle := LoadLibrary(PChar(FileName));
        if DbClientHandle = 0 then
          raise Exception.CreateRes(@SErrorLoadingMidas);

        DllGetClassObject := GetProcAddress(DbClientHandle, 'DllGetClassObject');
      end;
    finally
      LeaveCriticalSection(Loading);
    end;
  end;
end;
{$ENDIF}
{$IFDEF LINUX}
procedure CheckDbClient(const CLSID: TGUID);
begin
   DbClientHandle := THandle(dlopen(SMidasLib, 0));
   if DbClientHandle <> 0 then
     DllGetClassObject := dlsym(Pointer(DbClientHandle), 'DllGetClassObject')
   else
     raise Exception.Create(dlerror);
end;
{$ENDIF}

procedure CreateDbClientObject(const CLSID, IID: TGUID; out Obj);
var
  Factory: IClassFactory;
begin
  CheckDbClient(CLSID);
  DllGetClassObject(CLSID, IClassFactory, Factory);
  Factory.CreateInstance(nil, IID, Obj);
end;

procedure FreeDataPacket(var DataPacket: TDataPacket);
begin
  if Assigned(DataPacket) then
  begin
    SafeArrayCheck(SafeArrayDestroy(DataPacket));
    DataPacket := nil;
  end;
end;

function VarToDataPacket(const V: OleVariant): TDataPacket;
begin
  if VarIsNull(V) then Result := nil else
  begin
    if not (VarIsArray(V) and (VarArrayHighBound(V, 1) > 20)) then
      DatabaseError(SInvalidDataPacket);
{$IFDEF MSWINDOWS}
    Result := tagVARIANT(V).PArray;
{$ENDIF}
{$IFDEF LINUX}
    Result := (TVarData(V)).VArray;
{$ENDIF}
  end;
end;

function DataPacketSize(const DataPacket: TDataPacket): Integer;
begin
  SafeArrayCheck(SafeArrayGetUBound(DataPacket, 1, Result));
  Inc(Result);
end;

procedure DataPacketToVariant(const DataPacket: TDataPacket; var V: OleVariant);
begin
  if Assigned(DataPacket) then
  begin
    VarClear(V);
{$IFDEF MSWINDOWS}
    tagVariant(V).vt := varByte or varArray;
    tagVariant(V).PArray := DataPacket;
{$ENDIF}
{$IFDEF LINUX}
    TVarData(V).VType := varByte or varArray;
    TVarData(V).VArray := DataPacket;
{$ENDIF}
  end else
    V := NULL;
end;

function VariantArrayToString(const V: OleVariant): string;
var
  P: Pointer;
  Size: Integer;
begin
  Result := '';
  if VarIsArray(V) and (VarType(V) and varTypeMask = varByte) then
  begin
    Size := VarArrayHighBound(V, 1) - VarArrayLowBound(V, 1) + 1;
    if Size > 0 then
    begin
      SetLength(Result, Size);
      P := VarArrayLock(V);
      try
        Move(P^, Result[1], Size);
      finally
        VarArrayUnlock(V);
      end;
    end;
  end;
end;

function StringToVariantArray(const S: string): OleVariant;
var
  P: Pointer;
begin
  Result := NULL;
  if Length(S) > 0 then
  begin
    Result := VarArrayCreate([0, Length(S) - 1], varByte);
    P := VarArrayLock(Result);
    try
      Move(S[1], P^, Length(S));
    finally
      VarArrayUnlock(Result);
    end;
  end;
end;

procedure RegisterMidasLib(GetClassProc: Pointer);
begin
  DllGetClassObject := GetClassProc;
  DbClientHandle := THandle(1);
end;



{$IFDEF LINUX}

function HandleSafeCallException(ExceptObject: TObject;
  ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID,
  HelpFileName: WideString): HResult;
begin
  Result := 0;
end;

{$ENDIF}

initialization
  InitializeCriticalSection(Loading);
finalization
{$IFDEF MSWINDOWS}
  if DbClientHandle > 32 then FreeLibrary(DbClientHandle);
{$ENDIF}
{$IFDEF LINUX}
  if DbClientHandle > 0 then dlclose(Pointer(DbClientHandle));
{$ENDIF}
  DeleteCriticalSection(Loading);
end.