hbstream.pas

Midas.dll全部源码

  procedure ReadAttributes(Attrs: TStrings);
  var
    AttrName, AttrVal: string;
  begin
    Attrs.Clear;
    while HasAttribute do
    begin
      CheckNextToken(toSimbol);
      AttrName := Parser.TokenStr;
      CheckNextToken(toEquality);
      CheckNextToken(toQuotedString);
      AttrVal := Parser.TokenStr;
      Attrs.Values[AttrName] := Copy(AttrVal, 2, Length(AttrVal) - 2); // Strip quotes
    end;
  end;

  procedure ReadFields(Parent: TXMLField); forward;

  procedure ReadField(Parent: TXMLField);
  var
    Field: TXMLField;
  begin
    CheckNextTag(SField);
    Field := TXMLField.Create(SField, Parent);
    try
      ReadAttributes(Field.Attrs);
      Fields.Add(Field);
    except
      Field.Free;
      raise;
    end;

    Field.DecodeFldDesc;
    if Field.FLDDes.iFldType = fldTABLE then
    begin
      CheckNextToken(toTagClose);
      ReadFields(Field);
    end;
    CheckWaitForTagEnd;
  end;

  procedure ReadFields(Parent: TXMLField);

    function HasField: Boolean;
    var
      SavePos: Integer;
    begin
      SavePos := Stream.Position;
      Result := (Parser.NextToken = toTagOpen) and (Parser.NextToken = toSimbol) and
        SameText(Parser.TokenStr, SField);
      Stream.Position := SavePos;
    end;

  var
    SavePos: Integer;
  begin
    CheckNextTag(SFields);     //<FIELDS>
    CheckNextToken(toTagClose);
    while HasField do ReadField(Parent);
    CheckNextToken(toTagOpen); //</FIELDS>
    CheckWaitForTagEnd;

    SavePos := Stream.Position;
    if (Parser.NextToken = toTagOpen) and (Parser.NextToken = toSimbol) and SameText(Parser.TokenStr, SParams) then
    begin
      if Assigned(Parent) then
        ReadAttributes(Parent.Params) else
        ReadAttributes(Params);
      CheckWaitForTagEnd;
    end else
      Stream.Position := SavePos;
  end;

  procedure WriteParams(Attrs: TStrings);

    procedure WriteAttrBool(const AttrName: string);
    var
      Value: Boolean;
    begin
      if Attrs.IndexOfName(AttrName) >= 0 then
      begin
        Value := StrToBool(Attrs.Values[AttrName]);
        Check(Writer.AddAttribute(pcktAttrArea, PChar(AttrName), (dsfldBOOL shl dsSizeBitsLen) or 1, SizeOf(Value), @Value));
      end;
    end;

    procedure WriteAttrInteger(const AttrName: string);
    var
      Value: Integer;
    begin
      if Attrs.IndexOfName(AttrName) >= 0 then
      begin
        Value := StrToInt(Attrs.Values[AttrName]);
        Check(Writer.AddAttribute(pcktAttrArea, PChar(AttrName), (dsfldINT shl dsSizeBitsLen) or 4, SizeOf(Value), @Value));
      end;
    end;

    procedure WriteAttrString(const AttrName: string);
    var
      Value: string;
    begin
      if Attrs.IndexOfName(AttrName) >= 0 then
      begin
        Value := HTMLDecode(Attrs.Values[AttrName]);
        Check(Writer.AddAttribute(pcktAttrArea, PChar(AttrName), (dsfldZSTRING shl dsSizeBitsLen), Length(Value), PChar(Value)));
      end;
    end;

  begin
    WriteAttrBool(szDATASET_DELTA);
    WriteAttrBool(szREADONLY);
    WriteAttrBool(szCONSTRAINTS);
    WriteAttrInteger(szAUTOINCVALUE);
    WriteAttrInteger(szMD_SEMANTICS);
    WriteAttrInteger(szLCID);
    WriteAttrString(szCHANGE_LOG);
  end;

  procedure WriteFields(Parent: TXMLField);
  var
    I: Integer;
    Field: TXMLField;
  begin
    for I := 0 to Fields.Count - 1 do
    begin
      Field := Fields.List^[I];
      if Field.Parent = Parent then
      begin
        Field.DecodePacketFldDesc;
        Check(Writer.AddColumnDesc(Field.PacketFldDesc));
        WriteAttributes(Writer, Field.AttrInfos, 1);
        if Field.FLDDes.iFldType = fldTABLE then
        begin
          WriteFields(Field);
          Check(Writer.AddAttribute(pcktAttrArea, nil, 0, 0, nil));
        end;
      end;
    end;
    if Assigned(Parent) then
      WriteParams(Parent.Params) else
      WriteParams(Params);
  end;

  procedure ReadMetaData;
  begin
    CheckNextTag(SMetaData);
    CheckNextToken(toTagClose);
    ReadFields(nil);
    WriteFields(nil);
    CheckWaitForTagEnd;
  end;

  function GetIntValue(Row: TStrings; const AttrName: string): Integer;
  begin
    Result := StrToInt(Row.Values[AttrName]);
  end;

  function GetStrValue(Row: TStrings; const AttrName: string): string;
  begin
    Result := HTMLDecode(Row.Values[AttrName]);
  end;

  function GetBoolValue(Row: TStrings; const AttrName: string): Boolean;
  begin
    Result := StrToBool(Row.Values[AttrName]);
  end;

  function GetDateValue(Row: TStrings; const AttrName: string): TDateTime;
  begin
    Result := HTMLDecodeDate(Row.Values[AttrName]);
  end;

  procedure WriteDataSet(Field: TXMLField; ParentRow: Integer); forward;

  procedure WriteField(Field: TXMLField; ParentRow: Integer; Row: TStrings);
  var
    AttrValue: string;
    I: Integer;
    W: WideString;
    B: WordBool;
    D: Double;
    TS: TTimeStamp;
    DateData: Double;
    C: Currency;
    BCD: FMTBCD;
  begin
    with Field, FLDDes do
    begin
      if iFldType <> fldTABLE then
      begin
        if Row.IndexOfName(szName) >= 0 then
        begin
          AttrValue := HTMLDecode(Row.Values[szName]);
          case FldDes.iFldType of
            fldZSTRING, fldBLOB:
              Check(Writer.PutField(fldIsChanged, Length(AttrValue), PChar(AttrValue)));
            fldUNICODE:
              begin
                W := AttrValue;
                Check(Writer.PutField(fldIsChanged, Length(W) * 2, PChar(W)));
              end;
            fldDATE:
              begin
                TS := DateTimeToTimeStamp(HTMLDecodeDate(AttrValue));
                Check(Writer.PutField(fldIsChanged, SizeOf(Integer), @TS.Date));
              end;
            fldTIME:
              begin
                TS := DateTimeToTimeStamp(HTMLDecodeDate(AttrValue));
                Check(Writer.PutField(fldIsChanged, SizeOf(Integer), @TS.Time));
              end;
            fldTIMESTAMP:
              begin
                TS := DateTimeToTimeStamp(HTMLDecodeDate(AttrValue));
                DateData := TimeStampToMSecs(TS);
                Check(Writer.PutField(fldIsChanged, SizeOf(Double), @DateData));
              end;
            fldBOOL:
              begin
                B := StrToBool(AttrValue);
                Check(Writer.PutField(fldIsChanged, SizeOf(WordBool), @B));
              end;
            fldINT16, fldINT32, fldUINT16, fldUINT32:
              begin
                I := StrToInt(AttrValue);
                Check(Writer.PutField(fldIsChanged, iUnits1, @I));
              end;
            fldFLOAT:
              begin
                D := StrToFloat(AttrValue);
                Check(Writer.PutField(fldIsChanged, SizeOf(Double), @D));
              end;
            fldBCD:
              begin
                C := StrToFloat(AttrValue);
                CurrToFMTBCD(C, BCD, iUnits1, iUnits2);
                Check(Writer.PutField(fldIsChanged, SizeOf(FMTBCD), @BCD));
              end;
          else
            Check(Writer.PutField(fldIsNull, 0, nil));
          end;
        end else
          Check(Writer.PutField(fldIsNull, 0, nil));
      end else
        WriteDataSet(Field, ParentRow);
    end;
  end;

  procedure WriteRow(Parent: TXMLField; ParentRow: Integer; Row: TStrings); forward;

  procedure WriteDataSet(Field: TXMLField; ParentRow: Integer);
  var
    I, Count: Integer;
    Row: TRowStrings;
    Recs: TList;
  begin
    with Field do
    begin
      Recs := TList.Create;
      try
        for I := 0 to ListCount(Rows) - 1 do
        begin
          Row := Rows.List^[I];
          if Row.Tag = ParentRow then
            Recs.Add(Row);
        end;

        Count := Recs.Count;
        if Count = 0 then Count := -1;
        Check(Writer.PutField(fldIsChanged, SizeOf(DWord), @Count));
        for I := 0 to Recs.Count - 1 do
          WriteRow(Field, I, Recs.List^[I]);
        Check(Writer.EndOfNestedRows);
      finally
        Recs.Free;
      end;
    end;
  end;

  procedure WriteRow(Parent: TXMLField; ParentRow: Integer; Row: TStrings);
  var
    I: Integer;
    Field: TXMLField;
    RowState: Integer;
  begin
    if Row.IndexOfName(SRowState) >= 0 then
      RowState := GetIntValue(Row, SRowState) else
      RowState := 0;

    Check(Writer.PutField(fldIsChanged, SizeOf(DSAttr), @RowState));
    for I := 0 to Fields.Count - 1 do
    begin
      Field := Fields.List^[I];
      if Field.Parent = Parent then
        WriteField(Field, ParentRow, Row);
    end;

    if not Assigned(Parent) then
      for I := 0 to Fields.Count - 1 do
      begin
        Field := Fields.List^[I];
        if Field.FLDDes.iFldType = fldTABLE then
          Field.ClearRows;
      end;
  end;

  procedure ReadRows(Parent: TXMLField); forward;

  procedure ReadRow(Parent: TXMLField);
  var
    Row, RowRef: TRowStrings;
    Field: TXMLField;
  begin
    CheckNextToken(toTagOpen);
    CheckNextToken(toSimbol);
    if SameText(Parser.TokenStr, SRow) or Assigned(Parent) and SameText(Parser.TokenStr, SRow + Parent.FLDDes.szName) then
    begin
      Row := TRowStrings.Create;
      if Assigned(Parent) and Assigned(Parent.Parent) then
        Row.Tag := ListCount(Parent.Parent.Rows) - 1 else
        Row.Tag := -1;
      try
        RowRef := Row;
        if Assigned(Parent) then
        begin
          Parent.AddRow(Row);
          Row := nil;
        end;

        ReadAttributes(RowRef);
        case Parser.NextToken of
          toTagEnd:
            begin
              CheckNextToken(toTagClose);
            end;
          toTagClose:
            begin
              while HasTag do
              begin
                Field := FindField(Parent, Parser.TokenStr);
                if Assigned(Field) and (Field.FLDDes.iFldType = fldTABLE) then
                begin
                  ReadRows(Field);
                end else
                  Break;
              end;
              CheckWaitForTagEnd;
            end;
        else
          HBError(DBERR_DATAPACKETMISMATCH);
        end;

        if not Assigned(Parent) then WriteRow(nil, -1, RowRef);

      finally
        Row.Free;
      end;
    end else
      HBError(DBERR_DATAPACKETMISMATCH);
  end;

  procedure ReadRows(Parent: TXMLField);
  var
    RowDataTag: string;
  begin
    if Assigned(Parent) then
      RowDataTag := Parent.FLDDes.szName else
      RowDataTag := SRowData;
    CheckNextTag(RowDataTag);
    case Parser.NextToken of
      toTagClose:
        begin
          while HasTag do ReadRow(Parent);
          CheckWaitForTagEnd;
        end;
      toTagEnd:
        CheckNextToken(toTagClose);               // No more rows available
    else
      HBError(DBERR_DATAPACKETMISMATCH);
    end;
  end;

  procedure ReadDataPacket;
  begin
    CheckNextTag(SDataPacket);
    CheckWaitForToken(toTagClose);
    ReadMetaData;
    ReadRows(nil);
    CheckWaitForTagEnd;
  end;

