hbstream.pas

Midas.dll全部源码

{*******************************************************}
{                                                       }
{         Vladimir Gaitanoff HyperBase                  }
{                                                       }
{         Streaming support                             }
{                                                       }
{         Copyright (c) 1997,99 Vladimir Gaitanoff      }
{                                                       }
{*******************************************************}

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

unit hbStream;

interface
uses Windows, ActiveX, ComObj, hbIntf, Classes, hbXML,RTLConsts;

type
  TPacketData = (pdFldDesc, pdAttr, pdFldVal, pdFldValDelayed, pdEofNestedRows);

  TDSDataPacketFldDescList = array of TDSDataPacketFldDesc;

{ TDSWriter }

  TDSWriter = class(TComObject, IDSWriter, IDSWriter5)
  private
    FFieldDescs: TDSDataPacketFldDescList;
    FStates: array of Word;
    FParentCols, FChildNums: array of Integer;
    FColumns: Word;
    FVersion: DWord;
    FStream: TMemoryStream;
    FXMLWriter: TXMLWriter;
    FXMLMode: DWord;
    FXMLMetaDataTag, FXMLRowDataTag: Integer;
    FXMLColumn: Word;
    procedure Clear;
    procedure WriteHeader;
    procedure WritePacketData(PacketData: TPacketData);
    procedure WriteBuffer(const Buff; Count: Integer);
  protected

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

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

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

    function PutField(          { Add this field to the data stream. }
        FldStatus: TPcktFldStatus;
        Len: DWord;
        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: DWord): 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;

    { IDSWriter5 }

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

    function GetXMLMode: DWord; stdcall;

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

  IDSReader = interface (IUnknown)
    ['{9E8D2F96-591C-11D0-BF52-0020AF32BD65}']
    function ReadDataPacket(Writer: IDSWriter; SA: PSafeArray): DBResult; stdcall;
  end;

{ TDSReader }
  TDSReader = class(TComObject, IDSReader)
  private
    procedure ReadBinaryPacket(Stream: TStream; Writer: IDSWriter);
    procedure ReadXMLPacket(Stream: TStream; Writer: IDSWriter);
  protected
    function ReadDataPacket(Writer: IDSWriter; SA: PSafeArray): DBResult; stdcall;
  end;

const
  SDataPacket     = 'DATAPACKET';
  SMetaData       = 'METADATA';
  SFields         = 'FIELDS';
  SField          = 'FIELD';
  SParams         = 'PARAMS';
  SRowData        = 'ROWDATA';
  SRow            = 'ROW';
  SRowState       = 'RowState';
  SVersion        = 'Version';
  SAttrName       = 'attrname';
  SFieldType      = 'fieldtype';
  SUniExt         = '.uni';

  STrue           = 'TRUE';
  SFalse          = 'FALSE';

implementation
uses Consts, SysUtils, vg2BCDUtils, hbErrors, hbUtils, hbTypes,vg3SysUtils,vg2Classes;

const
  pktSign         = 'HyperBase data stream'#13#10#0;
  XMLSign         = '<?xml version="1.0" standalone="yes"?>';

  XMLFieldTypes: array [fldZSTRING..fldTABLE] of string = (
    'string', 'date', 'bin.hex', 'boolean', 'i2', 'i4', 'r8',
    'fixed', 'bin.hex', 'time', 'dateTime', 'ui2', 'ui4', '',
    'bin.hex', '', '', '', '', '', '', '' { Ref }, 'nested');

function GetFieldTypeStr(iFieldType: Integer): string;
var
  FldType, Len: Integer;
begin
  FldType := FieldTypeMap[(iFieldType and dsTypeBitsMask) shr dsSizeBitsLen];
  case FldType of
    fldUNKNOWN:
      HBError(DBERR_NOTSUPPORTED);
    fldINT32:
      begin
        Len := (iFieldType and dsSizeBitsMask);
        if Len = SizeOf(SmallInt) then
          FldType := fldINT16 else
        if Len = SizeOf(Int64) then
          HBError(DBERR_NOXMLDATATYPE);
      end;
    fldUINT32:
      begin
        Len := (iFieldType and dsSizeBitsMask);
        if Len = SizeOf(SmallInt) then
          FldType := fldUINT16 else
        if Len = SizeOf(Int64) then
          HBError(DBERR_NOXMLDATATYPE);
      end;
    fldFLOAT:
      ;
    fldBCD:
      ;
    fldZSTRING, fldUNICODE:
      ;
    fldBLOB:
      ;
    fldDATE, fldBOOL, fldTIME, fldTIMESTAMP:
      ;
    fldADT, fldARRAY:
      begin
        HBError(DBERR_NOXMLDATATYPE);
      end;
    fldTABLE:
      ;
  else
    HBError(DBERR_NIY);
  end;
  if FldType <> fldUNICODE then
    Result := XMLFieldTypes[FldType] else
    Result := XMLFieldTypes[fldZSTRING] + SUniExt;
