Hessian2序列化

unit Hessian2Output;

{
  title: hessian 2.0 序列化
  author: Xiao Chun 
  email: cnxiaochun#gmail.com
  version: draft
  reference: http://hessian.caucho.com/
}

interface
uses Classes;
const
  BUFFER_SIZE = 4096;

  INT_DIRECT_MIN = -$10;
  INT_DIRECT_MAX = $2F;
  INT_ZERO = $90;

  INT_BYTE_MIN = -$800;
  INT_BYTE_MAX = $7FF;
  INT_BYTE_ZERO = $C8;

  INT_SHORT_MIN = -$40000;
  INT_SHORT_MAX = $3FFFF;
  INT_SHORT_ZERO = $D4;

  LONG_DIRECT_MIN = -$08;
  LONG_DIRECT_MAX = $0F;
  LONG_ZERO = $E0;

  LONG_BYTE_MIN = -$800;
  LONG_BYTE_MAX = $7FF;
  LONG_BYTE_ZERO = $F8;

  LONG_SHORT_MIN = -$40000;
  LONG_SHORT_MAX = $3FFFF;
  LONG_SHORT_ZERO = $3C;

  LONG_INT_MIN = -$7FFFFFFF - 1;
  LONG_INT_MAX = $7FFFFFFF;
  LONG_INT_ZERO = $77;

  STRING_DIRECT_MAX = $1F;
  STRING_DIRECT = $00;

  BYTES_DIRECT_MAX = $0F;
  BYTES_DIRECT = $20;

  DOUBLE_ZERO = $67;
  DOUBLE_ONE = $68;
  DOUBLE_BYTE = $69;
  DOUBLE_SHORT = $6A;
  DOUBLE_FLOAT = $6B;

  LENGTH_BYTE = $6E;
  LIST_FIXED = $76; // 'v'

  REF_BYTE = $4A;
  REF_SHORT = $4B;

  TYPE_REF = $75;
type
  THessian2Output = class(TObject)
  private
    FBuffer: array[0..BUFFER_SIZE - 1] of Byte;
    FOffset: integer;
    FStream: TStream;
    FFreeStreamOnDestroy: boolean;
    _typeRefs: TStringList;
    procedure PrintString(const AValue: WideString; AOffset, ACount: integer);
    procedure WriteType(const AType: WideString);
    procedure _WriteString(const AValue: WideString; AOffset, ACount: integer);
  public
    constructor Create(AStream: TStream);
    destructor Destroy; override;
  public
    procedure StartCall(const AMethodName: WideString);
    procedure CompleteCall;
    procedure Flush;
    procedure WriteInt(AValue: integer);
    procedure WriteLong(AValue: Int64);
    procedure WriteDouble(AValue: Double);
    procedure WriteBoolean(AValue: boolean);
    procedure WriteNull;
    procedure WriteString(const AValue: WideString);
    procedure WriteUTCDate(AValue: TDateTime);
    procedure WriteBytes(ASourceStream: TStream); overload;
    procedure WriteBytes(ASourceStream: TStream; AOffset, ACount: integer); overload;
    procedure WriteMapBegin; overload;
    procedure WriteMapBegin(const AType: WideString); overload;
    procedure WriteMapEnd;
    function WriteListBegin(ALength: integer; const AType: WideString): boolean; overload;
    function WriteListBegin(ALength: integer): boolean; overload;
    procedure WriteListEnd;
  end;

implementation
uses JavaDate;

constructor THessian2Output.Create(AStream: TStream);
begin
  inherited Create;
  FOffset := 0;
  if Assigned(AStream) then
  begin
    FFreeStreamOnDestroy := false;
    FStream := AStream;
  end
  else begin
    FFreeStreamOnDestroy := true;
    FStream := TMemoryStream.Create;
  end;
end;

destructor THessian2Output.Destroy;
begin
  if FFreeStreamOnDestroy then FStream.Free;
  if Assigned(_typeRefs) then _typeRefs.Free;
  inherited;
end;

procedure THessian2Output.StartCall(const AMethodName: WideString);
var
  Len: Integer;
