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.
diff --git a/lib/delphi/test/TestClient.pas b/lib/delphi/test/TestClient.pas
index b3c9017..e8edd82 100644
--- a/lib/delphi/test/TestClient.pas
+++ b/lib/delphi/test/TestClient.pas
@@ -22,12 +22,19 @@
interface
uses
- SysUtils, Classes, Thrift.Protocol, Thrift.Transport, Thrift.Test,
- Generics.Collections, Thrift.Collections, Windows, Thrift.Console,
- DateUtils;
+ Windows, SysUtils, Classes,
+ DateUtils,
+ Generics.Collections,
+ TestConstants,
+ Thrift.Protocol.JSON,
+ Thrift.Protocol,
+ Thrift.Transport,
+ Thrift.Stream,
+ Thrift.Test,
+ Thrift.Collections,
+ Thrift.Console;
type
-
TThreadConsole = class
private
FThread : TThread;
@@ -40,14 +47,19 @@
TClientThread = class( TThread )
private
FTransport : ITransport;
+ FProtocol : IProtocol;
FNumIteration : Integer;
FConsole : TThreadConsole;
+ FErrors, FSuccesses : Integer;
+ procedure Expect( aTestResult : Boolean; const aTestInfo : string);
+
procedure ClientTest;
+ procedure JSONProtocolReadWriteTest;
protected
procedure Execute; override;
public
- constructor Create(ATransport: ITransport; ANumIteration: Integer);
+ constructor Create(ATransport: ITransport; AProtocol : IProtocol; ANumIteration: Integer);
destructor Destroy; override;
end;
@@ -62,6 +74,7 @@
implementation
+
{ TTestClient }
class procedure TTestClient.Execute(const args: array of string);
@@ -79,12 +92,14 @@
test : Integer;
thread : TThread;
trans : ITransport;
+ prot : IProtocol;
streamtrans : IStreamTransport;
http : IHTTPClient;
-
+ protType, p : TKnownProtocol;
begin
bBuffered := False;;
bFramed := False;
+ protType := prot_Binary;
try
host := 'localhost';
port := 9090;
@@ -132,6 +147,18 @@
begin
Inc( i );
FNumThread := StrToInt( args[i] );
+ end else
+ if (args[i] = '-prot') then // -prot JSON|binary
+ begin
+ Inc( i );
+ s := args[i];
+ for p:= Low(TKnownProtocol) to High(TKnownProtocol) do begin
+ if SameText( s, KNOWN_PROTOCOLS[p]) then begin
+ protType := p;
+ Console.WriteLine('Using '+KNOWN_PROTOCOLS[protType]+' protocol');
+ Break;
+ end;
+ end;
end;
finally
Inc( i );
@@ -167,7 +194,17 @@
http := THTTPClientImpl.Create( url );
trans := http;
end;
- thread := TClientThread.Create( trans, FNumIteration);
+
+ // create protocol instance, default to BinaryProtocol
+ case protType of
+ prot_Binary: prot := TBinaryProtocolImpl.Create( trans);
+ prot_JSON : prot := TJSONProtocolImpl.Create( trans);
+ else
+ ASSERT( FALSE); // unhandled case!
+ prot := TBinaryProtocolImpl.Create( trans); // use default
+ end;
+
+ thread := TClientThread.Create( trans, prot, FNumIteration);
threads[test] := thread;
{$WARN SYMBOL_DEPRECATED OFF}
thread.Resume;
@@ -201,7 +238,6 @@
procedure TClientThread.ClientTest;
var
- binaryProtocol : TBinaryProtocolImpl;
client : TThriftTest.Iface;
s : string;
i8 : ShortInt;
@@ -234,7 +270,7 @@
k2_2 : TNumberz;
k3 : TNumberz;
v2 : IInsanity;
- userMap : IThriftDictionary<TNumberz, Int64>;
+ userMap : IThriftDictionary<TNumberz, Int64>;
xtructs : IThriftList<IXtruct>;
x : IXtruct;
arg0 : ShortInt;
@@ -248,8 +284,7 @@
proc : TThreadProcedure;
begin
- binaryProtocol := TBinaryProtocolImpl.Create( FTransport );
- client := TThriftTest.TClient.Create( binaryProtocol );
+ client := TThriftTest.TClient.Create( FProtocol);
try
if not FTransport.IsOpen then
begin
@@ -523,11 +558,114 @@
end;
-constructor TClientThread.Create(ATransport: ITransport; ANumIteration: Integer);
+
+procedure TClientThread.JSONProtocolReadWriteTest;
+// Tests only then read/write procedures of the JSON protocol
+// All tests succeed, if we can read what we wrote before
+// Note that passing this test does not imply, that our JSON is really compatible to what
+// other clients or servers expect as the real JSON. This is beyond the scope of this test.
+var prot : IProtocol;
+ stm : TStringStream;
+ list : IList;
+ binary, binRead : TBytes;
+ i,iErr : Integer;
+const
+ TEST_SHORT = ShortInt( $FE);
+ TEST_SMALL = SmallInt( $FEDC);
+ TEST_LONG = LongInt( $FEDCBA98);
+ TEST_I64 = Int64( $FEDCBA9876543210);
+ TEST_DOUBLE = -1.234e-56;
+ DELTA_DOUBLE = TEST_DOUBLE * 1e-14;
+ TEST_STRING = 'abc-'#$00E4#$00f6#$00fc; // german umlauts (en-us: "funny chars")
+begin
+ stm := TStringStream.Create;
+ try
+ // prepare binary data
+ SetLength( binary, $100);
+ for i := Low(binary) to High(binary) do binary[i] := i;
+
+ // output setup
+ prot := TJSONProtocolImpl.Create(
+ TStreamTransportImpl.Create(
+ nil, TThriftStreamAdapterDelphi.Create( stm, FALSE)));
+
+ // write
+ prot.WriteListBegin( TListImpl.Create( TType.String_, 9));
+ prot.WriteBool( TRUE);
+ prot.WriteBool( FALSE);
+ prot.WriteByte( TEST_SHORT);
+ prot.WriteI16( TEST_SMALL);
+ prot.WriteI32( TEST_LONG);
+ prot.WriteI64( TEST_I64);
+ prot.WriteDouble( TEST_DOUBLE);
+ prot.WriteString( TEST_STRING);
+ prot.WriteBinary( binary);
+ prot.WriteListEnd;
+
+ // input setup
+ Expect( stm.Position = stm.Size, 'Stream position/length after write');
+ stm.Position := 0;
+ prot := TJSONProtocolImpl.Create(
+ TStreamTransportImpl.Create(
+ TThriftStreamAdapterDelphi.Create( stm, FALSE), nil));
+
+ // read and compare
+ list := prot.ReadListBegin;
+ Expect( list.ElementType = TType.String_, 'list element type');
+ Expect( list.Count = 9, 'list element count');
+ Expect( prot.ReadBool, 'WriteBool/ReadBool: TRUE');
+ Expect( not prot.ReadBool, 'WriteBool/ReadBool: FALSE');
+ Expect( prot.ReadByte = TEST_SHORT, 'WriteByte/ReadByte');
+ Expect( prot.ReadI16 = TEST_SMALL, 'WriteI16/ReadI16');
+ Expect( prot.ReadI32 = TEST_LONG, 'WriteI32/ReadI32');
+ Expect( prot.ReadI64 = TEST_I64, 'WriteI64/ReadI64');
+ Expect( abs(prot.ReadDouble-TEST_DOUBLE) < abs(DELTA_DOUBLE), 'WriteDouble/ReadDouble');
+ Expect( prot.ReadString = TEST_STRING, 'WriteString/ReadString');
+ binRead := prot.ReadBinary;
+ prot.ReadListEnd;
+
+ // test binary data
+ Expect( Length(binary) = Length(binRead), 'Binary data length check');
+ iErr := -1;
+ for i := Low(binary) to High(binary) do begin
+ if binary[i] <> binRead[i] then begin
+ iErr := i;
+ Break;
+ end;
+ end;
+ if iErr < 0
+ then Expect( TRUE, 'Binary data check ('+IntToStr(Length(binary))+' Bytes)')
+ else Expect( FALSE, 'Binary data check at offset '+IntToStr(iErr));
+
+ Expect( stm.Position = stm.Size, 'Stream position after read');
+
+ finally
+ stm.Free;
+ prot := nil; //-> Release
+ end;
+end;
+
+
+procedure TClientThread.Expect( aTestResult : Boolean; const aTestInfo : string);
+begin
+ if aTestResult then begin
+ Inc(FSuccesses);
+ Console.WriteLine( aTestInfo+' = OK');
+ end
+ else begin
+ Inc(FErrors);
+ Console.WriteLine( aTestInfo+' = FAILED');
+ ASSERT( FALSE); // we have a failed test!
+ end;
+end;
+
+
+constructor TClientThread.Create(ATransport: ITransport; AProtocol : IProtocol; ANumIteration: Integer);
begin
inherited Create( True );
FNumIteration := ANumIteration;
FTransport := ATransport;
+ FProtocol := AProtocol;
FConsole := TThreadConsole.Create( Self );
end;
@@ -545,6 +683,7 @@
for i := 0 to FNumIteration - 1 do
begin
ClientTest;
+ JSONProtocolReadWriteTest;
end;
proc := procedure
diff --git a/lib/delphi/test/TestConstants.pas b/lib/delphi/test/TestConstants.pas
new file mode 100644
index 0000000..9cb85ab
--- /dev/null
+++ b/lib/delphi/test/TestConstants.pas
@@ -0,0 +1,36 @@
+(*
+ * 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 TestConstants;
+
+interface
+
+type
+ TKnownProtocol = ( prot_Binary, // default binary protocol
+ prot_JSON // JSON protocol
+ );
+const
+ KNOWN_PROTOCOLS : array[TKnownProtocol] of string
+ = ('binary', 'JSON');
+
+implementation
+
+// nothing
+
+end.
diff --git a/lib/delphi/test/TestServer.pas b/lib/delphi/test/TestServer.pas
index 67cce77..ecaf80d 100644
--- a/lib/delphi/test/TestServer.pas
+++ b/lib/delphi/test/TestServer.pas
@@ -1,52 +1,55 @@
-(*
- * 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 TestServer;
-
-interface
-
-uses
- SysUtils,
- Generics.Collections,
- Thrift.Console,
- Thrift.Server,
- Thrift.Transport,
- Thrift.Collections,
- Thrift.Utils,
- Thrift.Test,
- Thrift,
- Contnrs;
-
-type
- TTestServer = class
- public
- type
-
- ITestHandler = interface( TThriftTest.Iface )
- procedure SetServer( AServer : IServer );
- end;
-
- TTestHandlerImpl = class( TInterfacedObject, ITestHandler )
- private
- FServer : IServer;
- protected
- procedure testVoid();
+(*
+ * 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 TestServer;
+
+interface
+
+uses
+ SysUtils,
+ Generics.Collections,
+ Thrift.Console,
+ Thrift.Server,
+ Thrift.Transport,
+ Thrift.Protocol,
+ Thrift.Protocol.JSON,
+ Thrift.Collections,
+ Thrift.Utils,
+ Thrift.Test,
+ Thrift,
+ TestConstants,
+ Contnrs;
+
+type
+ TTestServer = class
+ public
+ type
+
+ ITestHandler = interface( TThriftTest.Iface )
+ procedure SetServer( AServer : IServer );
+ end;
+
+ TTestHandlerImpl = class( TInterfacedObject, ITestHandler )
+ private
+ FServer : IServer;
+ protected
+ procedure testVoid();
function testString(thing: string): string;
function testByte(thing: ShortInt): ShortInt;
function testI32(thing: Integer): Integer;
@@ -66,395 +69,421 @@
procedure testException(arg: string);
function testMultiException(arg0: string; arg1: string): IXtruct;
procedure testOneway(secondsToSleep: Integer);
-
- procedure testStop;
-
- procedure SetServer( AServer : IServer );
- end;
-
- class procedure Execute( args: array of string);
- end;
-
-implementation
-
-{ TTestServer.TTestHandlerImpl }
-
-procedure TTestServer.TTestHandlerImpl.SetServer(AServer: IServer);
-begin
- FServer := AServer;
-end;
-
-function TTestServer.TTestHandlerImpl.testByte(thing: ShortInt): ShortInt;
-begin
- Console.WriteLine('testByte("' + IntToStr( thing) + '")');
- Result := thing;
-end;
-
-function TTestServer.TTestHandlerImpl.testDouble(thing: Double): Double;
-begin
- Console.WriteLine('testDouble("' + FloatToStr( thing ) + '")');
- Result := thing;
-end;
-
-function TTestServer.TTestHandlerImpl.testEnum(thing: TNumberz): TNumberz;
-begin
- Console.WriteLine('testEnum(' + IntToStr( Integer( thing)) + ')');
- Result := thing;
-end;
-
-procedure TTestServer.TTestHandlerImpl.testException(arg: string);
-var
- x : TXception;
-begin
- Console.WriteLine('testException(' + arg + ')');
- if ( arg = 'Xception') then
- begin
- x := TXception.Create;
- x.ErrorCode := 1001;
- x.Message_ := 'This is an Xception';
- raise x;
- end;
-end;
-
-function TTestServer.TTestHandlerImpl.testI32(thing: Integer): Integer;
-begin
- Console.WriteLine('testI32("' + IntToStr( thing) + '")');
- Result := thing;
-end;
-
-function TTestServer.TTestHandlerImpl.testI64(thing: Int64): Int64;
-begin
- Console.WriteLine('testI64("' + IntToStr( thing) + '")');
- Result := thing;
-end;
-
-function TTestServer.TTestHandlerImpl.testInsanity(
- argument: IInsanity): IThriftDictionary<Int64, IThriftDictionary<TNumberz, IInsanity>>;
-var
- hello, goodbye : IXtruct;
- crazy : IInsanity;
- looney : IInsanity;
- first_map : IThriftDictionary<TNumberz, IInsanity>;
- second_map : IThriftDictionary<TNumberz, IInsanity>;
- insane : IThriftDictionary<Int64, IThriftDictionary<TNumberz, IInsanity>>;
-
-begin
-
- Console.WriteLine('testInsanity()');
- hello := TXtructImpl.Create;
- hello.String_thing := 'hello';
- hello.Byte_thing := 2;
- hello.I32_thing := 2;
- hello.I64_thing := 2;
-
- goodbye := TXtructImpl.Create;
- goodbye.String_thing := 'Goodbye4';
- goodbye.Byte_thing := 4;
- goodbye.I32_thing := 4;
- goodbye.I64_thing := 4;
-
- crazy := TInsanityImpl.Create;
- crazy.UserMap := TThriftDictionaryImpl<TNumberz, Int64>.Create;
- crazy.UserMap.AddOrSetValue( TNumberz.EIGHT, 8);
- crazy.Xtructs := TThriftListImpl<IXtruct>.Create;
- crazy.Xtructs.Add(goodbye);
-
- looney := TInsanityImpl.Create;
- crazy.UserMap.AddOrSetValue( TNumberz.FIVE, 5);
- crazy.Xtructs.Add(hello);
-
- first_map := TThriftDictionaryImpl<TNumberz, IInsanity>.Create;
- second_map := TThriftDictionaryImpl<TNumberz, IInsanity>.Create;
-
- first_map.AddOrSetValue( TNumberz.SIX, crazy);
- first_map.AddOrSetValue( TNumberz.THREE, crazy);
-
- second_map.AddOrSetValue( TNumberz.SIX, looney);
-
- insane := TThriftDictionaryImpl<Int64, IThriftDictionary<TNumberz, IInsanity>>.Create;
-
- insane.AddOrSetValue( 1, first_map);
- insane.AddOrSetValue( 2, second_map);
-
- Result := insane;
-end;
-
-function TTestServer.TTestHandlerImpl.testList(
- thing: IThriftList<Integer>): IThriftList<Integer>;
-var
- first : Boolean;
- elem : Integer;
-begin
- Console.Write('testList({');
- first := True;
- for elem in thing do
- begin
- if first then
- begin
- first := False;
- end else
- begin
- Console.Write(', ');
- end;
- Console.Write( IntToStr( elem));
- end;
- Console.WriteLine('})');
- Result := thing;
-end;
-
-function TTestServer.TTestHandlerImpl.testMap(
- thing: IThriftDictionary<Integer, Integer>): IThriftDictionary<Integer, Integer>;
-var
- first : Boolean;
- key : Integer;
-begin
- Console.Write('testMap({');
- first := True;
- for key in thing.Keys do
- begin
- if (first) then
- begin
- first := false;
- end else
- begin
- Console.Write(', ');
- end;
- Console.Write(IntToStr(key) + ' => ' + IntToStr( thing[key]));
- end;
- Console.WriteLine('})');
- Result := thing;
-end;
-
-function TTestServer.TTestHandlerImpl.TestMapMap(
- hello: Integer): IThriftDictionary<Integer, IThriftDictionary<Integer, Integer>>;
-var
- mapmap : IThriftDictionary<Integer, IThriftDictionary<Integer, Integer>>;
- pos : IThriftDictionary<Integer, Integer>;
- neg : IThriftDictionary<Integer, Integer>;
- i : Integer;
-begin
- Console.WriteLine('testMapMap(' + IntToStr( hello) + ')');
- mapmap := TThriftDictionaryImpl<Integer, IThriftDictionary<Integer, Integer>>.Create;
- pos := TThriftDictionaryImpl<Integer, Integer>.Create;
- neg := TThriftDictionaryImpl<Integer, Integer>.Create;
-
- for i := 1 to 4 do
- begin
- pos.AddOrSetValue( i, i);
- neg.AddOrSetValue( -i, -i);
- end;
-
- mapmap.AddOrSetValue(4, pos);
- mapmap.AddOrSetValue( -4, neg);
-
- Result := mapmap;
-end;
-
-function TTestServer.TTestHandlerImpl.testMulti(arg0: ShortInt; arg1: Integer;
- arg2: Int64; arg3: IThriftDictionary<SmallInt, string>; arg4: TNumberz;
- arg5: Int64): IXtruct;
-var
- hello : IXtruct;
-begin
- Console.WriteLine('testMulti()');
- hello := TXtructImpl.Create;
- hello.String_thing := 'Hello2';
- hello.Byte_thing := arg0;
- hello.I32_thing := arg1;
- hello.I64_thing := arg2;
- Result := hello;
-end;
-
-function TTestServer.TTestHandlerImpl.testMultiException(arg0,
- arg1: string): IXtruct;
-var
- x : TXception;
- x2 : TXception2;
-begin
- Console.WriteLine('testMultiException(' + arg0 + ', ' + arg1 + ')');
- if ( arg0 = 'Xception') then
- begin
- x := TXception.Create;
- x.ErrorCode := 1001;
- x.Message_ := 'This is an Xception';
- raise x;
- end else
- if ( arg0 = 'Xception2') then
- begin
- x2 := TXception2.Create;
- x2.ErrorCode := 2002;
- x2.Struct_thing := TXtructImpl.Create;
- x2.Struct_thing.String_thing := 'This is an Xception2';
- raise x2;
- end;
-
- Result := TXtructImpl.Create;
- Result.String_thing := arg1;
-end;
-
-function TTestServer.TTestHandlerImpl.testNest(thing: IXtruct2): IXtruct2;
-var
- temp : IXtruct;
-begin
- temp := thing.Struct_thing;
- Console.WriteLine('testNest({' +
- IntToStr( thing.Byte_thing) + ', {' +
- '"' + temp.String_thing + '", ' +
- IntToStr( temp.Byte_thing) + ', ' +
- IntToStr( temp.I32_thing) + ', ' +
- IntToStr( temp.I64_thing) + '}, ' +
- IntToStr( temp.I32_thing) + '})');
- Result := thing;
-end;
-
-procedure TTestServer.TTestHandlerImpl.testOneway(secondsToSleep: Integer);
-begin
- Console.WriteLine('testOneway(' + IntToStr( secondsToSleep )+ '), sleeping...');
- Sleep(secondsToSleep * 1000);
- Console.WriteLine('testOneway finished');
-end;
-
-function TTestServer.TTestHandlerImpl.testSet(
- thing: IHashSet<Integer>):IHashSet<Integer>;
-var
- first : Boolean;
- elem : Integer;
-begin
- Console.Write('testSet({');
- first := True;
-
- for elem in thing do
- begin
- if first then
- begin
- first := False;
- end else
- begin
- Console.Write( ', ');
- end;
- Console.Write( IntToStr( elem));
- end;
- Console.WriteLine('})');
- Result := thing;
-end;
-
-procedure TTestServer.TTestHandlerImpl.testStop;
-begin
- if FServer <> nil then
- begin
- FServer.Stop;
- end;
-end;
-
-function TTestServer.TTestHandlerImpl.testString(thing: string): string;
-begin
- Console.WriteLine('teststring("' + thing + '")');
- Result := thing;
-end;
-
-function TTestServer.TTestHandlerImpl.testStringMap(
- thing: IThriftDictionary<string, string>): IThriftDictionary<string, string>;
-begin
-
-end;
-
-function TTestServer.TTestHandlerImpl.testTypedef(thing: Int64): Int64;
-begin
- Console.WriteLine('testTypedef(' + IntToStr( thing) + ')');
- Result := thing;
-end;
-
-procedure TTestServer.TTestHandlerImpl.TestVoid;
-begin
- Console.WriteLine('testVoid()');
-end;
-
-function TTestServer.TTestHandlerImpl.testStruct(thing: IXtruct): IXtruct;
-begin
- Console.WriteLine('testStruct({' +
- '"' + thing.String_thing + '", ' +
- IntToStr( thing.Byte_thing) + ', ' +
- IntToStr( thing.I32_thing) + ', ' +
- IntToStr( thing.I64_thing));
- Result := thing;
-end;
-
-{ TTestServer }
-
-class procedure TTestServer.Execute(args: array of string);
-var
- UseBufferedSockets : Boolean;
- UseFramed : Boolean;
- Port : Integer;
- testHandler : ITestHandler;
- testProcessor : IProcessor;
- ServerSocket : IServerTransport;
- ServerEngine : IServer;
- TransportFactroy : ITransportFactory;
-
-
-begin
- try
- UseBufferedSockets := False;
- UseFramed := False;
- Port := 9090;
-
- if ( Length( args) > 0) then
- begin
- Port := StrToIntDef( args[0], Port);
-
- if ( Length( args) > 0) then
- begin
- if ( args[0] = 'raw' ) then
- begin
- // as default
- end else
- if ( args[0] = 'buffered' ) then
- begin
- UseBufferedSockets := True;
- end else
- if ( args[0] = 'framed' ) then
- begin
- UseFramed := True;
- end else
- begin
- // Fall back to the older boolean syntax
- UseBufferedSockets := StrToBoolDef( args[1], UseBufferedSockets);
- end
- end
- end;
-
- testHandler := TTestHandlerImpl.Create;
-
- testProcessor := TThriftTest.TProcessorImpl.Create( testHandler );
- ServerSocket := TServerSocketImpl.Create( Port, 0, UseBufferedSockets );
- if UseFramed then
- begin
- TransportFactroy := TFramedTransportImpl.TFactory.Create;
- ServerEngine := TSimpleServer.Create( testProcessor, ServerSocket,
- TransportFactroy);
- end else
- begin
- ServerEngine := TSimpleServer.Create( testProcessor, ServerSocket);
- end;
-
- testHandler.SetServer( ServerEngine);
-
- Console.WriteLine('Starting the server on port ' + IntToStr( Port) +
- IfValue(UseBufferedSockets, ' with buffered socket', '') +
- IfValue(useFramed, ' with framed transport', '') +
- '...');
-
- serverEngine.Serve;
- testHandler.SetServer( nil);
-
- except
- on E: Exception do
- begin
- Console.Write( E.Message);
- end;
- end;
- Console.WriteLine( 'done.');
-end;
-
-end.
+
+ procedure testStop;
+
+ procedure SetServer( AServer : IServer );
+ end;
+
+ class procedure Execute( args: array of string);
+ end;
+
+implementation
+
+{ TTestServer.TTestHandlerImpl }
+
+procedure TTestServer.TTestHandlerImpl.SetServer(AServer: IServer);
+begin
+ FServer := AServer;
+end;
+
+function TTestServer.TTestHandlerImpl.testByte(thing: ShortInt): ShortInt;
+begin
+ Console.WriteLine('testByte("' + IntToStr( thing) + '")');
+ Result := thing;
+end;
+
+function TTestServer.TTestHandlerImpl.testDouble(thing: Double): Double;
+begin
+ Console.WriteLine('testDouble("' + FloatToStr( thing ) + '")');
+ Result := thing;
+end;
+
+function TTestServer.TTestHandlerImpl.testEnum(thing: TNumberz): TNumberz;
+begin
+ Console.WriteLine('testEnum(' + IntToStr( Integer( thing)) + ')');
+ Result := thing;
+end;
+
+procedure TTestServer.TTestHandlerImpl.testException(arg: string);
+var
+ x : TXception;
+begin
+ Console.WriteLine('testException(' + arg + ')');
+ if ( arg = 'Xception') then
+ begin
+ x := TXception.Create;
+ x.ErrorCode := 1001;
+ x.Message_ := 'This is an Xception';
+ raise x;
+ end;
+end;
+
+function TTestServer.TTestHandlerImpl.testI32(thing: Integer): Integer;
+begin
+ Console.WriteLine('testI32("' + IntToStr( thing) + '")');
+ Result := thing;
+end;
+
+function TTestServer.TTestHandlerImpl.testI64(thing: Int64): Int64;
+begin
+ Console.WriteLine('testI64("' + IntToStr( thing) + '")');
+ Result := thing;
+end;
+
+function TTestServer.TTestHandlerImpl.testInsanity(
+ argument: IInsanity): IThriftDictionary<Int64, IThriftDictionary<TNumberz, IInsanity>>;
+var
+ hello, goodbye : IXtruct;
+ crazy : IInsanity;
+ looney : IInsanity;
+ first_map : IThriftDictionary<TNumberz, IInsanity>;
+ second_map : IThriftDictionary<TNumberz, IInsanity>;
+ insane : IThriftDictionary<Int64, IThriftDictionary<TNumberz, IInsanity>>;
+
+begin
+
+ Console.WriteLine('testInsanity()');
+ hello := TXtructImpl.Create;
+ hello.String_thing := 'hello';
+ hello.Byte_thing := 2;
+ hello.I32_thing := 2;
+ hello.I64_thing := 2;
+
+ goodbye := TXtructImpl.Create;
+ goodbye.String_thing := 'Goodbye4';
+ goodbye.Byte_thing := 4;
+ goodbye.I32_thing := 4;
+ goodbye.I64_thing := 4;
+
+ crazy := TInsanityImpl.Create;
+ crazy.UserMap := TThriftDictionaryImpl<TNumberz, Int64>.Create;
+ crazy.UserMap.AddOrSetValue( TNumberz.EIGHT, 8);
+ crazy.Xtructs := TThriftListImpl<IXtruct>.Create;
+ crazy.Xtructs.Add(goodbye);
+
+ looney := TInsanityImpl.Create;
+ crazy.UserMap.AddOrSetValue( TNumberz.FIVE, 5);
+ crazy.Xtructs.Add(hello);
+
+ first_map := TThriftDictionaryImpl<TNumberz, IInsanity>.Create;
+ second_map := TThriftDictionaryImpl<TNumberz, IInsanity>.Create;
+
+ first_map.AddOrSetValue( TNumberz.SIX, crazy);
+ first_map.AddOrSetValue( TNumberz.THREE, crazy);
+
+ second_map.AddOrSetValue( TNumberz.SIX, looney);
+
+ insane := TThriftDictionaryImpl<Int64, IThriftDictionary<TNumberz, IInsanity>>.Create;
+
+ insane.AddOrSetValue( 1, first_map);
+ insane.AddOrSetValue( 2, second_map);
+
+ Result := insane;
+end;
+
+function TTestServer.TTestHandlerImpl.testList(
+ thing: IThriftList<Integer>): IThriftList<Integer>;
+var
+ first : Boolean;
+ elem : Integer;
+begin
+ Console.Write('testList({');
+ first := True;
+ for elem in thing do
+ begin
+ if first then
+ begin
+ first := False;
+ end else
+ begin
+ Console.Write(', ');
+ end;
+ Console.Write( IntToStr( elem));
+ end;
+ Console.WriteLine('})');
+ Result := thing;
+end;
+
+function TTestServer.TTestHandlerImpl.testMap(
+ thing: IThriftDictionary<Integer, Integer>): IThriftDictionary<Integer, Integer>;
+var
+ first : Boolean;
+ key : Integer;
+begin
+ Console.Write('testMap({');
+ first := True;
+ for key in thing.Keys do
+ begin
+ if (first) then
+ begin
+ first := false;
+ end else
+ begin
+ Console.Write(', ');
+ end;
+ Console.Write(IntToStr(key) + ' => ' + IntToStr( thing[key]));
+ end;
+ Console.WriteLine('})');
+ Result := thing;
+end;
+
+function TTestServer.TTestHandlerImpl.TestMapMap(
+ hello: Integer): IThriftDictionary<Integer, IThriftDictionary<Integer, Integer>>;
+var
+ mapmap : IThriftDictionary<Integer, IThriftDictionary<Integer, Integer>>;
+ pos : IThriftDictionary<Integer, Integer>;
+ neg : IThriftDictionary<Integer, Integer>;
+ i : Integer;
+begin
+ Console.WriteLine('testMapMap(' + IntToStr( hello) + ')');
+ mapmap := TThriftDictionaryImpl<Integer, IThriftDictionary<Integer, Integer>>.Create;
+ pos := TThriftDictionaryImpl<Integer, Integer>.Create;
+ neg := TThriftDictionaryImpl<Integer, Integer>.Create;
+
+ for i := 1 to 4 do
+ begin
+ pos.AddOrSetValue( i, i);
+ neg.AddOrSetValue( -i, -i);
+ end;
+
+ mapmap.AddOrSetValue(4, pos);
+ mapmap.AddOrSetValue( -4, neg);
+
+ Result := mapmap;
+end;
+
+function TTestServer.TTestHandlerImpl.testMulti(arg0: ShortInt; arg1: Integer;
+ arg2: Int64; arg3: IThriftDictionary<SmallInt, string>; arg4: TNumberz;
+ arg5: Int64): IXtruct;
+var
+ hello : IXtruct;
+begin
+ Console.WriteLine('testMulti()');
+ hello := TXtructImpl.Create;
+ hello.String_thing := 'Hello2';
+ hello.Byte_thing := arg0;
+ hello.I32_thing := arg1;
+ hello.I64_thing := arg2;
+ Result := hello;
+end;
+
+function TTestServer.TTestHandlerImpl.testMultiException(arg0,
+ arg1: string): IXtruct;
+var
+ x : TXception;
+ x2 : TXception2;
+begin
+ Console.WriteLine('testMultiException(' + arg0 + ', ' + arg1 + ')');
+ if ( arg0 = 'Xception') then
+ begin
+ x := TXception.Create;
+ x.ErrorCode := 1001;
+ x.Message_ := 'This is an Xception';
+ raise x;
+ end else
+ if ( arg0 = 'Xception2') then
+ begin
+ x2 := TXception2.Create;
+ x2.ErrorCode := 2002;
+ x2.Struct_thing := TXtructImpl.Create;
+ x2.Struct_thing.String_thing := 'This is an Xception2';
+ raise x2;
+ end;
+
+ Result := TXtructImpl.Create;
+ Result.String_thing := arg1;
+end;
+
+function TTestServer.TTestHandlerImpl.testNest(thing: IXtruct2): IXtruct2;
+var
+ temp : IXtruct;
+begin
+ temp := thing.Struct_thing;
+ Console.WriteLine('testNest({' +
+ IntToStr( thing.Byte_thing) + ', {' +
+ '"' + temp.String_thing + '", ' +
+ IntToStr( temp.Byte_thing) + ', ' +
+ IntToStr( temp.I32_thing) + ', ' +
+ IntToStr( temp.I64_thing) + '}, ' +
+ IntToStr( temp.I32_thing) + '})');
+ Result := thing;
+end;
+
+procedure TTestServer.TTestHandlerImpl.testOneway(secondsToSleep: Integer);
+begin
+ Console.WriteLine('testOneway(' + IntToStr( secondsToSleep )+ '), sleeping...');
+ Sleep(secondsToSleep * 1000);
+ Console.WriteLine('testOneway finished');
+end;
+
+function TTestServer.TTestHandlerImpl.testSet(
+ thing: IHashSet<Integer>):IHashSet<Integer>;
+var
+ first : Boolean;
+ elem : Integer;
+begin
+ Console.Write('testSet({');
+ first := True;
+
+ for elem in thing do
+ begin
+ if first then
+ begin
+ first := False;
+ end else
+ begin
+ Console.Write( ', ');
+ end;
+ Console.Write( IntToStr( elem));
+ end;
+ Console.WriteLine('})');
+ Result := thing;
+end;
+
+procedure TTestServer.TTestHandlerImpl.testStop;
+begin
+ if FServer <> nil then
+ begin
+ FServer.Stop;
+ end;
+end;
+
+function TTestServer.TTestHandlerImpl.testString(thing: string): string;
+begin
+ Console.WriteLine('teststring("' + thing + '")');
+ Result := thing;
+end;
+
+function TTestServer.TTestHandlerImpl.testStringMap(
+ thing: IThriftDictionary<string, string>): IThriftDictionary<string, string>;
+begin
+
+end;
+
+function TTestServer.TTestHandlerImpl.testTypedef(thing: Int64): Int64;
+begin
+ Console.WriteLine('testTypedef(' + IntToStr( thing) + ')');
+ Result := thing;
+end;
+
+procedure TTestServer.TTestHandlerImpl.TestVoid;
+begin
+ Console.WriteLine('testVoid()');
+end;
+
+function TTestServer.TTestHandlerImpl.testStruct(thing: IXtruct): IXtruct;
+begin
+ Console.WriteLine('testStruct({' +
+ '"' + thing.String_thing + '", ' +
+ IntToStr( thing.Byte_thing) + ', ' +
+ IntToStr( thing.I32_thing) + ', ' +
+ IntToStr( thing.I64_thing));
+ Result := thing;
+end;
+
+{ TTestServer }
+
+class procedure TTestServer.Execute(args: array of string);
+var
+ UseBufferedSockets : Boolean;
+ UseFramed : Boolean;
+ Port : Integer;
+ testHandler : ITestHandler;
+ testProcessor : IProcessor;
+ ServerSocket : IServerTransport;
+ ServerEngine : IServer;
+ TransportFactory : ITransportFactory;
+ ProtocolFactory : IProtocolFactory;
+ i : Integer;
+ s : string;
+ protType, p : TKnownProtocol;
+begin
+ try
+ UseBufferedSockets := False;
+ UseFramed := False;
+ protType := prot_Binary;
+ Port := 9090;
+
+ i := 0;
+ while ( i < Length(args) ) do begin
+ s := args[i];
+ Inc(i);
+
+ if StrToIntDef( s, -1) > 0 then
+ begin
+ Port := StrToIntDef( s, Port);
+ end else
+ if ( s = 'raw' ) then
+ begin
+ // as default
+ end else
+ if ( s = 'buffered' ) then
+ begin
+ UseBufferedSockets := True;
+ end else
+ if ( s = 'framed' ) then
+ begin
+ UseFramed := True;
+ end else
+ if (s = '-prot') then // -prot JSON|binary
+ begin
+ s := args[i];
+ Inc( i );
+ for p:= Low(TKnownProtocol) to High(TKnownProtocol) do begin
+ if SameText( s, KNOWN_PROTOCOLS[p]) then begin
+ protType := p;
+ Break;
+ end;
+ end;
+ end else
+ begin
+ // Fall back to the older boolean syntax
+ UseBufferedSockets := StrToBoolDef( args[1], UseBufferedSockets);
+ end
+ end;
+
+ // create protocol factory, default to BinaryProtocol
+ case protType of
+ prot_Binary: ProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
+ prot_JSON : ProtocolFactory := TJSONProtocolImpl.TFactory.Create;
+ else
+ ASSERT( FALSE); // unhandled case!
+ ProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
+ end;
+
+ testHandler := TTestHandlerImpl.Create;
+
+ testProcessor := TThriftTest.TProcessorImpl.Create( testHandler );
+ ServerSocket := TServerSocketImpl.Create( Port, 0, UseBufferedSockets );
+
+ if UseFramed
+ then TransportFactory := TFramedTransportImpl.TFactory.Create
+ else TransportFactory := TTransportFactoryImpl.Create;
+
+ ServerEngine := TSimpleServer.Create( testProcessor,
+ ServerSocket,
+ TransportFactory,
+ ProtocolFactory);
+
+ testHandler.SetServer( ServerEngine);
+
+ Console.WriteLine('Starting the server on port ' + IntToStr( Port) +
+ IfValue(UseBufferedSockets, ' with buffered socket', '') +
+ IfValue(useFramed, ' with framed transport', '') +
+ ' using '+KNOWN_PROTOCOLS[protType]+' protocol' +
+ '...');
+
+ serverEngine.Serve;
+ testHandler.SetServer( nil);
+
+ except
+ on E: Exception do
+ begin
+ Console.Write( E.Message);
+ end;
+ end;
+ Console.WriteLine( 'done.');
+end;
+
+end.
diff --git a/lib/delphi/test/client.dpr b/lib/delphi/test/client.dpr
index d14079d..310e966 100644
--- a/lib/delphi/test/client.dpr
+++ b/lib/delphi/test/client.dpr
@@ -1,62 +1,63 @@
-(*
- * 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.
- *)
-
-
-program client;
-
-{$APPTYPE CONSOLE}
-
-uses
- SysUtils,
- TestClient in 'TestClient.pas',
- Thrift.Test in 'gen-delphi\Thrift.Test.pas',
- Thrift in '..\..\..\lib\delphi\src\Thrift.pas',
- Thrift.Transport in '..\..\..\lib\delphi\src\Thrift.Transport.pas',
- Thrift.Protocol in '..\..\..\lib\delphi\src\Thrift.Protocol.pas',
- Thrift.Collections in '..\..\..\lib\delphi\src\Thrift.Collections.pas',
- Thrift.Server in '..\..\..\lib\delphi\src\Thrift.Server.pas',
- Thrift.Stream in '..\..\..\lib\delphi\src\Thrift.Stream.pas',
- Thrift.Console in '..\..\..\lib\delphi\src\Thrift.Console.pas',
- Thrift.Utils in '..\..\..\lib\delphi\src\Thrift.Utils.pas';
-
-var
- nParamCount : Integer;
- args : array of string;
- i : Integer;
- arg : string;
- s : string;
-
-begin
- try
- Writeln( 'Delphi TestClient '+Thrift.Version);
- nParamCount := ParamCount;
- SetLength( args, nParamCount);
- for i := 1 to nParamCount do
- begin
- arg := ParamStr( i );
- args[i-1] := arg;
- end;
- TTestClient.Execute( args );
- Readln;
- except
- on E: Exception do
- Writeln(E.ClassName, ': ', E.Message);
- end;
-end.
-
+(*g
+ * Licensed to the Apache Software Foundation (ASF) under oneg
+ * or more contributor license agreements. See the NOTICE fileg
+ * distributed with this work for additional informationg
+ * regarding copyright ownership. The ASF licenses this fileg
+ * to you under the Apache License, Version 2.0 (theg
+ * "License"); you may not use this file except in complianceg
+ * with the License. You may obtain a copy of the License atg
+ *g
+ * http://www.apache.org/licenses/LICENSE-2.0g
+ *g
+ * Unless required by applicable law or agreed to in writing,g
+ * software distributed under the License is distributed on ang
+ * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANYg
+ * KIND, either express or implied. See the License for theg
+ * specific language governing permissions and limitationsg
+ * under the License.g
+ *)g
+g
+g
+program client;g
+g
+{$APPTYPE CONSOLE}g
+g
+usesg
+ SysUtils,
+ TestClient in 'TestClient.pas',
+ Thrift.Test in 'gen-delphi\Thrift.Test.pas',
+ Thrift in '..\..\..\lib\delphi\src\Thrift.pas',
+ Thrift.Transport in '..\..\..\lib\delphi\src\Thrift.Transport.pas',
+ Thrift.Protocol in '..\..\..\lib\delphi\src\Thrift.Protocol.pas',
+ Thrift.Protocol.JSON in '..\..\..\lib\delphi\src\Thrift.Protocol.JSON.pas',
+ Thrift.Collections in '..\..\..\lib\delphi\src\Thrift.Collections.pas',
+ Thrift.Server in '..\..\..\lib\delphi\src\Thrift.Server.pas',
+ Thrift.Stream in '..\..\..\lib\delphi\src\Thrift.Stream.pas',
+ Thrift.Console in '..\..\..\lib\delphi\src\Thrift.Console.pas',
+ Thrift.Utils in '..\..\..\lib\delphi\src\Thrift.Utils.pas';
+
+varg
+ nParamCount : Integer;g
+ args : array of string;g
+ i : Integer;g
+ arg : string;g
+ s : string;g
+g
+beging
+ tryg
+ Writeln( 'Delphi TestClient '+Thrift.Version);g
+ nParamCount := ParamCount;g
+ SetLength( args, nParamCount);g
+ for i := 1 to nParamCount dog
+ beging
+ arg := ParamStr( i );g
+ args[i-1] := arg;g
+ end;g
+ TTestClient.Execute( args );g
+ Readln;g
+ exceptg
+ on E: Exception dog
+ Writeln(E.ClassName, ': ', E.Message);g
+ end;g
+end.g
+g
diff --git a/lib/delphi/test/server.dpr b/lib/delphi/test/server.dpr
index d6a53bc..832f825 100644
--- a/lib/delphi/test/server.dpr
+++ b/lib/delphi/test/server.dpr
@@ -1,63 +1,62 @@
-(*
- * 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.
- *)
-
-program server;
-
-{$APPTYPE CONSOLE}
-
-uses
- SysUtils,
- TestServer in 'TestServer.pas',
- Thrift.Test in 'gen-delphi\Thrift.Test.pas',
- Thrift in '..\..\..\lib\delphi\src\Thrift.pas',
- Thrift.Transport in '..\..\..\lib\delphi\src\Thrift.Transport.pas',
- Thrift.Protocol in '..\..\..\lib\delphi\src\Thrift.Protocol.pas',
- Thrift.Collections in '..\..\..\lib\delphi\src\Thrift.Collections.pas',
- Thrift.Server in '..\..\..\lib\delphi\src\Thrift.Server.pas',
- Thrift.Console in '..\..\..\lib\delphi\src\Thrift.Console.pas',
- Thrift.Utils in '..\..\..\lib\delphi\src\Thrift.Utils.pas',
- Thrift.Stream in '..\..\..\lib\delphi\src\Thrift.Stream.pas';
-
-var
- nParamCount : Integer;
- args : array of string;
- i : Integer;
- arg : string;
- s : string;
-
-begin
- try
- Writeln( 'Delphi TestServer '+Thrift.Version);
- nParamCount := ParamCount;
- SetLength( args, nParamCount);
- for i := 1 to nParamCount do
- begin
- arg := ParamStr( i );
- args[i-1] := arg;
- end;
- TTestServer.Execute( args );
- Readln;
- except
- on E: Exception do
- Writeln(E.ClassName, ': ', E.Message);
- end;
-end.
-
-
-
+(*
+ * 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.
+ *)
+
+program server;
+
+{$APPTYPE CONSOLE}
+
+uses
+ SysUtils,
+ TestServer in 'TestServer.pas',
+ Thrift.Test in 'gen-delphi\Thrift.Test.pas',
+ Thrift in '..\..\..\lib\delphi\src\Thrift.pas',
+ Thrift.Transport in '..\..\..\lib\delphi\src\Thrift.Transport.pas',
+ Thrift.Protocol in '..\..\..\lib\delphi\src\Thrift.Protocol.pas',
+ Thrift.Protocol.JSON in '..\..\..\lib\delphi\src\Thrift.Protocol.JSON.pas',
+ Thrift.Collections in '..\..\..\lib\delphi\src\Thrift.Collections.pas',
+ Thrift.Server in '..\..\..\lib\delphi\src\Thrift.Server.pas',
+ Thrift.Console in '..\..\..\lib\delphi\src\Thrift.Console.pas',
+ Thrift.Utils in '..\..\..\lib\delphi\src\Thrift.Utils.pas',
+ Thrift.Stream in '..\..\..\lib\delphi\src\Thrift.Stream.pas';
+
+var
+ nParamCount : Integer;
+ args : array of string;
+ i : Integer;
+ arg : string;
+ s : string;
+
+begin
+ try
+ Writeln( 'Delphi TestServer '+Thrift.Version);
+ nParamCount := ParamCount;
+ SetLength( args, nParamCount);
+ for i := 1 to nParamCount do
+ begin
+ arg := ParamStr( i );
+ args[i-1] := arg;
+ end;
+ TTestServer.Execute( args );
+ Readln;
+ except
+ on E: Exception do
+ Writeln(E.ClassName, ': ', E.Message);
+ end;
+end.
+