hbxml.pas

Midas.dll全部源码

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

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

unit hbXML;

interface
uses Classes;

type
{ TXMLWriter }
  TXMLWriter = class(TObject)
  private
    FStream: TStream;
    FStack: TStrings;
    function GetStackTop: string;
  protected
    procedure WriteString(const Value: string);
  public
    constructor Create(AStream: TStream);
    destructor Destroy; override;
    procedure FlushTo(Index: Integer);
    procedure Flush;
    procedure Clear;
    function BeginWriteNode(const Tag: string): Integer;
    procedure EndWriteNode;
    procedure WriteAttribute(const Name: string; Value: string);
    property Stream: TStream read FStream;
    property Stack: TStrings read FStack;
    property StackTop: string read GetStackTop;
  end;

  TXMLToken = (toError, toEOF, toTagOpen, toTagClose, toTagEnd, toEquality, toSimbol, toQuotedString);

{ TXMLParser }
  TXMLParser = class(TObject)
  private
    FInStream: TStream;
    FTokenStr: string;
    FToken: TXMLToken;
  public
    constructor Create(InStream: TStream);
    function NextToken: TXMLToken;
    procedure WaitForToken(AToken: TXMLToken);
    property Token: TXMLToken read FToken;
    property TokenStr: string read FTokenStr;
  end;

{ Utility routines }
function HTMLEncode(const Value: string): string;
function HTMLDecode(const Value: string): string;

function HTMLEncodeDate(Value: TDateTime): string;
function HTMLDecodeDate(const Value: string): TDateTime;

implementation
uses SysUtils;