begin
  if BUFFER_SIZE < FOffset + 16 then Flush;

  FBuffer[FOffset] := Byte('c'); Inc(FOffset);
  FBuffer[FOffset] := Byte(2); Inc(FOffset);
  FBuffer[FOffset] := Byte(0); Inc(FOffset);
  FBuffer[FOffset] := Byte('m'); Inc(FOffset);

  Len := Length(AMethodName);
  FBuffer[FOffset] := Byte(len shr 8 ); Inc(FOffset);
  FBuffer[FOffset] := Byte(len); Inc(FOffset);
  PrintString(AMethodName, 0, Len);
end;

procedure THessian2Output.CompleteCall;
begin
  if BUFFER_SIZE < FOffset + 16 then Flush;

  FBuffer[FOffset] := Byte('z'); Inc(FOffset);
end;

procedure THessian2Output.WriteInt(AValue: integer);
begin
  if BUFFER_SIZE < FOffset + 16 then Flush;

  if (INT_DIRECT_MIN <= AValue) and (AValue <= INT_DIRECT_MAX) then
  begin
    FBuffer[FOffset] := Byte(AValue + INT_ZERO); Inc(FOffset);
  end
  else if (INT_BYTE_MIN <= AValue) and (AValue <= INT_BYTE_MAX) then
  begin
    FBuffer[FOffset] := Byte(INT_BYTE_ZERO + (AValue shr 8 )); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue); Inc(FOffset);
  end
  else if (INT_SHORT_MIN <= AValue) and (AValue <= INT_SHORT_MAX) then
  begin
    FBuffer[FOffset] := Byte(INT_SHORT_ZERO + (AValue shr 16 )); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue shr 8 ); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue); Inc(FOffset);
  end
  else begin
    FBuffer[FOffset] := Byte('I'); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue shr 24); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue shr 16); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue shr 8 ); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue); Inc(FOffset);
  end
end;

procedure THessian2Output.WriteLong(AValue: int64);
begin
  if BUFFER_SIZE < FOffset + 16 then Flush;

  if (LONG_DIRECT_MIN <= AValue) and (AValue <= LONG_DIRECT_MAX) then
  begin
    FBuffer[FOffset] := Byte(AValue + LONG_ZERO); Inc(FOffset);
  end
  else if (LONG_BYTE_MIN <= AValue) and (AValue <= LONG_BYTE_MAX) then
  begin
    FBuffer[FOffset] := Byte(LONG_BYTE_ZERO + (AValue shr 8 )); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue); Inc(FOffset);
  end
  else if (LONG_SHORT_MIN <= AValue) and (AValue <= LONG_SHORT_MAX) then
  begin
    FBuffer[FOffset] := Byte(LONG_SHORT_ZERO + (AValue shr 16)); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue shr 8 ); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue); Inc(FOffset);
  end
  else if (LONG_INT_MIN <= AValue) and (AValue <= LONG_INT_MAX) then
  begin
    FBuffer[FOffset] := Byte(LONG_INT_ZERO); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue shr 24); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue shr 16); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue shr 8 ); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue); Inc(FOffset);
  end
  else begin
    FBuffer[FOffset] := Byte('L'); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue shr 56); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue shr 48); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue shr 40); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue shr 32); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue shr 24); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue shr 16); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue shr 8 ); Inc(FOffset);
    FBuffer[FOffset] := Byte(AValue); Inc(FOffset);
  end
end;

procedure THessian2Output.WriteDouble(AValue: Double);
var
  intValue: integer;
  longValue: int64;
  floatValue: single;