end;

function GetXMLString(ParamType, ParamLen: DWord; Source: Pointer; var Value: string): Boolean;
const
  BooleanMap: array[Boolean] of string = (SFalse, STrue);
var
  TS: TTimeStamp;
begin
  Result := True;
  case (ParamType and dsTypeBitsMask) shr dsSizeBitsLen of
    dsfldINT,
    dsfldUINT:
    begin
      case ParamLen of
        1: Value := IntToStr(Byte(Source^));
        2: Value := IntToStr(SmallInt(Source^));
        4: Value := IntToStr(Integer(Source^));
      end;
    end;
    dsfldBOOL:
      Value := BooleanMap[WordBool(Source^)];
    dsfldFLOATIEEE:
      Value := FloatToStr(Double(Source^));
    dsfldBCD:
      Value := FloatToStr(Currency(Source^));
    dsfldDATE:
      begin
        TS.Date := PDateTimeRec(Source).Date;
        TS.Time := 0;
        Value := HTMLEncodeDate(TimeStampToDateTime(TS));
      end;
    dsfldTIME:
      begin
        TS.Date := DateDelta;
        TS.Time := PDateTimeRec(Source).Time;
        Value := HTMLEncodeDate(TimeStampToDateTime(TS));
      end;
    dsfldTIMESTAMP:
      begin
        TS := MSecsToTimeStamp(TDateTimeRec(Source^).DateTime);
        Value := HTMLEncodeDate(TimeStampToDateTime(TS));
      end;
    dsfldZSTRING:
    begin
      // ???
      //SetString(Value, PChar(Source) + SizeOf(Word), ParamLen - SizeOf(Word) - 1);
      Value := PChar(Source);
    end;
    dsfldUNICODE:
    begin
      Value := PWideChar(Source);
    end;
    dsfldBYTES:
    begin
      SetString(Value, PChar(Source), ParamLen);
    end;
  else
    Result := False;
  end;
end;

function StrToBool(const Value: string): Boolean;
begin
  if SameText(Value, STrue) then
    Result := True
  else if SameText(Value, SFalse) then
    Result := False
  else
    raise EConvertError.Create(SInvalidString);
end;

{ TDSWriter }
procedure TDSWriter.Initialize;
begin
  inherited;
  FStream := TMemoryStream.Create;
  FXMLWriter := TXMLWriter.Create(FStream);
end;

destructor TDSWriter.Destroy;
begin
  Clear;
  FStream.Free;
  FXMLWriter.Free;
  inherited;
end;

procedure TDSWriter.WriteHeader;
begin
  if FXMLMode = 0 then
  begin
    FStream.WriteBuffer(pktSign, Length(pktSign));
    FStream.WriteBuffer(FVersion, SizeOf(Integer));
    FStream.WriteBuffer(FColumns, SizeOf(Word));
  end else begin
    FStream.Write(XMLSign[1], Length(XMLSign));
    FXMLWriter.BeginWriteNode(SDataPacket);
    FXMLWriter.WriteAttribute(SVersion, Format('%d.0', [PACKETVERSION_2]));
  end;
end;

procedure TDSWriter.Clear;
begin
  FFieldDescs := nil;
  FParentCols := nil;
  FChildNums  := nil;
  FStates     := nil;

  FStream.Size := 0;
  FXMLMetaDataTag := 0;
  FXMLRowDataTag := 0;
  FXMLColumn := 0;
  FXMLWriter.Clear;
end;

procedure TDSWriter.WritePacketData(PacketData: TPacketData);
begin
  FStream.WriteBuffer(PacketData, SizeOf(TPacketData));
end;

procedure TDSWriter.WriteBuffer(const Buff; Count: Integer);
begin
  FStream.WriteBuffer(Count, SizeOf(Integer));
  FStream.WriteBuffer(Buff, Count);
end;

function TDSWriter.AddColumnDesc(const FldDes: TDSDataPacketFldDesc): DBResult;
var
  FieldsStarted: Boolean;
