hbstream.pas

Midas.dll全部源码

      FldDes := @FFieldDescs[FXMLColumn];

      if (FldDes.iFieldType and dsTypeBitsMask) shr dsSizeBitsLen = dsfldEMBEDDEDTBL then
      begin
        FXMLWriter.BeginWriteNode(FldDes.szFieldName);
        Inc(FXMLColumn);
        if (FldStatus <> fldIsChanged) or (Len and dsDELAYEDBIT <> 0) then
          EndOfNestedRows; 
      end else begin
        if (Len and dsDELAYEDBIT = 0) and (FldStatus = fldIsChanged) and GetXMLString(FldDes.iFieldType, Len, Src, Value) then
          FXMLWriter.WriteAttribute(FldDes.szFieldName, Value);
        FXMLColumn := (FXMLColumn + 1);
        if ParentCol = -1 then
        begin
          if FXMLColumn > High(FFieldDescs) then
          begin
            FXMLColumn := 0;
            FStates[0] := 0;
            FXMLWriter.EndWriteNode; // Close ROW tag or EMBEDDEDTABLE tag
          end;
        end else begin
          if (FXMLColumn > High(FFieldDescs)) or (FChildNums[FXMLColumn] = FFieldDescs[ParentCol].iFieldType and dsSizeBitsMask) then
          begin
            FXMLColumn := ParentCol + 1;
            FStates[FXMLColumn] := 0;
            FXMLWriter.EndWriteNode; // Close ROW tag or EMBEDDEDTABLE tag
          end;
        end;
      end;
    end;
  except
    Result := HandleExceptions;
  end;
end;

function TDSWriter.AddAttribute(AttrArea: TPcktAttrArea; Attr: PChar;
  AttrType, Len: DWord; Value: Pointer): DBResult;
const
  B: Byte = 0;
var
  AttrStr: string;
begin
  if FXMLMode = 0 then
  begin
    WritePacketData(pdAttr);
    FStream.WriteBuffer(AttrArea, SizeOf(AttrArea));
    FStream.WriteBuffer(AttrType, SizeOf(AttrType));
    if Assigned(Attr) then
      WriteBuffer(Attr^, StrLen(Attr) + 1) else
      WriteBuffer(B, 1);
    WriteBuffer(Value^, Len);
  end else begin
    if AttrArea = fldAttrArea then
    begin
      if GetXMLString(AttrType, Len, Value, AttrStr) then
        FXMLWriter.WriteAttribute(Attr, AttrStr); // Attribute of FIELD tag
    end else begin
      if FXMLWriter.Stack[FXMLWriter.Stack.Count - 2] = SFields then
      begin
        FXMLWriter.EndWriteNode; // Close FIELD tag
        FXMLWriter.EndWriteNode; // Close FIELDS tag
      end;

      if not Assigned(Attr) then
      begin
        FXMLWriter.EndWriteNode; // Close PARAMS tag
                                 // All attributes of packet area are written
      end else begin
        if FXMLWriter.StackTop <> SParams then
          FXMLWriter.BeginWriteNode(SParams);
        if GetXMLString(AttrType, Len, Value, AttrStr) then
          FXMLWriter.WriteAttribute(Attr, AttrStr);
      end;
    end;
  end;
  Result := DBERR_NONE;
end;

function TDSWriter.EndOfNestedRows: DBResult;
var
  NextCol, ParentCol: Integer;
begin
  if FXMLMode = 0 then
  begin
    WritePacketData(pdEofNestedRows)
  end else begin
    FXMLWriter.EndWriteNode; // Close DataSet tag
    ParentCol := FParentCols[FXMLColumn];
    NextCol := FindInteger(FParentCols[ParentCol], FParentCols[ParentCol + 1], High(FParentCols) - ParentCol);
    if NextCol >= 0 then
    begin
      FXMLColumn := ParentCol + 1 + NextCol;
      FStates[ParentCol + 1] := 0;
    end else begin
      FXMLColumn := 0;
      FStates[0] := 0;
      FXMLWriter.EndWriteNode; // Close ROW tag
    end;
  end;
  Result := DBERR_NONE;
end;

function TDSWriter.GetXMLMode: DWord;
begin
  Result := FXMLMode;
end;

function TDSWriter.SetXMLMode(iMode: Integer): DBResult;
begin
  FXMLMode := iMode and xmlON;
  Result := DBERR_NONE;
end;

function TDSWriter.Reset: DBResult;
begin
  Clear;
  WriteHeader;
  Result := DBERR_NONE;
end;

function TDSWriter.GetSize(var DataPacketSize: DWord): DBResult;
begin
  FXMLWriter.Flush;
  DataPacketSize := FStream.Size;
  Result := DBERR_NONE;
end;

function TDSWriter.GetDataPacket(var SA: PSafeArray): DBResult;
begin
  FXMLWriter.Flush;
  CreateDataPacket(FStream.Memory^, FStream.Size, SA);
  Result := DBERR_NONE;
end;