begin
  if BUFFER_SIZE < FOffset + 16 then Flush;

  if Int(AValue) = AValue then
  begin // 只有整数部分
    intValue := Round(AValue);
    if intValue = 0 then
    begin
      FBuffer[FOffset] := Byte(DOUBLE_ZERO); Inc(FOffset);
      exit;
    end
    else if intValue = 1 then
    begin
      FBuffer[FOffset] := Byte(DOUBLE_ONE); Inc(FOffset);
      exit;
    end
    else if (-$80 <= intValue) and (intValue < $80) then
    begin
      FBuffer[FOffset] := Byte(DOUBLE_BYTE); Inc(FOffset);
      FBuffer[FOffset] := Byte(intValue); Inc(FOffset);
      exit;
    end
    else if ($8000 <= intValue) and (intValue < $8000) then
    begin
      FBuffer[FOffset] := Byte(DOUBLE_SHORT); Inc(FOffset);
      FBuffer[FOffset] := Byte(intValue shr 8 ); Inc(FOffset);
      FBuffer[FOffset] := Byte(intValue); Inc(FOffset);
      exit;
    end;
  end;

  floatValue := AValue;
  if floatValue = AValue then
  begin
    FBuffer[FOffset] := Byte(DOUBLE_FLOAT); Inc(FOffset);
    intValue := PInteger(@floatValue)^;
    FBuffer[FOffset] := Byte(intValue shr 24); Inc(FOffset);
    FBuffer[FOffset] := Byte(intValue shr 16); Inc(FOffset);
    FBuffer[FOffset] := Byte(intValue shr 8 ); Inc(FOffset);
    FBuffer[FOffset] := Byte(intValue); Inc(FOffset);
    exit;
  end;

  FBuffer[FOffset] := Byte('D'); Inc(FOffset);
  longValue := PInt64(@AValue)^;
  FBuffer[FOffset] := Byte(longValue shr 56); Inc(FOffset);
  FBuffer[FOffset] := Byte(longValue shr 48); Inc(FOffset);
  FBuffer[FOffset] := Byte(longValue shr 40); Inc(FOffset);
  FBuffer[FOffset] := Byte(longValue shr 32); Inc(FOffset);
  FBuffer[FOffset] := Byte(longValue shr 24); Inc(FOffset);
  FBuffer[FOffset] := Byte(longValue shr 16); Inc(FOffset);
  FBuffer[FOffset] := Byte(longValue shr 8 ); Inc(FOffset);
  FBuffer[FOffset] := Byte(longValue); Inc(FOffset);
end;

procedure THessian2Output.WriteBoolean(AValue: boolean);
begin
  if BUFFER_SIZE < FOffset + 16 then Flush;

  if AValue then
  begin
    FBuffer[FOffset] := Byte('T'); Inc(FOffset);
  end
  else begin
    FBuffer[FOffset] := Byte('F'); Inc(FOffset);
  end
end;

procedure THessian2Output.WriteString(const AValue: WideString);
begin
  _WriteString(AValue, 0, Length(AValue));
end;

procedure THessian2Output.WriteUTCDate(AValue: TDateTime);
var
  UTCValue: int64;
begin
  UTCValue := DateTimeToJavaDate(AValue);

  if BUFFER_SIZE < FOffset + 16 then Flush;

  FBuffer[FOffset] := Byte('d'); Inc(FOffset);
  FBuffer[FOffset] := Byte(UTCValue shr 56); Inc(FOffset);
  FBuffer[FOffset] := Byte(UTCValue shr 48); Inc(FOffset);
  FBuffer[FOffset] := Byte(UTCValue shr 40); Inc(FOffset);
  FBuffer[FOffset] := Byte(UTCValue shr 32); Inc(FOffset);
  FBuffer[FOffset] := Byte(UTCValue shr 24); Inc(FOffset);
  FBuffer[FOffset] := Byte(UTCValue shr 16); Inc(FOffset);
  FBuffer[FOffset] := Byte(UTCValue shr 8 ); Inc(FOffset);
  FBuffer[FOffset] := Byte(UTCValue); Inc(FOffset);
end;

procedure THessian2Output.WriteNull;
begin
  if BUFFER_SIZE < FOffset + 16 then Flush;

  FBuffer[FOffset] := Byte('N'); Inc(FOffset);
end;

procedure THessian2Output.WriteBytes(ASourceStream: TStream);
begin
  if ASourceStream = nil then
  begin
    WriteNull;
  end
  else begin
    WriteBytes(ASourceStream, 0, ASourceStream.Size);
  end;
end;

procedure THessian2Output.WriteBytes(ASourceStream: TStream; AOffset, ACount: integer);
var
  sublen: integer;
  N: integer;