const
  EOL         = #13#10;

  NoConversion = [' ','A'..'Z','a'..'z','*','@','.',',',';',':','_','-',
                  '0'..'9','$','!','?','''','(',')'];

  BlankChars   = [#9, #10, #13, ' '];

  SimbolChars  = ['A'..'Z','a'..'z','@','.','_','0'..'9','!','?'];

  SpecialChars = ['<', '>', '"', '&'];

function GetTabSpace(Count: Integer): string;
begin
  SetLength(Result, Count);
  FillChar(PChar(Result)^, Count, ' ');
end;

function SpecialCharToCode(C: Char): string;
begin
  case C of
    '<': Result := '&lt;';
    '>': Result := '&gt;';
    '"': Result := '&quot;';
    '&': Result := '&amp;';
  else
    Result := '';
  end;
end;

function HTMLEncode(const Value: string): string;
var
  Sp, Rp: PChar;
  I: Integer;
  Code: string;
begin
  SetLength(Result, Length(Value) * 6);
  Sp := PChar(Value);
  Rp := PChar(Result);
  for I := 0 to Length(Value) - 1 do
  begin
    if Sp^ in NoConversion then
      Rp^ := Sp^
    else
      if Sp^ in SpecialChars then
      begin
        Code := SpecialCharToCode(Sp^);
        Move(Code[1], Rp^, Length(Code));
        Inc(Rp, Length(Code) - 1);
      end else begin
        FormatBuf(Rp^, 6, '&#%.3d;', 7, [Ord(Sp^)]);
        Inc(Rp, 5);
      end;
    Inc(Rp);
    Inc(Sp);
  end;
  SetLength(Result, Rp - PChar(Result));
end;

function HTMLDecode(const Value: string): string;
var
  Sp, Rp: PChar;
  Code: string;
  CodeChar: Char;
  IsCode: Boolean;

const
  Codes: array[0..4] of string = (
   'LT', 'GT', 'QUOT', 'AMP', '&');

  CodeChars: array[0..4] of Char = (
    '<', '>', '"', '&', '&');

  function FindCode(var CodeChar: Char): Boolean;
  var
    I: Integer;
    Tmp: string;
  begin
    Tmp := UpperCase(Code);
    for I := 0 to High(Codes) do
      if Tmp = Codes[I] then
      begin
        CodeChar := CodeChars[I];
        Result := True;
        Exit;
      end;
    CodeChar := #0;
    Result := False;
  end;

  procedure FlushCode;
  begin
    if (Length(Code) > 1) and (Code[1] = '#') then
      Code := Chr(StrToInt(Copy(Code, 2, MaxInt))) else
      Code := '&' + Code;

    Move(Code[1], Rp^, Length(Code));
    Inc(Rp, Length(Code));
    IsCode := False;
  end;

begin
  SetLength(Result, Length(Value));
  Sp := PChar(Value);
  Rp := PChar(Result);
  IsCode := False;
  while Sp^ <> #0 do
  begin
    if IsCode then
    begin
      // Numeric code
      if (Length(Code) > 0) and (Code[1] = '#') and not (Sp^ in ['0'..'9']) then
      begin
        FlushCode;
        if Sp^ = ';' then Inc(Sp);
        Continue;
      end;

      if Sp^ in [' ', ';', '&'] then
      begin
        FlushCode;
        Continue;
      end;

      // Other code
      Code := Code + Sp^;

      if FindCode(CodeChar) then
      begin
        Rp^ := CodeChar;
        Inc(Rp);
        IsCode := False;
        if (Sp + 1)^ = ';' then Inc(Sp);
      end;
    end else begin
      if Sp^ <> '&' then
      begin
        Rp^ := Sp^;
        Inc(Rp);
      end else begin
        Code := '';
        IsCode := True;
      end;
    end;
    Inc(Sp);
  end;

  if IsCode then
  begin
    if FindCode(CodeChar) then
    begin
      Rp^ := CodeChar;
      Inc(Rp);
    end else
      FlushCode;
  end;
  SetLength(Result, Rp - PChar(Result));
end;

function HTMLEncodeDate(Value: TDateTime): string;
var
  Yr, Mn, Dy: Word;
  Hr, Mt, S, Ms: Word;
  DateStr, TimeStr: string;
begin
  if Trunc(Value) > 0 then
  begin
    DecodeDate(Value, Yr, Mn, Dy);
    DateStr := Format('%.4d%.2d%.2d', [Yr, Mn, Dy]);
  end else
    DateStr := '';

  if Frac(Value) > 0 then
  begin
    DecodeTime(Value, Hr, Mt, S, Ms);
    TimeStr := Format('%.2d:%.2d:%.5d', [Hr, Mt, S * 1000 + Ms]);
    if DateStr <> '' then
      Result := DateStr + 'T' + TimeStr else
      Result := TimeStr;
  end else
    Result := DateStr;
end;

function HTMLDecodeDate(const Value: string): TDateTime;

  function SubStrInt(const Value: string; Start, Count: Integer): Integer;
  begin
    Result := StrToInt(Copy(Value, Start, Count));
  end;

var
  I: Integer;
  Tmp, TimeStr, DateStr: string;
  Yr, Mn, Dy: Word;
  Hr, Mt: Word;
  Ms: Integer;
begin
  Tmp := UpperCase(Trim(Value));
  I := Pos('T', Tmp);

  if I = 9 then
  begin
    DateStr := Copy(Tmp, 1, 8);
    TimeStr := Copy(Tmp, 10, MaxInt);
  end else if Pos(':', Tmp) = 3 then begin
    DateStr := '';
    TimeStr := Tmp;
  end else begin
    DateStr := Tmp;
    TimeStr := '';
  end;

  // Date portion
  if DateStr <> '' then
  begin
    Yr := SubStrInt(DateStr, 1, 4);
    Mt := SubStrInt(DateStr, 5, 2);
    Dy := SubStrInt(DateStr, 7, 2);
    Result := EncodeDate(Yr, Mt, Dy);
  end else
    Result := 0;

  // Time portion
  if TimeStr <> '' then
  begin
    Hr := SubStrInt(TimeStr, 1, 2);
    Mn := SubStrInt(TimeStr, 4, 2);
    Ms := SubStrInt(TimeStr, 7, 5);
    Result := Result + EncodeTime(Hr, Mn, Ms div 1000, Ms mod 1000);
  end;
end;

{ TXMLWriter }
constructor TXMLWriter.Create(AStream: TStream);
begin
  FStack := TStringList.Create;
  FStream := AStream;
end;

destructor TXMLWriter.Destroy;
begin
  FStack.Free;
  inherited;
end;

procedure TXMLWriter.WriteString(const Value: string);
begin
  Stream.WriteBuffer(Value[1], Length(Value));
end;

function TXMLWriter.BeginWriteNode(const Tag: string): Integer;
begin
  with FStack do
  begin
    // HasChild := True
    if (Count > 0) and not Boolean(Objects[Count - 1]) then
    begin
      WriteString('>');
      Objects[Count - 1] := Pointer(1);
    end;

    // Start new DOM level
    WriteString(EOL + GetTabSpace(FStack.Count * 2));

    WriteString(Format('<%s', [Tag]));
    Result := FStack.Add(Tag);
  end;
end;

procedure TXMLWriter.EndWriteNode;
var
  HasChild: Boolean;
begin
  with FStack do
  begin
    HasChild := Boolean(Objects[Count - 1]);

    if HasChild then
    begin
      // End of DOM level
      WriteString(EOL + GetTabSpace((FStack.Count - 1) * 2));
      WriteString(Format('</%s>', [Strings[Count - 1]]))
    end else
      WriteString('/>');

    Delete(Count - 1);
  end;
end;

procedure TXMLWriter.WriteAttribute(const Name: string; Value: string);
begin
  WriteString(Format(' %s="%s"', [Name, HTMLEncode(Value)]));
end;

procedure TXMLWriter.FlushTo(Index: Integer);
var
  I: Integer;
begin
  for I := FStack.Count - 1 downto Index do
    EndWriteNode;
end;

procedure TXMLWriter.Flush;
begin
  FlushTo(0);
end;

procedure TXMLWriter.Clear;
begin
  FStack.Clear;
end;

function TXMLWriter.GetStackTop: string;
begin
  if FStack.Count > 0 then
    Result := FStack[FStack.Count - 1] else
    Result := '';
end;

{ TXMLParser }
constructor TXMLParser.Create(InStream: TStream);
begin
  FInStream := InStream;
end;

function TXMLParser.NextToken: TXMLToken;

  procedure SkipBlanks;
  var
    C: Char;
  begin
    with FInStream do
    begin
      if Position = Size then Exit;

      C := ' ';
      while (C in BlankChars) and not (Position = Size) do
        ReadBuffer(C, SizeOf(Char));

      // Put non-blank character back
      if Position > 0 then
        Position := Position - 1;
    end;
  end;

  procedure ReadTokenStr;
  var
    C: Char;
  begin
    with FInStream do
    begin
      ReadBuffer(C, SizeOf(Char));

      case C of
        '<': FToken := toTagOpen;
        '>': FToken := toTagClose;
        '/': FToken := toTagEnd;
        '=': FToken := toEquality;
        '"': FToken := toQuotedString;
      else
        if C in SimbolChars then
          FToken := toSimbol
        else begin
          FToken := toError;
          Exit;
        end;
      end;

      FTokenStr := C;

      if (FToken = toQuotedString) and (Position = Size) then
      begin
        FToken := toError;
        Exit;
      end;

      if FToken in [toSimbol, toQuotedString] then
      begin
        while not (Position = Size) do
        begin
          ReadBuffer(C, SizeOf(Char));

          case FToken of
            toSimbol:
              begin
                if not (C in SimbolChars) then
                begin
                  // But character back
                  Position := Position - 1;
                  Exit;
                end;
                FTokenStr := FTokenStr + C;
              end;

            toQuotedString:
              begin
                if C in BlankChars - [' '] then
                begin
                  FToken := toError;
                  Exit;
                end;
                FTokenStr := FTokenStr + C;
                if C = '"' then Exit;
              end;
          end;

          if (Position = Size) then
          begin
            // Quoted string not closed
            if FToken = toQuotedString then
              FToken := toError;
            Exit;
          end;
        end;

        // Put non-blank character back
        if Position > 0 then
          Position := Position - 1;
      end;
    end;
  end;

begin
  FTokenStr := '';

  with FInStream do
  begin
    SkipBlanks;
    if Position = Size then
    begin
      FToken := toEOF;
    end else
      ReadTokenStr;

    Result := FToken;
  end;
end;

procedure TXMLParser.WaitForToken(AToken: TXMLToken);
begin
  repeat
    NextToken;
  until Token in [toError, toEOF, AToken];
end;

end.