begin
  Parser := TXMLParser.Create(Stream);
  with Parser do
  try
    ReadHeader;
    Fields := TList.Create;
    Params := TStringList.Create;
    try
      try
        ReadDataPacket;
      except
        on EConvertError do
          HBError(DBERR_DATAPACKETMISMATCH);
      end;
    finally
      Params.Free;
      ListDestroyObjects(Fields, True);
    end;
  finally
    Parser.Free;
  end;
end;

function TDSReader.ReadDataPacket(Writer: IDSWriter; SA: PSafeArray): DBResult;

var
  Size: Integer;
  Data: Pointer;
  Stream: TRead_MemoryStream;

  function ReadSignature: Boolean;
  var
    Sign: array [0..Length(pktSign) - 1] of Char;
  begin
    ZeroMemory(@Sign, SizeOf(Sign));
    Stream.Read(Sign, Length(pktSign));
    Result := StrComp(Sign, pktSign) = 0;
  end;

begin
  try
    Stream := TRead_MemoryStream.Create;
    try
      Size := DataPacketSize(SA);
      OleCheck(SafeArrayAccessData(SA, Data));
      try
        Stream.SetPointer(Data, Size);
        if ReadSignature then
        begin
          ReadBinaryPacket(Stream, Writer);
        end else begin
          Stream.Position := 0;
          ReadXMLPacket(Stream, Writer);
        end;
      finally
        SafeArrayUnaccessData(SA);
      end;
    finally
      Stream.Free;
    end;
    Result := DBERR_NONE;
  except
    Result := HandleExceptions;
  end;
end;

end.