begin
  if ASourceStream = nil then
  begin
    WriteNull;
  end
  else begin
    if AOffset > 0 then
    begin
      ASourceStream.Position := AOffset;
    end
    else begin
      ASourceStream.Position := 0;
    end;

    if BUFFER_SIZE < FOffset + 16 then Flush;

    while ACount > $8000 do
    begin
      FBuffer[FOffset] := Byte('b'); Inc(FOffset);
      FBuffer[FOffset] := Byte($8000 shr 8 ); Inc(FOffset);
      FBuffer[FOffset] := Byte($8000); Inc(FOffset);

      sublen := $8000;
      while sublen > 0 do
      begin
        if sublen > (BUFFER_SIZE - FOffset) then N := BUFFER_SIZE - FOffset else N := sublen;
        ASourceStream.ReadBuffer(FBuffer, N); Inc(FOffset, N);

        // Flush
        FStream.WriteBuffer(FBuffer, FOffset);
        FOffset := 0;

        Dec(sublen, N);
      end;
      ACount := ACount - $8000;
      //AOffset := AOffset + $80000;
    end;

    if ACount < $10 then
    begin
      FBuffer[FOffset] := Byte(BYTES_DIRECT + ACount); Inc(FOffset);
    end
    else begin
      FBuffer[FOffset] := Byte('B'); Inc(FOffset);
      FBuffer[FOffset] := Byte(ACount shr 8 ); Inc(FOffset);
      FBuffer[FOffset] := Byte(ACount); Inc(FOffset);
    end;

    while ACount > 0 do
    begin
      if ACount > (BUFFER_SIZE - FOffset) then N := BUFFER_SIZE - FOffset else N := ACount;
      ASourceStream.ReadBuffer(FBuffer, N); Inc(FOffset, N);

      // Flush
      FStream.WriteBuffer(FBuffer, FOffset);
      FOffset := 0;

      Dec(ACount, N);
    end;
  end
end;

procedure THessian2Output.WriteMapBegin;
begin
  WriteMapBegin('');
end;

procedure THessian2Output.WriteMapBegin(const AType: WideString);
begin
  if BUFFER_SIZE < FOffset + 16 then Flush;

  FBuffer[FOffset] := Byte('M'); Inc(FOffset);
  WriteType(AType);
end;

procedure THessian2Output.WriteMapEnd;
begin
  if BUFFER_SIZE < FOffset + 16 then Flush;

  FBuffer[FOffset] := Byte('z'); Inc(FOffset);
end;

function THessian2Output.WriteListBegin(ALength: integer): boolean;
begin
  result := WriteListBegin(ALength, '');
end;

function THessian2Output.WriteListBegin(ALength: integer; const AType: WideString): boolean;
var
  refV: integer;
begin
  if _typeRefs <> nil then
  begin
    refV := _typeRefs.IndexOf(AType);
    if refV >= 0 then
    begin
      refV := Integer(_typeRefs.Objects[refV]);

      if BUFFER_SIZE < FOffset + 16 then Flush;

      FBuffer[FOffset] := Byte(LIST_FIXED); Inc(FOffset);

      WriteInt(refV);
      WriteInt(ALength);

      result := false;
      exit;
    end
  end;

  if BUFFER_SIZE < FOffset + 16 then Flush;

  FBuffer[FOffset] := Byte('V'); Inc(FOffset);
  WriteType(AType);

  if BUFFER_SIZE < FOffset + 16 then Flush;

  if ALength < 0 then
  begin
  end
  else if ALength < $100 then
  begin
    FBuffer[FOffset] := Byte(LENGTH_BYTE); Inc(FOffset);
    FBuffer[FOffset] := Byte(ALength); Inc(FOffset);
  end
  else begin
    FBuffer[FOffset] := Byte('l'); Inc(FOffset);
    FBuffer[FOffset] := Byte(ALength shr 24); Inc(FOffset);
    FBuffer[FOffset] := Byte(ALength shr 16); Inc(FOffset);
    FBuffer[FOffset] := Byte(ALength shr 8 ); Inc(FOffset);
    FBuffer[FOffset] := Byte(ALength); Inc(FOffset);
  end;
  result := True;
