Thrift-1401: JSON-protocol for Delphi XE Libraries
Client: delphi
Patch: Jens Geyer
Adds support for the JSON protocol to the existing Delphi XE libraries.
git-svn-id: https://svn.apache.org/repos/asf/thrift/trunk@1200538 13f79535-47bb-0310-9956-ffa450edef68
diff --git a/lib/delphi/src/Thrift.Protocol.JSON.pas b/lib/delphi/src/Thrift.Protocol.JSON.pas
new file mode 100644
index 0000000..6fd6493
--- /dev/null
+++ b/lib/delphi/src/Thrift.Protocol.JSON.pas
@@ -0,0 +1,1165 @@
+(*
+ * Licensed to the Apache Software Foundation (ASF) under one
+ * or more contributor license agreements. See the NOTICE file
+ * distributed with this work for additional information
+ * regarding copyright ownership. The ASF licenses this file
+ * to you under the Apache License, Version 2.0 (the
+ * "License"); you may not use this file except in compliance
+ * with the License. You may obtain a copy of the License at
+ *
+ * http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing,
+ * software distributed under the License is distributed on an
+ * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+ * KIND, either express or implied. See the License for the
+ * specific language governing permissions and limitations
+ * under the License.
+ *)
+
+{$SCOPEDENUMS ON}
+
+unit Thrift.Protocol.JSON;
+
+interface
+
+uses
+ Classes,
+ SysUtils,
+ Math,
+ IdCoderMIME,
+ Generics.Collections,
+ Thrift.Transport,
+ Thrift.Protocol;
+
+type
+ IJSONProtocol = interface( IProtocol)
+ ['{F0DAFDBD-692A-4B71-9736-F5D485A2178F}']
+ // Read a byte that must match b; otherwise an exception is thrown.
+ procedure ReadJSONSyntaxChar( b : Byte);
+ end;
+
+ // JSON protocol implementation for thrift.
+ // This is a full-featured protocol supporting Write and Read.
+ // Please see the C++ class header for a detailed description of the protocol's wire format.
+ // Adapted from the C# version.
+ TJSONProtocolImpl = class( TProtocolImpl, IJSONProtocol)
+ public
+ type
+ TFactory = class( TInterfacedObject, IProtocolFactory)
+ public
+ function GetProtocol( trans: ITransport): IProtocol;
+ end;
+
+ private
+ class function GetTypeNameForTypeID(typeID : TType) : string;
+ class function GetTypeIDForTypeName( const name : string) : TType;
+
+ protected
+ type
+ // Base class for tracking JSON contexts that may require
+ // inserting/Reading additional JSON syntax characters.
+ // This base context does nothing.
+ TJSONBaseContext = class
+ protected
+ FProto : IJSONProtocol;
+ public
+ constructor Create( const aProto : IJSONProtocol);
+ procedure Write; virtual;
+ procedure Read; virtual;
+ function EscapeNumbers : Boolean; virtual;
+ end;
+
+ // Context for JSON lists.
+ // Will insert/Read commas before each item except for the first one.
+ TJSONListContext = class( TJSONBaseContext)
+ private
+ FFirst : Boolean;
+ public
+ constructor Create( const aProto : IJSONProtocol);
+ procedure Write; override;
+ procedure Read; override;
+ end;
+
+ // Context for JSON records. Will insert/Read colons before the value portion of each record
+ // pair, and commas before each key except the first. In addition, will indicate that numbers
+ // in the key position need to be escaped in quotes (since JSON keys must be strings).
+ TJSONPairContext = class( TJSONBaseContext)
+ private
+ FFirst, FColon : Boolean;
+ public
+ constructor Create( const aProto : IJSONProtocol);
+ procedure Write; override;
+ procedure Read; override;
+ function EscapeNumbers : Boolean; override;
+ end;
+
+ // Holds up to one byte from the transport
+ TLookaheadReader = class
+ protected
+ FProto : IJSONProtocol;
+ constructor Create( const aProto : IJSONProtocol);
+
+ private
+ FHasData : Boolean;
+ FData : TBytes;
+
+ public
+ // Return and consume the next byte to be Read, either taking it from the
+ // data buffer if present or getting it from the transport otherwise.
+ function Read : Byte;
+
+ // Return the next byte to be Read without consuming, filling the data
+ // buffer if it has not been filled alReady.
+ function Peek : Byte;
+ end;
+
+ protected
+ // Stack of nested contexts that we may be in
+ FContextStack : TStack<TJSONBaseContext>;
+
+ // Current context that we are in
+ FContext : TJSONBaseContext;
+
+ // Reader that manages a 1-byte buffer
+ FReader : TLookaheadReader;
+
+ // Push/pop a new JSON context onto/from the stack.
+ procedure PushContext( aCtx : TJSONBaseContext);
+ procedure PopContext;
+
+ public
+ // TJSONProtocolImpl Constructor
+ constructor Create( aTrans : ITransport);
+ destructor Destroy; override;
+
+ protected
+ // IJSONProtocol
+ // Read a byte that must match b; otherwise an exception is thrown.
+ procedure ReadJSONSyntaxChar( b : Byte);
+
+ private
+ // Convert a byte containing a hex char ('0'-'9' or 'a'-'f') into its corresponding hex value
+ class function HexVal( ch : Byte) : Byte;
+
+ // Convert a byte containing a hex value to its corresponding hex character
+ class function HexChar( val : Byte) : Byte;
+
+ // Write the bytes in array buf as a JSON characters, escaping as needed
+ procedure WriteJSONString( const b : TBytes); overload;
+ procedure WriteJSONString( str : string); overload;
+
+ // Write out number as a JSON value. If the context dictates so, it will be
+ // wrapped in quotes to output as a JSON string.
+ procedure WriteJSONInteger( num : Int64);
+
+ // Write out a double as a JSON value. If it is NaN or infinity or if the
+ // context dictates escaping, Write out as JSON string.
+ procedure WriteJSONDouble( const num : Double);
+
+ // Write out contents of byte array b as a JSON string with base-64 encoded data
+ procedure WriteJSONBase64( const b : TBytes);
+
+ procedure WriteJSONObjectStart;
+ procedure WriteJSONObjectEnd;
+ procedure WriteJSONArrayStart;
+ procedure WriteJSONArrayEnd;
+
+ public
+ // IProtocol
+ procedure WriteMessageBegin( aMsg : IMessage); override;
+ procedure WriteMessageEnd; override;
+ procedure WriteStructBegin(struc: IStruct); override;
+ procedure WriteStructEnd; override;
+ procedure WriteFieldBegin(field: IField); override;
+ procedure WriteFieldEnd; override;
+ procedure WriteFieldStop; override;
+ procedure WriteMapBegin(map: IMap); override;
+ procedure WriteMapEnd; override;
+ procedure WriteListBegin( list: IList); override;
+ procedure WriteListEnd(); override;
+ procedure WriteSetBegin( set_: ISet ); override;
+ procedure WriteSetEnd(); override;
+ procedure WriteBool( b: Boolean); override;
+ procedure WriteByte( b: ShortInt); override;
+ procedure WriteI16( i16: SmallInt); override;
+ procedure WriteI32( i32: Integer); override;
+ procedure WriteI64( i64: Int64); override;
+ procedure WriteDouble( d: Double); override;
+ procedure WriteString( const s: string ); override;
+ procedure WriteBinary( const b: TBytes); override;
+ //
+ function ReadMessageBegin: IMessage; override;
+ procedure ReadMessageEnd(); override;
+ function ReadStructBegin: IStruct; override;
+ procedure ReadStructEnd; override;
+ function ReadFieldBegin: IField; override;
+ procedure ReadFieldEnd(); override;
+ function ReadMapBegin: IMap; override;
+ procedure ReadMapEnd(); override;
+ function ReadListBegin: IList; override;
+ procedure ReadListEnd(); override;
+ function ReadSetBegin: ISet; override;
+ procedure ReadSetEnd(); override;
+ function ReadBool: Boolean; override;
+ function ReadByte: ShortInt; override;
+ function ReadI16: SmallInt; override;
+ function ReadI32: Integer; override;
+ function ReadI64: Int64; override;
+ function ReadDouble:Double; override;
+ function ReadString : string; override;
+ function ReadBinary: TBytes; override;
+
+
+ private
+ // Reading methods.
+
+ // Read in a JSON string, unescaping as appropriate.
+ // Skip Reading from the context if skipContext is true.
+ function ReadJSONString( skipContext : Boolean) : TBytes;
+
+ // Return true if the given byte could be a valid part of a JSON number.
+ function IsJSONNumeric( b : Byte) : Boolean;
+
+ // Read in a sequence of characters that are all valid in JSON numbers. Does
+ // not do a complete regex check to validate that this is actually a number.
+ function ReadJSONNumericChars : String;
+
+ // Read in a JSON number. If the context dictates, Read in enclosing quotes.
+ function ReadJSONInteger : Int64;
+
+ // Read in a JSON double value. Throw if the value is not wrapped in quotes
+ // when expected or if wrapped in quotes when not expected.
+ function ReadJSONDouble : Double;
+
+ // Read in a JSON string containing base-64 encoded data and decode it.
+ function ReadJSONBase64 : TBytes;
+
+ procedure ReadJSONObjectStart;
+ procedure ReadJSONObjectEnd;
+ procedure ReadJSONArrayStart;
+ procedure ReadJSONArrayEnd;
+ end;
+
+
+implementation
+
+var
+ COMMA : TBytes;
+ COLON : TBytes;
+ LBRACE : TBytes;
+ RBRACE : TBytes;
+ LBRACKET : TBytes;
+ RBRACKET : TBytes;
+ QUOTE : TBytes;
+ BACKSLASH : TBytes;
+ ZERO : TBytes;
+ ESCSEQ : TBytes;
+
+const
+ VERSION = 1;
+ JSON_CHAR_TABLE : array[0..$2F] of Byte
+ = (0,0,0,0, 0,0,0,0, Byte('b'),Byte('t'),Byte('n'),0, Byte('f'),Byte('r'),0,0,
+ 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0,
+ 1,1,Byte('"'),1, 1,1,1,1, 1,1,1,1, 1,1,1,1);
+
+ ESCAPE_CHARS = '"\btnfr';
+ ESCAPE_CHAR_VALS = '"\'#8#9#10#12#13;
+
+ DEF_STRING_SIZE = 16;
+
+ NAME_BOOL = 'tf';
+ NAME_BYTE = 'i8';
+ NAME_I16 = 'i16';
+ NAME_I32 = 'i32';
+ NAME_I64 = 'i64';
+ NAME_DOUBLE = 'dbl';
+ NAME_STRUCT = 'rec';
+ NAME_STRING = 'str';
+ NAME_MAP = 'map';
+ NAME_LIST = 'lst';
+ NAME_SET = 'set';
+
+ INVARIANT_CULTURE : TFormatSettings
+ = ( ThousandSeparator: ',';
+ DecimalSeparator: '.');
+
+
+
+//--- TJSONProtocolImpl ----------------------
+
+
+function TJSONProtocolImpl.TFactory.GetProtocol( trans: ITransport): IProtocol;
+begin
+ result := TJSONProtocolImpl.Create(trans);
+end;
+
+class function TJSONProtocolImpl.GetTypeNameForTypeID(typeID : TType) : string;
+begin
+ case typeID of
+ TType.Bool_: result := NAME_BOOL;
+ TType.Byte_: result := NAME_BYTE;
+ TType.I16: result := NAME_I16;
+ TType.I32: result := NAME_I32;
+ TType.I64: result := NAME_I64;
+ TType.Double_: result := NAME_DOUBLE;
+ TType.String_: result := NAME_STRING;
+ TType.Struct: result := NAME_STRUCT;
+ TType.Map: result := NAME_MAP;
+ TType.Set_: result := NAME_SET;
+ TType.List: result := NAME_LIST;
+ else
+ raise TProtocolException.Create( TProtocolException.NOT_IMPLEMENTED, 'Unrecognized type ('+IntToStr(Ord(typeID))+')');
+ end;
+end;
+
+
+class function TJSONProtocolImpl.GetTypeIDForTypeName( const name : string) : TType;
+begin
+ if name = NAME_BOOL then result := TType.Bool_
+ else if name = NAME_BYTE then result := TType.Byte_
+ else if name = NAME_I16 then result := TType.I16
+ else if name = NAME_I32 then result := TType.I32
+ else if name = NAME_I64 then result := TType.I64
+ else if name = NAME_DOUBLE then result := TType.Double_
+ else if name = NAME_STRUCT then result := TType.Struct
+ else if name = NAME_STRING then result := TType.String_
+ else if name = NAME_MAP then result := TType.Map
+ else if name = NAME_LIST then result := TType.List
+ else if name = NAME_SET then result := TType.Set_
+ else raise TProtocolException.Create( TProtocolException.NOT_IMPLEMENTED, 'Unrecognized type ('+name+')');
+end;
+
+
+constructor TJSONProtocolImpl.TJSONBaseContext.Create( const aProto : IJSONProtocol);
+begin
+ inherited Create;
+ FProto := aProto;
+end;
+
+
+procedure TJSONProtocolImpl.TJSONBaseContext.Write;
+begin
+ // nothing
+end;
+
+
+procedure TJSONProtocolImpl.TJSONBaseContext.Read;
+begin
+ // nothing
+end;
+
+
+function TJSONProtocolImpl.TJSONBaseContext.EscapeNumbers : Boolean;
+begin
+ result := FALSE;
+end;
+
+
+constructor TJSONProtocolImpl.TJSONListContext.Create( const aProto : IJSONProtocol);
+begin
+ inherited Create( aProto);
+ FFirst := TRUE;
+end;
+
+
+procedure TJSONProtocolImpl.TJSONListContext.Write;
+begin
+ if FFirst
+ then FFirst := FALSE
+ else FProto.Transport.Write( COMMA);
+end;
+
+
+procedure TJSONProtocolImpl.TJSONListContext.Read;
+begin
+ if FFirst
+ then FFirst := FALSE
+ else FProto.ReadJSONSyntaxChar( COMMA[0]);
+end;
+
+
+constructor TJSONProtocolImpl.TJSONPairContext.Create( const aProto : IJSONProtocol);
+begin
+ inherited Create( aProto);
+ FFirst := TRUE;
+ FColon := TRUE;
+end;
+
+
+procedure TJSONProtocolImpl.TJSONPairContext.Write;
+begin
+ if FFirst then begin
+ FFirst := FALSE;
+ FColon := TRUE;
+ end
+ else begin
+ if FColon
+ then FProto.Transport.Write( COLON)
+ else FProto.Transport.Write( COMMA);
+ FColon := not FColon;
+ end;
+end;
+
+
+procedure TJSONProtocolImpl.TJSONPairContext.Read;
+begin
+ if FFirst then begin
+ FFirst := FALSE;
+ FColon := TRUE;
+ end
+ else begin
+ if FColon
+ then FProto.ReadJSONSyntaxChar( COLON[0])
+ else FProto.ReadJSONSyntaxChar( COMMA[0]);
+ FColon := not FColon;
+ end;
+end;
+
+
+function TJSONProtocolImpl.TJSONPairContext.EscapeNumbers : Boolean;
+begin
+ result := FColon;
+end;
+
+
+constructor TJSONProtocolImpl.TLookaheadReader.Create( const aProto : IJSONProtocol);
+begin
+ inherited Create;
+ FProto := aProto;
+ FHasData := FALSE;
+end;
+
+
+function TJSONProtocolImpl.TLookaheadReader.Read : Byte;
+begin
+ if FHasData
+ then FHasData := FALSE
+ else begin
+ SetLength( FData, 1);
+ FProto.Transport.ReadAll( FData, 0, 1);
+ end;
+ result := FData[0];
+end;
+
+
+function TJSONProtocolImpl.TLookaheadReader.Peek : Byte;
+begin
+ if not FHasData then begin
+ SetLength( FData, 1);
+ FProto.Transport.ReadAll( FData, 0, 1);
+ FHasData := TRUE;
+ end;
+ result := FData[0];
+end;
+
+
+procedure TJSONProtocolImpl.PushContext( aCtx : TJSONBaseContext);
+begin
+ FContextStack.Push( FContext);
+ FContext := aCtx;
+end;
+
+procedure TJSONProtocolImpl.PopContext;
+begin
+ FreeAndNil(FContext);
+ FContext := FContextStack.Pop;
+end;
+
+
+constructor TJSONProtocolImpl.Create( aTrans : ITransport);
+begin
+ inherited Create( aTrans);
+
+ // Stack of nested contexts that we may be in
+ FContextStack := TStack<TJSONBaseContext>.Create;
+
+ FContext := TJSONBaseContext.Create( Self);
+ FReader := TLookaheadReader.Create( Self);
+end;
+
+
+destructor TJSONProtocolImpl.Destroy;
+begin
+ try
+ FreeAndNil( FReader);
+ FreeAndNil( FContext);
+ FreeAndNil( FContextStack);
+ finally
+ inherited Destroy;
+ end;
+end;
+
+
+procedure TJSONProtocolImpl.ReadJSONSyntaxChar( b : Byte);
+var ch : Byte;
+begin
+ ch := FReader.Read;
+ if (ch <> b)
+ then raise TProtocolException.Create( TProtocolException.INVALID_DATA, 'Unexpected character ('+Char(ch)+')');
+end;
+
+
+class function TJSONProtocolImpl.HexVal( ch : Byte) : Byte;
+var i : Integer;
+begin
+ i := StrToIntDef( '$0'+Char(ch), -1);
+ if (0 <= i) and (i < $10)
+ then result := i
+ else raise TProtocolException.Create( TProtocolException.INVALID_DATA, 'Expected hex character ('+Char(ch)+')');
+end;
+
+
+class function TJSONProtocolImpl.HexChar( val : Byte) : Byte;
+const HEXCHARS = '0123456789ABCDEF';
+begin
+ result := Byte( PChar(HEXCHARS)[val and $0F]);
+ ASSERT( Pos( Char(result), HEXCHARS) > 0);
+end;
+
+
+procedure TJSONProtocolImpl.WriteJSONString( str : string);
+begin
+ WriteJSONString( SysUtils.TEncoding.UTF8.GetBytes( str));
+end;
+
+
+procedure TJSONProtocolImpl.WriteJSONString( const b : TBytes);
+var i : Integer;
+ tmp : TBytes;
+begin
+ FContext.Write;
+ Transport.Write( QUOTE);
+ for i := 0 to Length(b)-1 do begin
+
+ if (b[i] and $00FF) >= $30 then begin
+
+ if (b[i] = BACKSLASH[0]) then begin
+ Transport.Write( BACKSLASH);
+ Transport.Write( BACKSLASH);
+ end
+ else begin
+ Transport.Write( b, i, 1);
+ end;
+
+ end
+ else begin
+ SetLength( tmp, 2);
+ tmp[0] := JSON_CHAR_TABLE[b[i]];
+ if (tmp[0] = 1) then begin
+ Transport.Write( b, i, 1)
+ end
+ else if (tmp[0] > 1) then begin
+ Transport.Write( BACKSLASH);
+ Transport.Write( tmp, 0, 1);
+ end
+ else begin
+ Transport.Write( ESCSEQ);
+ tmp[0] := HexChar( b[i] div $10);
+ tmp[1] := HexChar( b[i]);
+ Transport.Write( tmp, 0, 2);
+ end;
+ end;
+ end;
+ Transport.Write( QUOTE);
+end;
+
+
+procedure TJSONProtocolImpl.WriteJSONInteger( num : Int64);
+var str : String;
+ escapeNum : Boolean;
+begin
+ FContext.Write;
+ str := IntToStr(num);
+
+ escapeNum := FContext.EscapeNumbers;
+ if escapeNum
+ then Transport.Write( QUOTE);
+
+ Transport.Write( SysUtils.TEncoding.UTF8.GetBytes( str));
+
+ if escapeNum
+ then Transport.Write( QUOTE);
+end;
+
+
+procedure TJSONProtocolImpl.WriteJSONDouble( const num : Double);
+var str : string;
+ special : Boolean;
+ escapeNum : Boolean;
+begin
+ FContext.Write;
+
+ str := FloatToStr( num, INVARIANT_CULTURE);
+ special := FALSE;
+
+ case UpCase(str[1]) of
+ 'N' : special := TRUE; // NaN
+ 'I' : special := TRUE; // Infinity
+ '-' : special := (UpCase(str[2]) = 'I'); // -Infinity
+ end;
+
+ escapeNum := special or FContext.EscapeNumbers;
+
+
+ if escapeNum
+ then Transport.Write( QUOTE);
+
+ Transport.Write( SysUtils.TEncoding.UTF8.GetBytes( str));
+
+ if escapeNum
+ then Transport.Write( QUOTE);
+end;
+
+
+procedure TJSONProtocolImpl.WriteJSONBase64( const b : TBytes);
+var str : string;
+ tmp : TBytes;
+ i : Integer;
+begin
+ FContext.Write;
+ Transport.Write( QUOTE);
+
+ // First base64-encode b, then write the resulting 8-bit chars
+ // Unfortunately, EncodeBytes() returns a string of 16-bit (wide) chars
+ // And for the sake of efficiency, we want to write everything at once
+ str := TIdEncoderMIME.EncodeBytes(b);
+ ASSERT( SizeOf(str[1]) = SizeOf(Word));
+ SetLength( tmp, Length(str));
+ for i := 1 to Length(str) do begin
+ ASSERT( Hi(Word(str[i])) = 0); // base64 consists of a well-defined set of 8-bit chars only
+ tmp[i-1] := Lo(Word(str[i])); // extract the lower byte
+ end;
+ Transport.Write( tmp); // now write all the data
+
+ Transport.Write( QUOTE);
+end;
+
+
+procedure TJSONProtocolImpl.WriteJSONObjectStart;
+begin
+ FContext.Write;
+ Transport.Write( LBRACE);
+ PushContext( TJSONPairContext.Create( Self));
+end;
+
+
+procedure TJSONProtocolImpl.WriteJSONObjectEnd;
+begin
+ PopContext;
+ Transport.Write( RBRACE);
+end;
+
+
+procedure TJSONProtocolImpl.WriteJSONArrayStart;
+begin
+ FContext.Write;
+ Transport.Write( LBRACKET);
+ PushContext( TJSONListContext.Create( Self));
+end;
+
+
+procedure TJSONProtocolImpl.WriteJSONArrayEnd;
+begin
+ PopContext;
+ Transport.Write( RBRACKET);
+end;
+
+
+procedure TJSONProtocolImpl.WriteMessageBegin( aMsg : IMessage);
+begin
+ WriteJSONArrayStart;
+ WriteJSONInteger(VERSION);
+
+ WriteJSONString( SysUtils.TEncoding.UTF8.GetBytes( aMsg.Name));
+
+ WriteJSONInteger( LongInt( aMsg.Type_));
+ WriteJSONInteger( aMsg.SeqID);
+end;
+
+procedure TJSONProtocolImpl.WriteMessageEnd;
+begin
+ WriteJSONArrayEnd;
+end;
+
+
+procedure TJSONProtocolImpl.WriteStructBegin( struc: IStruct);
+begin
+ WriteJSONObjectStart;
+end;
+
+
+procedure TJSONProtocolImpl.WriteStructEnd;
+begin
+ WriteJSONObjectEnd;
+end;
+
+
+procedure TJSONProtocolImpl.WriteFieldBegin( field : IField);
+begin
+ WriteJSONInteger(field.ID);
+ WriteJSONObjectStart;
+ WriteJSONString( GetTypeNameForTypeID(field.Type_));
+end;
+
+
+procedure TJSONProtocolImpl.WriteFieldEnd;
+begin
+ WriteJSONObjectEnd;
+end;
+
+
+procedure TJSONProtocolImpl.WriteFieldStop;
+begin
+ // nothing to do
+end;
+
+procedure TJSONProtocolImpl.WriteMapBegin( map: IMap);
+begin
+ WriteJSONArrayStart;
+ WriteJSONString( GetTypeNameForTypeID( map.KeyType));
+ WriteJSONString( GetTypeNameForTypeID( map.ValueType));
+ WriteJSONInteger( map.Count);
+ WriteJSONObjectStart;
+end;
+
+
+procedure TJSONProtocolImpl.WriteMapEnd;
+begin
+ WriteJSONObjectEnd;
+ WriteJSONArrayEnd;
+end;
+
+
+procedure TJSONProtocolImpl.WriteListBegin( list: IList);
+begin
+ WriteJSONArrayStart;
+ WriteJSONString( GetTypeNameForTypeID( list.ElementType));
+ WriteJSONInteger(list.Count);
+end;
+
+
+procedure TJSONProtocolImpl.WriteListEnd;
+begin
+ WriteJSONArrayEnd;
+end;
+
+
+procedure TJSONProtocolImpl.WriteSetBegin( set_: ISet);
+begin
+ WriteJSONArrayStart;
+ WriteJSONString( GetTypeNameForTypeID( set_.ElementType));
+ WriteJSONInteger( set_.Count);
+end;
+
+
+procedure TJSONProtocolImpl.WriteSetEnd;
+begin
+ WriteJSONArrayEnd;
+end;
+
+procedure TJSONProtocolImpl.WriteBool( b: Boolean);
+begin
+ if b
+ then WriteJSONInteger( 1)
+ else WriteJSONInteger( 0);
+end;
+
+procedure TJSONProtocolImpl.WriteByte( b: ShortInt);
+begin
+ WriteJSONInteger( b);
+end;
+
+procedure TJSONProtocolImpl.WriteI16( i16: SmallInt);
+begin
+ WriteJSONInteger( i16);
+end;
+
+procedure TJSONProtocolImpl.WriteI32( i32: Integer);
+begin
+ WriteJSONInteger( i32);
+end;
+
+procedure TJSONProtocolImpl.WriteI64( i64: Int64);
+begin
+ WriteJSONInteger(i64);
+end;
+
+procedure TJSONProtocolImpl.WriteDouble( d: Double);
+begin
+ WriteJSONDouble( d);
+end;
+
+procedure TJSONProtocolImpl.WriteString( const s: string );
+begin
+ WriteJSONString( SysUtils.TEncoding.UTF8.GetBytes( s));
+end;
+
+procedure TJSONProtocolImpl.WriteBinary( const b: TBytes);
+begin
+ WriteJSONBase64( b);
+end;
+
+
+function TJSONProtocolImpl.ReadJSONString( skipContext : Boolean) : TBytes;
+var buffer : TMemoryStream;
+ ch : Byte;
+ off : Integer;
+ tmp : TBytes;
+begin
+ buffer := TMemoryStream.Create;
+ try
+ if not skipContext
+ then FContext.Read;
+
+ ReadJSONSyntaxChar( QUOTE[0]);
+
+ while TRUE do begin
+ ch := FReader.Read;
+
+ if (ch = QUOTE[0])
+ then Break;
+
+ if (ch = ESCSEQ[0])
+ then begin
+ ch := FReader.Read;
+ if (ch = ESCSEQ[1])
+ then begin
+ ReadJSONSyntaxChar( ZERO[0]);
+ ReadJSONSyntaxChar( ZERO[0]);
+ SetLength( tmp, 2);
+ Transport.ReadAll( tmp, 0, 2);
+ ch := (HexVal(tmp[0]) shl 4) + HexVal(tmp[1]);
+ end
+ else begin
+ off := Pos( Char(ch), ESCAPE_CHARS);
+ if off < 1
+ then raise TProtocolException.Create( TProtocolException.INVALID_DATA, 'Expected control char');
+ ch := Byte( ESCAPE_CHAR_VALS[off]);
+ end;
+ end;
+ buffer.Write( ch, 1);
+ end;
+
+ SetLength( result, buffer.Size);
+ Move( buffer.Memory^, result[0], Length(result));
+
+ finally
+ buffer.Free;
+ end;
+end;
+
+
+function TJSONProtocolImpl.IsJSONNumeric( b : Byte) : Boolean;
+const NUMCHARS = ['+','-','.','0','1','2','3','4','5','6','7','8','9','E','e'];
+begin
+ result := CharInSet( Char(b), NUMCHARS);
+end;
+
+
+function TJSONProtocolImpl.ReadJSONNumericChars : string;
+var strbld : TThriftStringBuilder;
+ ch : Byte;
+begin
+ strbld := TThriftStringBuilder.Create;
+ try
+ while TRUE do begin
+ ch := FReader.Peek;
+ if IsJSONNumeric(ch)
+ then strbld.Append( Char(FReader.Read))
+ else Break;
+ end;
+ result := strbld.ToString;
+
+ finally
+ strbld.Free;
+ end;
+end;
+
+
+function TJSONProtocolImpl.ReadJSONInteger : Int64;
+var str : string;
+begin
+ FContext.Read;
+ if FContext.EscapeNumbers
+ then ReadJSONSyntaxChar( QUOTE[0]);
+
+ str := ReadJSONNumericChars;
+
+ if FContext.EscapeNumbers
+ then ReadJSONSyntaxChar( QUOTE[0]);
+
+ try
+ result := StrToInt64(str);
+ except
+ on e:Exception do begin
+ raise TProtocolException.Create( TProtocolException.INVALID_DATA,
+ 'Bad data encounted in numeric data ('+str+') ('+e.Message+')');
+ end;
+ end;
+end;
+
+
+function TJSONProtocolImpl.ReadJSONDouble : Double;
+var dub : Double;
+ str : string;
+begin
+ FContext.Read;
+
+ if FReader.Peek = QUOTE[0]
+ then begin
+ str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString( TRUE));
+ dub := StrToFloat( str, INVARIANT_CULTURE);
+
+ if not FContext.EscapeNumbers()
+ and not Math.IsNaN(dub)
+ and not Math.IsInfinite(dub)
+ then begin
+ // Throw exception -- we should not be in a string in Self case
+ raise TProtocolException.Create( TProtocolException.INVALID_DATA, 'Numeric data unexpectedly quoted');
+ end;
+ result := dub;
+ Exit;
+ end;
+
+ // will throw - we should have had a quote if escapeNum == true
+ if FContext.EscapeNumbers
+ then ReadJSONSyntaxChar( QUOTE[0]);
+
+ try
+ str := ReadJSONNumericChars;
+ result := StrToFloat( str, INVARIANT_CULTURE);
+ except
+ on e:Exception
+ do raise TProtocolException.Create( TProtocolException.INVALID_DATA,
+ 'Bad data encounted in numeric data ('+str+') ('+e.Message+')');
+ end;
+end;
+
+
+function TJSONProtocolImpl.ReadJSONBase64 : TBytes;
+var b : TBytes;
+ str : string;
+begin
+ b := ReadJSONString(false);
+
+ SetString( str, PAnsiChar(b), Length(b));
+ result := TIdDecoderMIME.DecodeBytes( str);
+end;
+
+
+procedure TJSONProtocolImpl.ReadJSONObjectStart;
+begin
+ FContext.Read;
+ ReadJSONSyntaxChar( LBRACE[0]);
+ PushContext( TJSONPairContext.Create( Self));
+end;
+
+
+procedure TJSONProtocolImpl.ReadJSONObjectEnd;
+begin
+ ReadJSONSyntaxChar( RBRACE[0]);
+ PopContext;
+end;
+
+
+procedure TJSONProtocolImpl.ReadJSONArrayStart;
+begin
+ FContext.Read;
+ ReadJSONSyntaxChar( LBRACKET[0]);
+ PushContext( TJSONListContext.Create( Self));
+end;
+
+
+procedure TJSONProtocolImpl.ReadJSONArrayEnd;
+begin
+ ReadJSONSyntaxChar( RBRACKET[0]);
+ PopContext;
+end;
+
+
+function TJSONProtocolImpl.ReadMessageBegin: IMessage;
+begin
+ result := TMessageImpl.Create;
+ ReadJSONArrayStart;
+
+ if ReadJSONInteger <> VERSION
+ then raise TProtocolException.Create( TProtocolException.BAD_VERSION, 'Message contained bad version.');
+
+ result.Name := SysUtils.TEncoding.UTF8.GetString( ReadJSONString( FALSE));
+ result.Type_ := TMessageType( ReadJSONInteger);
+ result.SeqID := ReadJSONInteger;
+end;
+
+
+procedure TJSONProtocolImpl.ReadMessageEnd;
+begin
+ ReadJSONArrayEnd;
+end;
+
+
+function TJSONProtocolImpl.ReadStructBegin : IStruct ;
+begin
+ ReadJSONObjectStart;
+ result := TStructImpl.Create('');
+end;
+
+
+procedure TJSONProtocolImpl.ReadStructEnd;
+begin
+ ReadJSONObjectEnd;
+end;
+
+
+function TJSONProtocolImpl.ReadFieldBegin : IField;
+var ch : Byte;
+ str : string;
+begin
+ result := TFieldImpl.Create;
+ ch := FReader.Peek;
+ if ch = RBRACE[0]
+ then result.Type_ := TType.Stop
+ else begin
+ result.ID := ReadJSONInteger;
+ ReadJSONObjectStart;
+
+ str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString( FALSE));
+ result.Type_ := GetTypeIDForTypeName( str);
+ end;
+end;
+
+
+procedure TJSONProtocolImpl.ReadFieldEnd;
+begin
+ ReadJSONObjectEnd;
+end;
+
+
+function TJSONProtocolImpl.ReadMapBegin : IMap;
+var str : string;
+begin
+ result := TMapImpl.Create;
+ ReadJSONArrayStart;
+
+ str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString(FALSE));
+ result.KeyType := GetTypeIDForTypeName( str);
+
+ str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString(FALSE));
+ result.ValueType := GetTypeIDForTypeName( str);
+
+ result.Count := ReadJSONInteger;
+ ReadJSONObjectStart;
+end;
+
+
+procedure TJSONProtocolImpl.ReadMapEnd;
+begin
+ ReadJSONObjectEnd;
+ ReadJSONArrayEnd;
+end;
+
+
+function TJSONProtocolImpl.ReadListBegin : IList;
+var str : string;
+begin
+ result := TListImpl.Create;
+ ReadJSONArrayStart;
+
+ str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString(FALSE));
+ result.ElementType := GetTypeIDForTypeName( str);
+ result.Count := ReadJSONInteger;
+end;
+
+
+procedure TJSONProtocolImpl.ReadListEnd;
+begin
+ ReadJSONArrayEnd;
+end;
+
+
+function TJSONProtocolImpl.ReadSetBegin : ISet;
+var str : string;
+begin
+ result := TSetImpl.Create;
+ ReadJSONArrayStart;
+
+ str := SysUtils.TEncoding.UTF8.GetString( ReadJSONString(FALSE));
+ result.ElementType := GetTypeIDForTypeName( str);
+ result.Count := ReadJSONInteger;
+end;
+
+
+procedure TJSONProtocolImpl.ReadSetEnd;
+begin
+ ReadJSONArrayEnd;
+end;
+
+
+function TJSONProtocolImpl.ReadBool : Boolean;
+begin
+ result := (ReadJSONInteger <> 0);
+end;
+
+
+function TJSONProtocolImpl.ReadByte : ShortInt;
+begin
+ result := ReadJSONInteger;
+end;
+
+
+function TJSONProtocolImpl.ReadI16 : SmallInt;
+begin
+ result := ReadJSONInteger;
+end;
+
+
+function TJSONProtocolImpl.ReadI32 : LongInt;
+begin
+ result := ReadJSONInteger;
+end;
+
+
+function TJSONProtocolImpl.ReadI64 : Int64;
+begin
+ result := ReadJSONInteger;
+end;
+
+
+function TJSONProtocolImpl.ReadDouble : Double;
+begin
+ result := ReadJSONDouble;
+end;
+
+
+function TJSONProtocolImpl.ReadString : string;
+begin
+ result := SysUtils.TEncoding.UTF8.GetString( ReadJSONString( FALSE));
+end;
+
+
+function TJSONProtocolImpl.ReadBinary : TBytes;
+begin
+ result := ReadJSONBase64;
+end;
+
+
+//--- init code ---
+
+procedure InitBytes( var b : TBytes; aData : array of Byte);
+begin
+ SetLength( b, Length(aData));
+ Move( aData, b[0], Length(b));
+end;
+
+initialization
+ InitBytes( COMMA, [Byte(',')]);
+ InitBytes( COLON, [Byte(':')]);
+ InitBytes( LBRACE, [Byte('{')]);
+ InitBytes( RBRACE, [Byte('}')]);
+ InitBytes( LBRACKET, [Byte('[')]);
+ InitBytes( RBRACKET, [Byte(']')]);
+ InitBytes( QUOTE, [Byte('"')]);
+ InitBytes( BACKSLASH, [Byte('\')]);
+ InitBytes( ZERO, [Byte('0')]);
+ InitBytes( ESCSEQ, [Byte('\'),Byte('u'),Byte('0'),Byte('0')]);
+end.
diff --git a/lib/delphi/src/Thrift.Server.pas b/lib/delphi/src/Thrift.Server.pas
index 23b6976..2d35c19 100644
--- a/lib/delphi/src/Thrift.Server.pas
+++ b/lib/delphi/src/Thrift.Server.pas
@@ -1,191 +1,191 @@
-(*
- * Licensed to the Apache Software Foundation (ASF) under one
- * or more contributor license agreements. See the NOTICE file
- * distributed with this work for additional information
- * regarding copyright ownership. The ASF licenses this file
- * to you under the Apache License, Version 2.0 (the
- * "License"); you may not use this file except in compliance
- * with the License. You may obtain a copy of the License at
- *
- * http://www.apache.org/licenses/LICENSE-2.0
- *
- * Unless required by applicable law or agreed to in writing,
- * software distributed under the License is distributed on an
- * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
- * KIND, either express or implied. See the License for the
- * specific language governing permissions and limitations
- * under the License.
- *)
-
- unit Thrift.Server;
-
-interface
-
-uses
- SysUtils,
- Thrift,
- Thrift.Protocol,
- Thrift.Transport;
-
-type
- IServer = interface
- ['{CF9F56C6-BB39-4C7D-877B-43B416572CE6}']
- procedure Serve;
- procedure Stop;
- end;
-
- TServerImpl = class abstract( TInterfacedObject, IServer )
- public
- type
- TLogDelegate = reference to procedure( str: string);
- protected
- FProcessor : IProcessor;
- FServerTransport : IServerTransport;
- FInputTransportFactory : ITransportFactory;
- FOutputTransportFactory : ITransportFactory;
- FInputProtocolFactory : IProtocolFactory;
- FOutputProtocolFactory : IProtocolFactory;
- FLogDelegate : TLogDelegate;
-
- class procedure DefaultLogDelegate( str: string);
-
- procedure Serve; virtual; abstract;
- procedure Stop; virtual; abstract;
- public
- constructor Create(
- AProcessor :IProcessor;
- AServerTransport: IServerTransport;
- AInputTransportFactory : ITransportFactory;
- AOutputTransportFactory : ITransportFactory;
- AInputProtocolFactory : IProtocolFactory;
- AOutputProtocolFactory : IProtocolFactory;
- ALogDelegate : TLogDelegate
- ); overload;
-
- constructor Create( AProcessor :IProcessor;
- AServerTransport: IServerTransport); overload;
-
- constructor Create(
- AProcessor :IProcessor;
- AServerTransport: IServerTransport;
- ALogDelegate: TLogDelegate
- ); overload;
-
- constructor Create(
- AProcessor :IProcessor;
- AServerTransport: IServerTransport;
- ATransportFactory : ITransportFactory
- ); overload;
-
- constructor Create(
- AProcessor :IProcessor;
- AServerTransport: IServerTransport;
- ATransportFactory : ITransportFactory;
- AProtocolFactory : IProtocolFactory
- ); overload;
- end;
-
- TSimpleServer = class( TServerImpl)
- private
- FStop : Boolean;
- public
- constructor Create( AProcessor: IProcessor; AServerTransport: IServerTransport); overload;
- constructor Create( AProcessor: IProcessor; AServerTransport: IServerTransport;
- ALogDel: TServerImpl.TLogDelegate); overload;
- constructor Create( AProcessor: IProcessor; AServerTransport: IServerTransport;
- ATransportFactory: ITransportFactory); overload;
- constructor Create( AProcessor: IProcessor; AServerTransport: IServerTransport;
- ATransportFactory: ITransportFactory; AProtocolFactory: IProtocolFactory); overload;
-
- procedure Serve; override;
- procedure Stop; override;
- end;
-
-
-implementation
-
-{ TServerImpl }
-
-constructor TServerImpl.Create(AProcessor: IProcessor;
- AServerTransport: IServerTransport; ALogDelegate: TLogDelegate);
-var
- InputFactory, OutputFactory : IProtocolFactory;
- InputTransFactory, OutputTransFactory : ITransportFactory;
-
-begin
- InputFactory := TBinaryProtocolImpl.TFactory.Create;
- OutputFactory := TBinaryProtocolImpl.TFactory.Create;
- InputTransFactory := TTransportFactoryImpl.Create;
- OutputTransFactory := TTransportFactoryImpl.Create;
-
- Create(
- AProcessor,
- AServerTransport,
- InputTransFactory,
- OutputTransFactory,
- InputFactory,
- OutputFactory,
- ALogDelegate
- );
-end;
-
-constructor TServerImpl.Create(AProcessor: IProcessor;
- AServerTransport: IServerTransport);
-var
- InputFactory, OutputFactory : IProtocolFactory;
- InputTransFactory, OutputTransFactory : ITransportFactory;
-
-begin
- InputFactory := TBinaryProtocolImpl.TFactory.Create;
- OutputFactory := TBinaryProtocolImpl.TFactory.Create;
- InputTransFactory := TTransportFactoryImpl.Create;
- OutputTransFactory := TTransportFactoryImpl.Create;
-
- Create(
- AProcessor,
- AServerTransport,
- InputTransFactory,
- OutputTransFactory,
- InputFactory,
- OutputFactory,
- DefaultLogDelegate
- );
-end;
-
-constructor TServerImpl.Create(AProcessor: IProcessor;
- AServerTransport: IServerTransport; ATransportFactory: ITransportFactory);
-var
- InputProtocolFactory : IProtocolFactory;
- OutputProtocolFactory : IProtocolFactory;
-begin
- InputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
- OutputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
-
- Create( AProcessor, AServerTransport, ATransportFactory, ATransportFactory,
- InputProtocolFactory, OutputProtocolFactory, DefaultLogDelegate);
-end;
-
-constructor TServerImpl.Create(AProcessor: IProcessor;
- AServerTransport: IServerTransport; AInputTransportFactory,
- AOutputTransportFactory: ITransportFactory; AInputProtocolFactory,
- AOutputProtocolFactory: IProtocolFactory;
- ALogDelegate : TLogDelegate);
-begin
- FProcessor := AProcessor;
- FServerTransport := AServerTransport;
- FInputTransportFactory := AInputTransportFactory;
- FOutputTransportFactory := AOutputTransportFactory;
- FInputProtocolFactory := AInputProtocolFactory;
- FOutputProtocolFactory := AOutputProtocolFactory;
- FLogDelegate := ALogDelegate;
-end;
-
-class procedure TServerImpl.DefaultLogDelegate( str: string);
-begin
- Writeln( str );
-end;
-
-constructor TServerImpl.Create(AProcessor: IProcessor;
+(*
+ * Licensed to the Apache Software Foundation (ASF) under one
+ * or more contributor license agreements. See the NOTICE file
+ * distributed with this work for additional information
+ * regarding copyright ownership. The ASF licenses this file
+ * to you under the Apache License, Version 2.0 (the
+ * "License"); you may not use this file except in compliance
+ * with the License. You may obtain a copy of the License at
+ *
+ * http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing,
+ * software distributed under the License is distributed on an
+ * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+ * KIND, either express or implied. See the License for the
+ * specific language governing permissions and limitations
+ * under the License.
+ *)
+
+ unit Thrift.Server;
+
+interface
+
+uses
+ SysUtils,
+ Thrift,
+ Thrift.Protocol,
+ Thrift.Transport;
+
+type
+ IServer = interface
+ ['{CF9F56C6-BB39-4C7D-877B-43B416572CE6}']
+ procedure Serve;
+ procedure Stop;
+ end;
+
+ TServerImpl = class abstract( TInterfacedObject, IServer )
+ public
+ type
+ TLogDelegate = reference to procedure( str: string);
+ protected
+ FProcessor : IProcessor;
+ FServerTransport : IServerTransport;
+ FInputTransportFactory : ITransportFactory;
+ FOutputTransportFactory : ITransportFactory;
+ FInputProtocolFactory : IProtocolFactory;
+ FOutputProtocolFactory : IProtocolFactory;
+ FLogDelegate : TLogDelegate;
+
+ class procedure DefaultLogDelegate( str: string);
+
+ procedure Serve; virtual; abstract;
+ procedure Stop; virtual; abstract;
+ public
+ constructor Create(
+ AProcessor :IProcessor;
+ AServerTransport: IServerTransport;
+ AInputTransportFactory : ITransportFactory;
+ AOutputTransportFactory : ITransportFactory;
+ AInputProtocolFactory : IProtocolFactory;
+ AOutputProtocolFactory : IProtocolFactory;
+ ALogDelegate : TLogDelegate
+ ); overload;
+
+ constructor Create( AProcessor :IProcessor;
+ AServerTransport: IServerTransport); overload;
+
+ constructor Create(
+ AProcessor :IProcessor;
+ AServerTransport: IServerTransport;
+ ALogDelegate: TLogDelegate
+ ); overload;
+
+ constructor Create(
+ AProcessor :IProcessor;
+ AServerTransport: IServerTransport;
+ ATransportFactory : ITransportFactory
+ ); overload;
+
+ constructor Create(
+ AProcessor :IProcessor;
+ AServerTransport: IServerTransport;
+ ATransportFactory : ITransportFactory;
+ AProtocolFactory : IProtocolFactory
+ ); overload;
+ end;
+
+ TSimpleServer = class( TServerImpl)
+ private
+ FStop : Boolean;
+ public
+ constructor Create( AProcessor: IProcessor; AServerTransport: IServerTransport); overload;
+ constructor Create( AProcessor: IProcessor; AServerTransport: IServerTransport;
+ ALogDel: TServerImpl.TLogDelegate); overload;
+ constructor Create( AProcessor: IProcessor; AServerTransport: IServerTransport;
+ ATransportFactory: ITransportFactory); overload;
+ constructor Create( AProcessor: IProcessor; AServerTransport: IServerTransport;
+ ATransportFactory: ITransportFactory; AProtocolFactory: IProtocolFactory); overload;
+
+ procedure Serve; override;
+ procedure Stop; override;
+ end;
+
+
+implementation
+
+{ TServerImpl }
+
+constructor TServerImpl.Create(AProcessor: IProcessor;
+ AServerTransport: IServerTransport; ALogDelegate: TLogDelegate);
+var
+ InputFactory, OutputFactory : IProtocolFactory;
+ InputTransFactory, OutputTransFactory : ITransportFactory;
+
+begin
+ InputFactory := TBinaryProtocolImpl.TFactory.Create;
+ OutputFactory := TBinaryProtocolImpl.TFactory.Create;
+ InputTransFactory := TTransportFactoryImpl.Create;
+ OutputTransFactory := TTransportFactoryImpl.Create;
+
+ Create(
+ AProcessor,
+ AServerTransport,
+ InputTransFactory,
+ OutputTransFactory,
+ InputFactory,
+ OutputFactory,
+ ALogDelegate
+ );
+end;
+
+constructor TServerImpl.Create(AProcessor: IProcessor;
+ AServerTransport: IServerTransport);
+var
+ InputFactory, OutputFactory : IProtocolFactory;
+ InputTransFactory, OutputTransFactory : ITransportFactory;
+
+begin
+ InputFactory := TBinaryProtocolImpl.TFactory.Create;
+ OutputFactory := TBinaryProtocolImpl.TFactory.Create;
+ InputTransFactory := TTransportFactoryImpl.Create;
+ OutputTransFactory := TTransportFactoryImpl.Create;
+
+ Create(
+ AProcessor,
+ AServerTransport,
+ InputTransFactory,
+ OutputTransFactory,
+ InputFactory,
+ OutputFactory,
+ DefaultLogDelegate
+ );
+end;
+
+constructor TServerImpl.Create(AProcessor: IProcessor;
+ AServerTransport: IServerTransport; ATransportFactory: ITransportFactory);
+var
+ InputProtocolFactory : IProtocolFactory;
+ OutputProtocolFactory : IProtocolFactory;
+begin
+ InputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
+ OutputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
+
+ Create( AProcessor, AServerTransport, ATransportFactory, ATransportFactory,
+ InputProtocolFactory, OutputProtocolFactory, DefaultLogDelegate);
+end;
+
+constructor TServerImpl.Create(AProcessor: IProcessor;
+ AServerTransport: IServerTransport; AInputTransportFactory,
+ AOutputTransportFactory: ITransportFactory; AInputProtocolFactory,
+ AOutputProtocolFactory: IProtocolFactory;
+ ALogDelegate : TLogDelegate);
+begin
+ FProcessor := AProcessor;
+ FServerTransport := AServerTransport;
+ FInputTransportFactory := AInputTransportFactory;
+ FOutputTransportFactory := AOutputTransportFactory;
+ FInputProtocolFactory := AInputProtocolFactory;
+ FOutputProtocolFactory := AOutputProtocolFactory;
+ FLogDelegate := ALogDelegate;
+end;
+
+class procedure TServerImpl.DefaultLogDelegate( str: string);
+begin
+ Writeln( str );
+end;
+
+constructor TServerImpl.Create(AProcessor: IProcessor;
AServerTransport: IServerTransport; ATransportFactory: ITransportFactory;
AProtocolFactory: IProtocolFactory);
begin
@@ -196,133 +196,133 @@
end;
{ TSimpleServer }
-
-constructor TSimpleServer.Create(AProcessor: IProcessor;
- AServerTransport: IServerTransport);
-var
- InputProtocolFactory : IProtocolFactory;
- OutputProtocolFactory : IProtocolFactory;
- InputTransportFactory : ITransportFactory;
- OutputTransportFactory : ITransportFactory;
-begin
- InputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
- OutputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
- InputTransportFactory := TTransportFactoryImpl.Create;
- OutputTransportFactory := TTransportFactoryImpl.Create;
-
- inherited Create( AProcessor, AServerTransport, InputTransportFactory,
- OutputTransportFactory, InputProtocolFactory, OutputProtocolFactory, DefaultLogDelegate);
-end;
-
-constructor TSimpleServer.Create(AProcessor: IProcessor;
- AServerTransport: IServerTransport; ALogDel: TServerImpl.TLogDelegate);
-var
- InputProtocolFactory : IProtocolFactory;
- OutputProtocolFactory : IProtocolFactory;
- InputTransportFactory : ITransportFactory;
- OutputTransportFactory : ITransportFactory;
-begin
- InputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
- OutputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
- InputTransportFactory := TTransportFactoryImpl.Create;
- OutputTransportFactory := TTransportFactoryImpl.Create;
-
- inherited Create( AProcessor, AServerTransport, InputTransportFactory,
- OutputTransportFactory, InputProtocolFactory, OutputProtocolFactory, ALogDel);
-end;
-
-constructor TSimpleServer.Create(AProcessor: IProcessor;
- AServerTransport: IServerTransport; ATransportFactory: ITransportFactory);
-begin
- inherited Create( AProcessor, AServerTransport, ATransportFactory,
- ATransportFactory, TBinaryProtocolImpl.TFactory.Create, TBinaryProtocolImpl.TFactory.Create, DefaultLogDelegate);
-end;
-
-constructor TSimpleServer.Create(AProcessor: IProcessor;
- AServerTransport: IServerTransport; ATransportFactory: ITransportFactory;
- AProtocolFactory: IProtocolFactory);
-begin
- inherited Create( AProcessor, AServerTransport, ATransportFactory,
- ATransportFactory, AProtocolFactory, AProtocolFactory, DefaultLogDelegate);
-end;
-
-procedure TSimpleServer.Serve;
-var
- client : ITransport;
- InputTransport : ITransport;
- OutputTransport : ITransport;
- InputProtocol : IProtocol;
- OutputProtocol : IProtocol;
-begin
- try
- FServerTransport.Listen;
- except
- on E: Exception do
- begin
- FLogDelegate( E.ToString);
- end;
- end;
-
- client := nil;
- InputTransport := nil;
- OutputTransport := nil;
- InputProtocol := nil;
- OutputProtocol := nil;
-
- while (not FStop) do
- begin
- try
- client := FServerTransport.Accept;
- FLogDelegate( 'Client Connected!');
- InputTransport := FInputTransportFactory.GetTransport( client );
- OutputTransport := FOutputTransportFactory.GetTransport( client );
- InputProtocol := FInputProtocolFactory.GetProtocol( InputTransport );
- OutputProtocol := FOutputProtocolFactory.GetProtocol( OutputTransport );
- while ( FProcessor.Process( InputProtocol, OutputProtocol )) do
- begin
- if FStop then Break;
- end;
- except
- on E: TTransportException do
- begin
- if FStop then
- begin
- FLogDelegate('TSimpleServer was shutting down, caught ' + E.ClassName);
- end;
- end;
- on E: Exception do
- begin
- FLogDelegate( E.ToString );
- end;
- end;
- if InputTransport <> nil then
- begin
- InputTransport.Close;
- end;
- if OutputTransport <> nil then
- begin
- OutputTransport.Close;
- end;
- end;
-
- if FStop then
- begin
- try
- FServerTransport.Close;
- except
- on E: TTransportException do
- begin
- FLogDelegate('TServerTranport failed on close: ' + E.Message);
- end;
- end;
- FStop := False;
- end;
-end;
-
-procedure TSimpleServer.Stop;
-begin
- FStop := True;
- FServerTransport.Close;
-end;
-
-end.
+
+constructor TSimpleServer.Create(AProcessor: IProcessor;
+ AServerTransport: IServerTransport);
+var
+ InputProtocolFactory : IProtocolFactory;
+ OutputProtocolFactory : IProtocolFactory;
+ InputTransportFactory : ITransportFactory;
+ OutputTransportFactory : ITransportFactory;
+begin
+ InputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
+ OutputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
+ InputTransportFactory := TTransportFactoryImpl.Create;
+ OutputTransportFactory := TTransportFactoryImpl.Create;
+
+ inherited Create( AProcessor, AServerTransport, InputTransportFactory,
+ OutputTransportFactory, InputProtocolFactory, OutputProtocolFactory, DefaultLogDelegate);
+end;
+
+constructor TSimpleServer.Create(AProcessor: IProcessor;
+ AServerTransport: IServerTransport; ALogDel: TServerImpl.TLogDelegate);
+var
+ InputProtocolFactory : IProtocolFactory;
+ OutputProtocolFactory : IProtocolFactory;
+ InputTransportFactory : ITransportFactory;
+ OutputTransportFactory : ITransportFactory;
+begin
+ InputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
+ OutputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
+ InputTransportFactory := TTransportFactoryImpl.Create;
+ OutputTransportFactory := TTransportFactoryImpl.Create;
+
+ inherited Create( AProcessor, AServerTransport, InputTransportFactory,
+ OutputTransportFactory, InputProtocolFactory, OutputProtocolFactory, ALogDel);
+end;
+
+constructor TSimpleServer.Create(AProcessor: IProcessor;
+ AServerTransport: IServerTransport; ATransportFactory: ITransportFactory);
+begin
+ inherited Create( AProcessor, AServerTransport, ATransportFactory,
+ ATransportFactory, TBinaryProtocolImpl.TFactory.Create, TBinaryProtocolImpl.TFactory.Create, DefaultLogDelegate);
+end;
+
+constructor TSimpleServer.Create(AProcessor: IProcessor;
+ AServerTransport: IServerTransport; ATransportFactory: ITransportFactory;
+ AProtocolFactory: IProtocolFactory);
+begin
+ inherited Create( AProcessor, AServerTransport, ATransportFactory,
+ ATransportFactory, AProtocolFactory, AProtocolFactory, DefaultLogDelegate);
+end;
+
+procedure TSimpleServer.Serve;
+var
+ client : ITransport;
+ InputTransport : ITransport;
+ OutputTransport : ITransport;
+ InputProtocol : IProtocol;
+ OutputProtocol : IProtocol;
+begin
+ try
+ FServerTransport.Listen;
+ except
+ on E: Exception do
+ begin
+ FLogDelegate( E.ToString);
+ end;
+ end;
+
+ client := nil;
+ InputTransport := nil;
+ OutputTransport := nil;
+ InputProtocol := nil;
+ OutputProtocol := nil;
+
+ while (not FStop) do
+ begin
+ try
+ client := FServerTransport.Accept;
+ FLogDelegate( 'Client Connected!');
+ InputTransport := FInputTransportFactory.GetTransport( client );
+ OutputTransport := FOutputTransportFactory.GetTransport( client );
+ InputProtocol := FInputProtocolFactory.GetProtocol( InputTransport );
+ OutputProtocol := FOutputProtocolFactory.GetProtocol( OutputTransport );
+ while ( FProcessor.Process( InputProtocol, OutputProtocol )) do
+ begin
+ if FStop then Break;
+ end;
+ except
+ on E: TTransportException do
+ begin
+ if FStop then
+ begin
+ FLogDelegate('TSimpleServer was shutting down, caught ' + E.ClassName);
+ end;
+ end;
+ on E: Exception do
+ begin
+ FLogDelegate( E.ToString );
+ end;
+ end;
+ if InputTransport <> nil then
+ begin
+ InputTransport.Close;
+ end;
+ if OutputTransport <> nil then
+ begin
+ OutputTransport.Close;
+ end;
+ end;
+
+ if FStop then
+ begin
+ try
+ FServerTransport.Close;
+ except
+ on E: TTransportException do
+ begin
+ FLogDelegate('TServerTranport failed on close: ' + E.Message);
+ end;
+ end;
+ FStop := False;
+ end;
+end;
+
+procedure TSimpleServer.Stop;
+begin
+ FStop := True;
+ FServerTransport.Close;
+end;
+
+end.
diff --git a/lib/delphi/src/Thrift.pas b/lib/delphi/src/Thrift.pas
index a1c959d..50513d3 100644
--- a/lib/delphi/src/Thrift.pas
+++ b/lib/delphi/src/Thrift.pas
@@ -1,173 +1,173 @@
-(*
- * Licensed to the Apache Software Foundation (ASF) under one
- * or more contributor license agreements. See the NOTICE file
- * distributed with this work for additional information
- * regarding copyright ownership. The ASF licenses this file
- * to you under the Apache License, Version 2.0 (the
- * "License"); you may not use this file except in compliance
- * with the License. You may obtain a copy of the License at
- *
- * http://www.apache.org/licenses/LICENSE-2.0
- *
- * Unless required by applicable law or agreed to in writing,
- * software distributed under the License is distributed on an
- * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
- * KIND, either express or implied. See the License for the
- * specific language governing permissions and limitations
- * under the License.
- *)
-
-unit Thrift;
-
-interface
-
-uses
- SysUtils, Thrift.Protocol;
-
-const
- Version = '0.8.0-dev';
-
-type
- IProcessor = interface
- ['{B1538A07-6CAC-4406-8A4C-AFED07C70A89}']
- function Process( iprot :IProtocol; oprot: IProtocol): Boolean;
- end;
-
- TApplicationException = class( SysUtils.Exception )
- public
- type
-{$SCOPEDENUMS ON}
+(*
+ * Licensed to the Apache Software Foundation (ASF) under one
+ * or more contributor license agreements. See the NOTICE file
+ * distributed with this work for additional information
+ * regarding copyright ownership. The ASF licenses this file
+ * to you under the Apache License, Version 2.0 (the
+ * "License"); you may not use this file except in compliance
+ * with the License. You may obtain a copy of the License at
+ *
+ * http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing,
+ * software distributed under the License is distributed on an
+ * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+ * KIND, either express or implied. See the License for the
+ * specific language governing permissions and limitations
+ * under the License.
+ *)
+
+unit Thrift;
+
+interface
+
+uses
+ SysUtils, Thrift.Protocol;
+
+const
+ Version = '0.8.0-dev';
+
+type
+ IProcessor = interface
+ ['{B1538A07-6CAC-4406-8A4C-AFED07C70A89}']
+ function Process( iprot :IProtocol; oprot: IProtocol): Boolean;
+ end;
+
+ TApplicationException = class( SysUtils.Exception )
+ public
+ type
+{$SCOPEDENUMS ON}
TExceptionType = (
- Unknown,
- UnknownMethod,
- InvalidMessageType,
- WrongMethodName,
- BadSequenceID,
- MissingResult
- );
-{$SCOPEDENUMS OFF}
- private
- FType : TExceptionType;
- public
- constructor Create; overload;
- constructor Create( AType: TExceptionType); overload;
- constructor Create( AType: TExceptionType; const msg: string); overload;
-
- class function Read( iprot: IProtocol): TApplicationException;
- procedure Write( oprot: IProtocol );
- end;
-
- // base class for IDL-generated exceptions
- TException = class( SysUtils.Exception)
- public
- procedure Message; // hide inherited property to prevent accidental read/write
- end;
-
-implementation
-
-{ TException }
-
-procedure TException.Message;
-// hide inherited property to prevent accidental read/write
-begin
- ASSERT( FALSE, 'Unexpected call to '+ClassName+'.message. Forgot the underscore?');
-end;
-
-{ TApplicationException }
-
-constructor TApplicationException.Create;
-begin
- inherited Create( '' );
-end;
-
-constructor TApplicationException.Create(AType: TExceptionType;
- const msg: string);
-begin
- inherited Create( msg );
- FType := AType;
-end;
-
-constructor TApplicationException.Create(AType: TExceptionType);
-begin
- inherited Create('');
- FType := AType;
-end;
-
-class function TApplicationException.Read(
- iprot: IProtocol): TApplicationException;
-var
- field : IField;
- msg : string;
- typ : TExceptionType;
-begin
- msg := '';
- typ := TExceptionType.Unknown;
- while ( True ) do
- begin
- field := iprot.ReadFieldBegin;
- if ( field.Type_ = TType.Stop) then
- begin
- Break;
- end;
-
- case field.Id of
- 1 : begin
- if ( field.Type_ = TType.String_) then
- begin
- msg := iprot.ReadString;
- end else
- begin
- TProtocolUtil.Skip( iprot, field.Type_ );
- end;
- end;
-
- 2 : begin
- if ( field.Type_ = TType.I32) then
- begin
- typ := TExceptionType( iprot.ReadI32 );
- end else
- begin
- TProtocolUtil.Skip( iprot, field.Type_ );
- end;
- end else
- begin
- TProtocolUtil.Skip( iprot, field.Type_);
- end;
- end;
- iprot.ReadFieldEnd;
- end;
- iprot.ReadStructEnd;
- Result := TApplicationException.Create( typ, msg );
-end;
-
-procedure TApplicationException.Write(oprot: IProtocol);
-var
- struc : IStruct;
- field : IField;
-
-begin
- struc := TStructImpl.Create( 'TApplicationException' );
- field := TFieldImpl.Create;
-
- oprot.WriteStructBegin( struc );
- if Message <> '' then
- begin
- field.Name := 'message';
- field.Type_ := TType.String_;
- field.Id := 1;
- oprot.WriteFieldBegin( field );
- oprot.WriteString( Message );
- oprot.WriteFieldEnd;
- end;
-
- field.Name := 'type';
- field.Type_ := TType.I32;
- field.Id := 2;
- oprot.WriteFieldBegin(field);
- oprot.WriteI32(Integer(FType));
- oprot.WriteFieldEnd();
- oprot.WriteFieldStop();
- oprot.WriteStructEnd();
-end;
-
-end.
+ Unknown,
+ UnknownMethod,
+ InvalidMessageType,
+ WrongMethodName,
+ BadSequenceID,
+ MissingResult
+ );
+{$SCOPEDENUMS OFF}
+ private
+ FType : TExceptionType;
+ public
+ constructor Create; overload;
+ constructor Create( AType: TExceptionType); overload;
+ constructor Create( AType: TExceptionType; const msg: string); overload;
+
+ class function Read( iprot: IProtocol): TApplicationException;
+ procedure Write( oprot: IProtocol );
+ end;
+
+ // base class for IDL-generated exceptions
+ TException = class( SysUtils.Exception)
+ public
+ procedure Message; // hide inherited property to prevent accidental read/write
+ end;
+
+implementation
+
+{ TException }
+
+procedure TException.Message;
+// hide inherited property to prevent accidental read/write
+begin
+ ASSERT( FALSE, 'Unexpected call to '+ClassName+'.message. Forgot the underscore?');
+end;
+
+{ TApplicationException }
+
+constructor TApplicationException.Create;
+begin
+ inherited Create( '' );
+end;
+
+constructor TApplicationException.Create(AType: TExceptionType;
+ const msg: string);
+begin
+ inherited Create( msg );
+ FType := AType;
+end;
+
+constructor TApplicationException.Create(AType: TExceptionType);
+begin
+ inherited Create('');
+ FType := AType;
+end;
+
+class function TApplicationException.Read(
+ iprot: IProtocol): TApplicationException;
+var
+ field : IField;
+ msg : string;
+ typ : TExceptionType;
+begin
+ msg := '';
+ typ := TExceptionType.Unknown;
+ while ( True ) do
+ begin
+ field := iprot.ReadFieldBegin;
+ if ( field.Type_ = TType.Stop) then
+ begin
+ Break;
+ end;
+
+ case field.Id of
+ 1 : begin
+ if ( field.Type_ = TType.String_) then
+ begin
+ msg := iprot.ReadString;
+ end else
+ begin
+ TProtocolUtil.Skip( iprot, field.Type_ );
+ end;
+ end;
+
+ 2 : begin
+ if ( field.Type_ = TType.I32) then
+ begin
+ typ := TExceptionType( iprot.ReadI32 );
+ end else
+ begin
+ TProtocolUtil.Skip( iprot, field.Type_ );
+ end;
+ end else
+ begin
+ TProtocolUtil.Skip( iprot, field.Type_);
+ end;
+ end;
+ iprot.ReadFieldEnd;
+ end;
+ iprot.ReadStructEnd;
+ Result := TApplicationException.Create( typ, msg );
+end;
+
+procedure TApplicationException.Write(oprot: IProtocol);
+var
+ struc : IStruct;
+ field : IField;
+
+begin
+ struc := TStructImpl.Create( 'TApplicationException' );
+ field := TFieldImpl.Create;
+
+ oprot.WriteStructBegin( struc );
+ if Message <> '' then
+ begin
+ field.Name := 'message';
+ field.Type_ := TType.String_;
+ field.Id := 1;
+ oprot.WriteFieldBegin( field );
+ oprot.WriteString( Message );
+ oprot.WriteFieldEnd;
+ end;
+
+ field.Name := 'type';
+ field.Type_ := TType.I32;
+ field.Id := 2;
+ oprot.WriteFieldBegin(field);
+ oprot.WriteI32(Integer(FType));
+ oprot.WriteFieldEnd();
+ oprot.WriteFieldStop();
+ oprot.WriteStructEnd();
+end;
+
+end.