function TDSWriter.GetErrorString(iErrCode: DBResult; pString: PChar): DBResult;
begin
  try
    GetErrorMessage(iErrCode, pString);
    Result := DBERR_NONE;
  except
    Result := HandleExceptions;
  end;
end;

{ TDSReader }
procedure TDSReader.ReadBinaryPacket(Stream: TStream; Writer: IDSWriter);

  procedure ReadHeader;
  var
    Columns: Word;
    Version: Integer;
  begin
    Stream.ReadBuffer(Version, SizeOf(Integer));
    Stream.ReadBuffer(Columns, SizeOf(Word));
    Check(Writer.Init_Sequential(Version, Columns));
  end;

  function NextData: TPacketData;
  begin
    Stream.ReadBuffer(Result, SizeOf(TPacketData));
  end;

  procedure ReadBuffer(var P: Pointer; ASize: DWord);
  begin
    with Stream do
    begin
      if DWord(Position) + ASize > DWord(Size) then
        raise EReadError.Create(SReadError);
      P := PChar(TCustomMemoryStream(Stream).Memory) + Position;
      Stream.Seek(ASize, soFromCurrent);
    end;
  end;

  procedure ReadBufferSize(var P: Pointer; var ASize: DWord);
  begin
    Stream.ReadBuffer(ASize, SizeOf(Integer));
    ReadBuffer(P, ASize);
  end;

  procedure ReadFldDesc;
  var
    FldDes: PDSDataPacketFldDesc;
  begin
    ReadBuffer(Pointer(FldDes), SizeOf(TDSDataPacketFldDesc));
    Check(Writer.AddColumnDesc(FldDes^));
  end;

  procedure ReadAttr;
  var
    AttrArea: TPcktAttrArea;
    AttrType: DWord;
    Attr: Pointer;
    AttrLen: DWord;
    Value: Pointer;
    Len: DWord;
  begin
    Stream.ReadBuffer(AttrArea, SizeOf(AttrArea));
    Stream.ReadBuffer(AttrType, SizeOf(AttrType));
    ReadBufferSize(Attr, AttrLen);
    ReadBufferSize(Value, Len);
    Writer.AddAttribute(AttrArea, Attr, AttrType, Len, Value);
  end;

  procedure ReadFldVal(DELAYBIT: DWord);
  var
    FldStatus: TPcktFldStatus;
    Buff: Pointer;
    Size: DWord;
  begin
    Stream.ReadBuffer(FldStatus, SizeOf(FldStatus));
    ReadBufferSize(Buff, Size);
    Check(Writer.PutField(FldStatus, Size or DELAYBIT, Buff));
  end;

begin
  ReadHeader;
  while Stream.Position < Stream.Size do
    case NextData of
      pdFldDesc:
        ReadFldDesc;
      pdAttr:
        ReadAttr;
      pdFldVal:
        ReadFldVal(0);
      pdFldValDelayed:
        ReadFldVal(dsDELAYEDBIT);
      pdEofNestedRows:
        Writer.EndOfNestedRows;
    else
      HBError(DBERR_DATAPACKETMISMATCH);
    end;
end;

type
{ TXMLNode }
  TXMLNode = class
  private
    FName: string;
    FAttrs: TStrings;
  public
    constructor Create(const AName: string);
    destructor Destroy; override;
    property Attrs: TStrings read FAttrs;
    property Name: string read FName write FName;
  end;

{ TXMLField }
  TXMLField = class(TXMLNode)
  private
    FAttrInfos: TAttrInfos;
    FParent: TXMLField;
    FParams: TStrings;
    FFLDDes: DSFLDDesc;
    FPacketFldDesc: TDSDataPacketFldDesc;
    FFields: TList;
    FRows: TList;
  protected
    procedure InsertField(AField: TXMLField);
  public
    constructor Create(const AName: string; AParent: TXMLField);
    destructor Destroy; override;
    procedure ClearRows;
    procedure DecodeFldDesc;
    procedure DecodePacketFldDesc;
    procedure AddRow(Row: TStrings);
    property AttrInfos: TAttrInfos read FAttrInfos;
    property FLDDes: DSFLDDesc read FFLDDes;
    property PacketFldDesc: TDSDataPacketFldDesc read FPacketFldDesc;
    property Parent: TXMLField read FParent;
    property Params: TStrings read FParams;
    property Rows: TList read FRows;
  end;

{ TRowStrings }
  TRowStrings = class(TStringList)
  private
    FTag: Integer;
  public
    property Tag: Integer read FTag write FTag;
  end;

{ TXMLNode }
constructor TXMLNode.Create(const AName: string);
begin
  FName := AName;
  FAttrs := TStringList.Create;
end;

destructor TXMLNode.Destroy;
begin
  FAttrs.Free;
  inherited;
end;

{ TXMLField }
constructor TXMLField.Create(const AName: string; AParent: TXMLField);
begin
  inherited Create(AName);
  FParams := TStringList.Create;
  if Assigned(AParent) then AParent.InsertField(Self);
end;