end;

procedure THessian2Output.WriteListEnd;
begin
  if BUFFER_SIZE < FOffset + 16 then Flush;

  FBuffer[FOffset] := Byte('z'); Inc(FOffset);
end;

procedure THessian2Output._WriteString(const AValue: WideString; AOffset, ACount: integer);
var
  sublen: integer;
  tail: integer;
begin
  while ACount > $8000 do
  begin
    if BUFFER_SIZE < FOffset + 16 then Flush;

    sublen := $8000;
    // chunk can't end in high surrogate
    tail := Integer(AValue[AOffset + sublen - 1]);
    if ($D800 <= tail) and (tail <= $DBFF) then dec(sublen);

    FBuffer[FOffset] := Byte('s'); Inc(FOffset);
    FBuffer[FOffset] := Byte(sublen shr 8 ); Inc(FOffset);
    FBuffer[FOffset] := Byte(sublen); Inc(FOffset);

    PrintString(AValue, AOffset, sublen);

    ACount := ACount - sublen;
    AOffset := AOffset + sublen;
  end;

  if BUFFER_SIZE < FOffset + 16 then Flush;

  if ACount <= STRING_DIRECT_MAX then
  begin
    FBuffer[FOffset] := Byte(STRING_DIRECT + ACount); Inc(FOffset);
  end
  else begin
    FBuffer[FOffset] := Byte('S'); Inc(FOffset);
    FBuffer[FOffset] := Byte(ACount shr 8 ); Inc(FOffset);
    FBuffer[FOffset] := Byte(ACount); Inc(FOffset);
  end;
  PrintString(AValue, AOffset, ACount);
end;

procedure THessian2Output.WriteType(const AType: WideString);
var
  Len: integer;
  typeRefV: integer;
begin
  Len := Length(AType);
  if Len = 0 then exit;

  if _typeRefs = nil then
  begin
    _typeRefs := TStringList.Create;
  end;

  typeRefV := _typeRefs.IndexOf(AType);
  if typeRefV >= 0 then
  begin
    typeRefV := Integer(_typeRefs.Objects[typeRefV]);

    if BUFFER_SIZE < FOffset + 16 then Flush;

    FBuffer[FOffset] := Byte(TYPE_REF); Inc(FOffset);

    writeInt(typeRefV);
  end
  else begin
    _typeRefs.AddObject(AType, TObject(_typeRefs.Count));

    if BUFFER_SIZE < FOffset + 16 then Flush;

    FBuffer[FOffset] := Byte('t'); Inc(FOffset);
    FBuffer[FOffset] := Byte(Len shr 8 ); Inc(FOffset);
    FBuffer[FOffset] := Byte(Len); Inc(FOffset);
    PrintString(AType, 0, Len);
  end
end;

procedure THessian2Output.PrintString(const AValue: WideString; AOffset, ACount: integer);
var
  I: integer;
  ch: integer;
begin
  for i := 1 to ACount do
  begin
    if BUFFER_SIZE < FOffset + 16 then Flush;

    // encoded as UTF-8
    ch := Integer(AValue[i + AOffset]);
    if ch < $80 then
    begin
      FBuffer[FOffset] := Byte(ch); Inc(FOffset);
    end
    else if ch < $800 then
    begin
      FBuffer[FOffset] := Byte($C0 + ((ch shr 6) and $1F)); Inc(FOffset);
      FBuffer[FOffset] := Byte($80 + (ch and $3F)); Inc(FOffset);
    end
    else begin
      FBuffer[FOffset] := Byte($E0 + ((ch shr 12) and $F)); Inc(FOffset);
      FBuffer[FOffset] := Byte($80 + ((ch shr 6) and $3F)); Inc(FOffset);
      FBuffer[FOffset] := Byte($80 + (ch and $3F)); Inc(FOffset);
    end
  end
end;

procedure THessian2Output.Flush;
var
  offset: integer;
begin
  offset := FOffset;
  if offset > 0 then
  begin
    FOffset := 0;
    FStream.WriteBuffer(FBuffer, offset);
  end
end;
end.