begin
  try
    SetLength(FFieldDescs, Length(FFieldDescs) + 1);
    Move(FldDes, FFieldDescs[High(FFieldDescs)], SizeOf(TDSDataPacketFldDesc));
    if FXMLMode = 0 then
    begin
      WritePacketData(pdFldDesc);
      FStream.WriteBuffer(FldDes, SizeOf(FldDes));
    end else begin
      FieldsStarted := FXMLMetaDataTag = 0;
      if FieldsStarted then
      begin
        FXMLMetaDataTag := FXMLWriter.BeginWriteNode(SMetaData);
        FXMLWriter.BeginWriteNode(SFields);
      end;
      if FXMLWriter.StackTop <> SFields then
        FXMLWriter.EndWriteNode;
      FXMLWriter.BeginWriteNode(SField);
      FXMLWriter.WriteAttribute(SAttrName, FldDes.szFieldName);
      FXMLWriter.WriteAttribute(SFieldType, GetFieldTypeStr(FldDes.iFieldType));
      if (FldDes.iFieldType and dsTypeBitsMask) shr dsSizeBitsLen = dsfldEMBEDDEDTBL then
        FXMLWriter.BeginWriteNode(SFields);
    end;
    Result := DBERR_NONE;
  except
    Result := HandleExceptions;
  end;
end;

function TDSWriter.GetColumnDescs(FieldDes: PDSDataPacketFldDesc): DBResult;
begin
  Move(Pointer(FFieldDescs)^, FieldDes^, Length(FFieldDescs) * SizeOf(TDSDataPacketFldDesc));
  Result := DBERR_NONE;
end;

function TDSWriter.GetColumnCount(var Count: DWord): DBResult;
begin
  Count := Length(FFieldDescs);
  Result := DBERR_NONE;
end;

function TDSWriter.Init(Version: DWord; Columns: Word;
  FieldDesc: PDSDataPacketFldDesc): DBResult;
var
  I: Integer;
begin
  Init_Sequential(Version, Columns);
  for I := 0 to Columns - 1 do
    AddColumnDesc(TDSDataPacketFldDescList(FieldDesc)[I]);
  Result := DBERR_NONE;
end;

function TDSWriter.Init_Sequential(Version: DWord; Columns: Word): DBResult;
begin
  Clear;
  FVersion := Version;
  FColumns := Columns;
  WriteHeader;
  Result := DBERR_NONE;
end;

function TDSWriter.PutField(FldStatus: TPcktFldStatus; Len: DWord; Src: Pointer): DBResult;

  procedure InitParentCols(var StartNo: Integer; ChildNo, ParentNo: Integer);
  var
    I, SaveStartNo: Integer;
    FldDes: PDSDataPacketFldDesc;
  begin
    FParentCols[StartNo] := ParentNo;
    FChildNums[StartNo] := ChildNo;
    SaveStartNo := StartNo;
    Inc(StartNo);
    FldDes := @FFieldDescs[SaveStartNo];
    if (FldDes.iFieldType and dsTypeBitsMask) shr dsSizeBitsLen = dsfldEMBEDDEDTBL then
      for I := 0 to FldDes.iFieldType and dsSizeBitsMask - 1 do
        InitParentCols(StartNo, I, SaveStartNo);
  end;

var
  Col, ParentCol, ChildNo: Integer;
  FldDes: PDSDataPacketFldDesc;
  Value: string;
begin
  Result := DBERR_NONE;
  try
    if FXMLMODE = 0 then
    begin
      if Len and dsDELAYEDBIT = 0 then
      begin
        WritePacketData(pdFldVal);
        FStream.WriteBuffer(FldStatus, SizeOf(FldStatus));
        WriteBuffer(Src^, Len);
      end else begin
        WritePacketData(pdFldValDelayed);
        FStream.WriteBuffer(FldStatus, SizeOf(FldStatus));
        WriteBuffer(Src^, SizeOf(Integer));
      end;
    end else begin
      if FXMLRowDataTag = 0 then
      begin
        if FXMLMetaDataTag > 0 then
          FXMLWriter.FlushTo(FXMLMetaDataTag);
        FXMLRowDataTag := FXMLWriter.BeginWriteNode(SRowData);
      end;

      // Initialize parent columns references
      if not Assigned(FParentCols) then
      begin
        SetLength(FParentCols, Length(FFieldDescs));
        SetLength(FChildNums, Length(FFieldDescs));
        SetLength(FStates, Length(FFieldDescs));
        Col := 0; ChildNo := 0;
        while Col <= High(FFieldDescs) do
        begin
          InitParentCols(Col, ChildNo, -1);
          Inc(ChildNo);
        end;
      end;

      ParentCol := FParentCols[FXMLColumn];
      if (ParentCol + 1) = FXMLColumn then
      begin
        if Hi(FStates[FXMLColumn]) > 0 then
        begin
          if ParentCol < 0 then
            FXMLWriter.BeginWriteNode(SRow) else
            FXMLWriter.BeginWriteNode(SRow + FFieldDescs[ParentCol].szFieldName);
          if Lo(FStates[FXMLColumn]) <> 0 then
            FXMLWriter.WriteAttribute(SRowState, IntToStr(Lo(FStates[FXMLColumn])));
        end else begin
          FStates[FXMLColumn] := PByte(Src)^ or $0100;
          Exit;
        end;
      end;