destructor TXMLField.Destroy;
begin
  FParams.Free;
  ListClear(FFields);
  ListDestroyObjects(FRows, True);
  inherited;
end;

procedure TXMLField.ClearRows;
begin
  ListDestroyObjects(FRows, True);
end;

procedure TXMLField.AddRow(Row: TStrings);
begin
  ListAdd(FRows, Row);
end;

procedure TXMLField.InsertField(AField: TXMLField);
begin
  ListAdd(FFields, AField);
  AField.FParent := Self;
end;

procedure TXMLField.DecodeFldDesc;
var
  I, iFldType: Integer;
  FieldName, FieldType: string;
begin
  FieldName := FAttrs.Values[SAttrName];
  if (FieldName = '') then
    HBError(DBERR_DATAPACKETMISMATCH);
  StrCopy(FFLDDes.szName, PChar(FieldName));

  FieldType := FAttrs.Values[SFieldType];

  iFldType := fldUNKNOWN;
  if FieldType <> '' then
  begin
    if (SameText(FieldType, 'string.uni')) then
      iFldType := fldUNICODE
    else
      for I := 0 to High(XMLFieldTypes) do
        if SameText(FieldType, XMLFieldTypes[I]) then
        begin
          iFldType := I;
          Break;
        end;
  end;

  case iFldType of
    fldINT16, fldUINT16:
      FFLDDes.iUnits1 := SizeOf(SmallInt);
    fldINT32, fldUINT32:
      FFLDDes.iUnits1 := SizeOf(Integer);
    fldUNKNOWN:
      HBError(DBERR_DATAPACKETMISMATCH);
  end;

  FFLDDes.iFldType := iFldType;
end;

procedure TXMLField.DecodePacketFldDesc;
begin
  if Attrs.IndexOfName(szWIDTH) >= 0 then
    FFLDDes.iUnits1 := StrToInt(Attrs.Values[szWIDTH]);

  if Attrs.IndexOfName(szDECIMALS) >= 0 then
    FFLDDes.iUnits2 := StrToInt(Attrs.Values[szDECIMALS]);

  if Attrs.IndexOfName(szSERVERCALC) >= 0 then
    FFLDDes.bCalculated := StrToBool(Attrs.Values[szSERVERCALC]);

  if Attrs.IndexOfName(szSUBTYPE) >= 0 then
    FFldDes.iFldSubType := GetFieldSubType(FFLDDes.iFldType, Attrs.Values[szSUBTYPE]);

  if FFLDDes.iFldType = fldTABLE then
    FFLDDes.iUnits1 := ListCount(FFields) + 1;
  FldDescToPacketDS(FFLDDes, 1, FPacketFldDesc, FAttrInfos);
end;

procedure TDSReader.ReadXMLPacket(Stream: TStream; Writer: IDSWriter);

var
  Parser: TXMLParser;
  Fields: TList;
  Params: TStrings;

  function FindField(Parent: TXMLField; const FieldName: string): TXMLField;
  var
    I: Integer;
  begin
    for I := 0 to Fields.Count - 1 do
    begin
      Result := Fields[I];
      if (Result.Parent = Parent) and SameText(Result.FLDDes.szName, FieldName) then Exit;
    end;
    Result := nil;
  end;

  procedure CheckToken(Token: TXMLToken; const TokenStr: string = '');
  begin
    if (Parser.Token <> Token) or (TokenStr <> '') and not SameText(Parser.TokenStr, TokenStr) then
      HBError(DBERR_DATAPACKETMISMATCH);
  end;

  procedure CheckNextToken(Token: TXMLToken; const TokenStr: string = '');
  begin
    Parser.NextToken;
    CheckToken(Token, TokenStr);
  end;

  procedure CheckNextTag(const Tag: string);
  begin
    CheckNextToken(toTagOpen);
    CheckNextToken(toSimbol, Tag);
  end;

  procedure CheckWaitForToken(Token: TXMLToken; const TokenStr: string = '');
  begin
    Parser.WaitForToken(Token);
    CheckToken(Token, TokenStr);
  end;

  procedure CheckWaitForTag(const Tag: string);
  begin
    CheckWaitForToken(toTagOpen);
    CheckNextToken(toSimbol, Tag);
  end;

  procedure CheckWaitForTagEnd;
  begin
    CheckWaitForToken(toTagEnd);
    CheckWaitForToken(toTagClose);
  end;

  procedure ReadHeader;
  begin
    CheckWaitForTag('?xml');
    CheckWaitForToken(toTagClose);
    Check(Writer.Init_Sequential(PACKETVERSION_2, 0));
  end;

  function HasAttribute: Boolean;
  var
    SavePos: Integer;
  begin
    SavePos := Stream.Position;
    Result := (Parser.NextToken = toSimbol);
    Stream.Position := SavePos;
  end;

  function HasTag: Boolean;
  var
    SavePos: Integer;
  begin
    SavePos := Stream.Position;
    Result := (Parser.NextToken = toTagOpen) and (Parser.NextToken = toSimbol);
    Stream.Position := SavePos;
  end;