--- /dev/null
+(*
+ * 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.
-(*\r
- * Licensed to the Apache Software Foundation (ASF) under one\r
- * or more contributor license agreements. See the NOTICE file\r
- * distributed with this work for additional information\r
- * regarding copyright ownership. The ASF licenses this file\r
- * to you under the Apache License, Version 2.0 (the\r
- * "License"); you may not use this file except in compliance\r
- * with the License. You may obtain a copy of the License at\r
- *\r
- * http://www.apache.org/licenses/LICENSE-2.0\r
- *\r
- * Unless required by applicable law or agreed to in writing,\r
- * software distributed under the License is distributed on an\r
- * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY\r
- * KIND, either express or implied. See the License for the\r
- * specific language governing permissions and limitations\r
- * under the License.\r
- *)\r
-\r
- unit Thrift.Server;\r
-\r
-interface\r
-\r
-uses\r
- SysUtils,\r
- Thrift,\r
- Thrift.Protocol,\r
- Thrift.Transport;\r
-\r
-type\r
- IServer = interface\r
- ['{CF9F56C6-BB39-4C7D-877B-43B416572CE6}']\r
- procedure Serve;\r
- procedure Stop;\r
- end;\r
-\r
- TServerImpl = class abstract( TInterfacedObject, IServer )\r
- public\r
- type\r
- TLogDelegate = reference to procedure( str: string);\r
- protected\r
- FProcessor : IProcessor;\r
- FServerTransport : IServerTransport;\r
- FInputTransportFactory : ITransportFactory;\r
- FOutputTransportFactory : ITransportFactory;\r
- FInputProtocolFactory : IProtocolFactory;\r
- FOutputProtocolFactory : IProtocolFactory;\r
- FLogDelegate : TLogDelegate;\r
-\r
- class procedure DefaultLogDelegate( str: string);\r
-\r
- procedure Serve; virtual; abstract;\r
- procedure Stop; virtual; abstract;\r
- public\r
- constructor Create(\r
- AProcessor :IProcessor;\r
- AServerTransport: IServerTransport;\r
- AInputTransportFactory : ITransportFactory;\r
- AOutputTransportFactory : ITransportFactory;\r
- AInputProtocolFactory : IProtocolFactory;\r
- AOutputProtocolFactory : IProtocolFactory;\r
- ALogDelegate : TLogDelegate\r
- ); overload;\r
-\r
- constructor Create( AProcessor :IProcessor;\r
- AServerTransport: IServerTransport); overload;\r
-\r
- constructor Create(\r
- AProcessor :IProcessor;\r
- AServerTransport: IServerTransport;\r
- ALogDelegate: TLogDelegate\r
- ); overload;\r
-\r
- constructor Create(\r
- AProcessor :IProcessor;\r
- AServerTransport: IServerTransport;\r
- ATransportFactory : ITransportFactory\r
- ); overload;\r
-\r
- constructor Create(\r
- AProcessor :IProcessor;\r
- AServerTransport: IServerTransport;\r
- ATransportFactory : ITransportFactory;\r
- AProtocolFactory : IProtocolFactory\r
- ); overload;\r
- end;\r
-\r
- TSimpleServer = class( TServerImpl)\r
- private\r
- FStop : Boolean;\r
- public\r
- constructor Create( AProcessor: IProcessor; AServerTransport: IServerTransport); overload;\r
- constructor Create( AProcessor: IProcessor; AServerTransport: IServerTransport;\r
- ALogDel: TServerImpl.TLogDelegate); overload;\r
- constructor Create( AProcessor: IProcessor; AServerTransport: IServerTransport;\r
- ATransportFactory: ITransportFactory); overload;\r
- constructor Create( AProcessor: IProcessor; AServerTransport: IServerTransport;\r
- ATransportFactory: ITransportFactory; AProtocolFactory: IProtocolFactory); overload;\r
-\r
- procedure Serve; override;\r
- procedure Stop; override;\r
- end;\r
-\r
-\r
-implementation\r
-\r
-{ TServerImpl }\r
-\r
-constructor TServerImpl.Create(AProcessor: IProcessor;\r
- AServerTransport: IServerTransport; ALogDelegate: TLogDelegate);\r
-var\r
- InputFactory, OutputFactory : IProtocolFactory;\r
- InputTransFactory, OutputTransFactory : ITransportFactory;\r
-\r
-begin\r
- InputFactory := TBinaryProtocolImpl.TFactory.Create;\r
- OutputFactory := TBinaryProtocolImpl.TFactory.Create;\r
- InputTransFactory := TTransportFactoryImpl.Create;\r
- OutputTransFactory := TTransportFactoryImpl.Create;\r
-\r
- Create(\r
- AProcessor,\r
- AServerTransport,\r
- InputTransFactory,\r
- OutputTransFactory,\r
- InputFactory,\r
- OutputFactory,\r
- ALogDelegate\r
- );\r
-end;\r
-\r
-constructor TServerImpl.Create(AProcessor: IProcessor;\r
- AServerTransport: IServerTransport);\r
-var\r
- InputFactory, OutputFactory : IProtocolFactory;\r
- InputTransFactory, OutputTransFactory : ITransportFactory;\r
-\r
-begin\r
- InputFactory := TBinaryProtocolImpl.TFactory.Create;\r
- OutputFactory := TBinaryProtocolImpl.TFactory.Create;\r
- InputTransFactory := TTransportFactoryImpl.Create;\r
- OutputTransFactory := TTransportFactoryImpl.Create;\r
-\r
- Create(\r
- AProcessor,\r
- AServerTransport,\r
- InputTransFactory,\r
- OutputTransFactory,\r
- InputFactory,\r
- OutputFactory,\r
- DefaultLogDelegate\r
- );\r
-end;\r
-\r
-constructor TServerImpl.Create(AProcessor: IProcessor;\r
- AServerTransport: IServerTransport; ATransportFactory: ITransportFactory);\r
-var\r
- InputProtocolFactory : IProtocolFactory;\r
- OutputProtocolFactory : IProtocolFactory;\r
-begin\r
- InputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;\r
- OutputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;\r
-\r
- Create( AProcessor, AServerTransport, ATransportFactory, ATransportFactory,\r
- InputProtocolFactory, OutputProtocolFactory, DefaultLogDelegate);\r
-end;\r
-\r
-constructor TServerImpl.Create(AProcessor: IProcessor;\r
- AServerTransport: IServerTransport; AInputTransportFactory,\r
- AOutputTransportFactory: ITransportFactory; AInputProtocolFactory,\r
- AOutputProtocolFactory: IProtocolFactory;\r
- ALogDelegate : TLogDelegate);\r
-begin\r
- FProcessor := AProcessor;\r
- FServerTransport := AServerTransport;\r
- FInputTransportFactory := AInputTransportFactory;\r
- FOutputTransportFactory := AOutputTransportFactory;\r
- FInputProtocolFactory := AInputProtocolFactory;\r
- FOutputProtocolFactory := AOutputProtocolFactory;\r
- FLogDelegate := ALogDelegate;\r
-end;\r
-\r
-class procedure TServerImpl.DefaultLogDelegate( str: string);\r
-begin\r
- Writeln( str );\r
-end;\r
-\r
-constructor TServerImpl.Create(AProcessor: IProcessor;\r
+(*
+ * 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
end;
{ TSimpleServer }
-\r
-constructor TSimpleServer.Create(AProcessor: IProcessor;\r
- AServerTransport: IServerTransport);\r
-var\r
- InputProtocolFactory : IProtocolFactory;\r
- OutputProtocolFactory : IProtocolFactory;\r
- InputTransportFactory : ITransportFactory;\r
- OutputTransportFactory : ITransportFactory;\r
-begin\r
- InputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;\r
- OutputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;\r
- InputTransportFactory := TTransportFactoryImpl.Create;\r
- OutputTransportFactory := TTransportFactoryImpl.Create;\r
-\r
- inherited Create( AProcessor, AServerTransport, InputTransportFactory,\r
- OutputTransportFactory, InputProtocolFactory, OutputProtocolFactory, DefaultLogDelegate);\r
-end;\r
-\r
-constructor TSimpleServer.Create(AProcessor: IProcessor;\r
- AServerTransport: IServerTransport; ALogDel: TServerImpl.TLogDelegate);\r
-var\r
- InputProtocolFactory : IProtocolFactory;\r
- OutputProtocolFactory : IProtocolFactory;\r
- InputTransportFactory : ITransportFactory;\r
- OutputTransportFactory : ITransportFactory;\r
-begin\r
- InputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;\r
- OutputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;\r
- InputTransportFactory := TTransportFactoryImpl.Create;\r
- OutputTransportFactory := TTransportFactoryImpl.Create;\r
-\r
- inherited Create( AProcessor, AServerTransport, InputTransportFactory,\r
- OutputTransportFactory, InputProtocolFactory, OutputProtocolFactory, ALogDel);\r
-end;\r
-\r
-constructor TSimpleServer.Create(AProcessor: IProcessor;\r
- AServerTransport: IServerTransport; ATransportFactory: ITransportFactory);\r
-begin\r
- inherited Create( AProcessor, AServerTransport, ATransportFactory,\r
- ATransportFactory, TBinaryProtocolImpl.TFactory.Create, TBinaryProtocolImpl.TFactory.Create, DefaultLogDelegate);\r
-end;\r
-\r
-constructor TSimpleServer.Create(AProcessor: IProcessor;\r
- AServerTransport: IServerTransport; ATransportFactory: ITransportFactory;\r
- AProtocolFactory: IProtocolFactory);\r
-begin\r
- inherited Create( AProcessor, AServerTransport, ATransportFactory,\r
- ATransportFactory, AProtocolFactory, AProtocolFactory, DefaultLogDelegate);\r
-end;\r
-\r
-procedure TSimpleServer.Serve;\r
-var\r
- client : ITransport;\r
- InputTransport : ITransport;\r
- OutputTransport : ITransport;\r
- InputProtocol : IProtocol;\r
- OutputProtocol : IProtocol;\r
-begin\r
- try\r
- FServerTransport.Listen;\r
- except\r
- on E: Exception do\r
- begin\r
- FLogDelegate( E.ToString);\r
- end;\r
- end;\r
-\r
- client := nil;\r
- InputTransport := nil;\r
- OutputTransport := nil;\r
- InputProtocol := nil;\r
- OutputProtocol := nil;\r
-\r
- while (not FStop) do\r
- begin\r
- try\r
- client := FServerTransport.Accept;\r
- FLogDelegate( 'Client Connected!');\r
- InputTransport := FInputTransportFactory.GetTransport( client );\r
- OutputTransport := FOutputTransportFactory.GetTransport( client );\r
- InputProtocol := FInputProtocolFactory.GetProtocol( InputTransport );\r
- OutputProtocol := FOutputProtocolFactory.GetProtocol( OutputTransport );\r
- while ( FProcessor.Process( InputProtocol, OutputProtocol )) do\r
- begin\r
- if FStop then Break;\r
- end;\r
- except\r
- on E: TTransportException do\r
- begin\r
- if FStop then\r
- begin\r
- FLogDelegate('TSimpleServer was shutting down, caught ' + E.ClassName);\r
- end;\r
- end;\r
- on E: Exception do\r
- begin\r
- FLogDelegate( E.ToString );\r
- end;\r
- end;\r
- if InputTransport <> nil then\r
- begin\r
- InputTransport.Close;\r
- end;\r
- if OutputTransport <> nil then\r
- begin\r
- OutputTransport.Close;\r
- end;\r
- end;\r
-\r
- if FStop then\r
- begin\r
- try\r
- FServerTransport.Close;\r
- except\r
- on E: TTransportException do\r
- begin\r
- FLogDelegate('TServerTranport failed on close: ' + E.Message);\r
- end;\r
- end;\r
- FStop := False;\r
- end;\r
-end;\r
-\r
-procedure TSimpleServer.Stop;\r
-begin\r
- FStop := True;\r
- FServerTransport.Close;\r
-end;\r
-\r
-end.\r
+
+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.
-(*\r
- * Licensed to the Apache Software Foundation (ASF) under one\r
- * or more contributor license agreements. See the NOTICE file\r
- * distributed with this work for additional information\r
- * regarding copyright ownership. The ASF licenses this file\r
- * to you under the Apache License, Version 2.0 (the\r
- * "License"); you may not use this file except in compliance\r
- * with the License. You may obtain a copy of the License at\r
- *\r
- * http://www.apache.org/licenses/LICENSE-2.0\r
- *\r
- * Unless required by applicable law or agreed to in writing,\r
- * software distributed under the License is distributed on an\r
- * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY\r
- * KIND, either express or implied. See the License for the\r
- * specific language governing permissions and limitations\r
- * under the License.\r
- *)\r
-\r
-unit Thrift;\r
-\r
-interface\r
-\r
-uses\r
- SysUtils, Thrift.Protocol;\r
-\r
-const\r
- Version = '0.8.0-dev';\r
- \r
-type\r
- IProcessor = interface\r
- ['{B1538A07-6CAC-4406-8A4C-AFED07C70A89}']\r
- function Process( iprot :IProtocol; oprot: IProtocol): Boolean;\r
- end;\r
-\r
- TApplicationException = class( SysUtils.Exception )\r
- public\r
- type\r
-{$SCOPEDENUMS ON}\r
+(*
+ * 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,\r
- UnknownMethod,\r
- InvalidMessageType,\r
- WrongMethodName,\r
- BadSequenceID,\r
- MissingResult\r
- );\r
-{$SCOPEDENUMS OFF}\r
- private\r
- FType : TExceptionType;\r
- public\r
- constructor Create; overload;\r
- constructor Create( AType: TExceptionType); overload;\r
- constructor Create( AType: TExceptionType; const msg: string); overload;\r
-\r
- class function Read( iprot: IProtocol): TApplicationException;\r
- procedure Write( oprot: IProtocol );\r
- end;\r
-\r
- // base class for IDL-generated exceptions\r
- TException = class( SysUtils.Exception)\r
- public\r
- procedure Message; // hide inherited property to prevent accidental read/write\r
- end;\r
-\r
-implementation\r
-\r
-{ TException }\r
-\r
-procedure TException.Message;\r
-// hide inherited property to prevent accidental read/write\r
-begin\r
- ASSERT( FALSE, 'Unexpected call to '+ClassName+'.message. Forgot the underscore?');\r
-end;\r
-\r
-{ TApplicationException }\r
-\r
-constructor TApplicationException.Create;\r
-begin\r
- inherited Create( '' );\r
-end;\r
-\r
-constructor TApplicationException.Create(AType: TExceptionType;\r
- const msg: string);\r
-begin\r
- inherited Create( msg );\r
- FType := AType;\r
-end;\r
-\r
-constructor TApplicationException.Create(AType: TExceptionType);\r
-begin\r
- inherited Create('');\r
- FType := AType;\r
-end;\r
-\r
-class function TApplicationException.Read(\r
- iprot: IProtocol): TApplicationException;\r
-var\r
- field : IField;\r
- msg : string;\r
- typ : TExceptionType;\r
-begin\r
- msg := '';\r
- typ := TExceptionType.Unknown;\r
- while ( True ) do\r
- begin\r
- field := iprot.ReadFieldBegin;\r
- if ( field.Type_ = TType.Stop) then\r
- begin\r
- Break;\r
- end;\r
-\r
- case field.Id of\r
- 1 : begin\r
- if ( field.Type_ = TType.String_) then\r
- begin\r
- msg := iprot.ReadString;\r
- end else\r
- begin\r
- TProtocolUtil.Skip( iprot, field.Type_ );\r
- end;\r
- end;\r
-\r
- 2 : begin\r
- if ( field.Type_ = TType.I32) then\r
- begin\r
- typ := TExceptionType( iprot.ReadI32 );\r
- end else\r
- begin\r
- TProtocolUtil.Skip( iprot, field.Type_ );\r
- end;\r
- end else\r
- begin\r
- TProtocolUtil.Skip( iprot, field.Type_);\r
- end;\r
- end;\r
- iprot.ReadFieldEnd;\r
- end;\r
- iprot.ReadStructEnd;\r
- Result := TApplicationException.Create( typ, msg );\r
-end;\r
-\r
-procedure TApplicationException.Write(oprot: IProtocol);\r
-var\r
- struc : IStruct;\r
- field : IField;\r
-\r
-begin\r
- struc := TStructImpl.Create( 'TApplicationException' );\r
- field := TFieldImpl.Create;\r
-\r
- oprot.WriteStructBegin( struc );\r
- if Message <> '' then\r
- begin\r
- field.Name := 'message';\r
- field.Type_ := TType.String_;\r
- field.Id := 1;\r
- oprot.WriteFieldBegin( field );\r
- oprot.WriteString( Message );\r
- oprot.WriteFieldEnd;\r
- end;\r
-\r
- field.Name := 'type';\r
- field.Type_ := TType.I32;\r
- field.Id := 2;\r
- oprot.WriteFieldBegin(field);\r
- oprot.WriteI32(Integer(FType));\r
- oprot.WriteFieldEnd();\r
- oprot.WriteFieldStop();\r
- oprot.WriteStructEnd();\r
-end;\r
-\r
-end.\r
+ 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.
interface\r
\r
uses\r
- SysUtils, Classes, Thrift.Protocol, Thrift.Transport, Thrift.Test,\r
- Generics.Collections, Thrift.Collections, Windows, Thrift.Console,\r
- DateUtils;\r
+ Windows, SysUtils, Classes,\r
+ DateUtils,\r
+ Generics.Collections,\r
+ TestConstants,\r
+ Thrift.Protocol.JSON,\r
+ Thrift.Protocol,\r
+ Thrift.Transport,\r
+ Thrift.Stream,\r
+ Thrift.Test,\r
+ Thrift.Collections,\r
+ Thrift.Console;\r
\r
type\r
-\r
TThreadConsole = class\r
private\r
FThread : TThread;\r
TClientThread = class( TThread )\r
private\r
FTransport : ITransport;\r
+ FProtocol : IProtocol;\r
FNumIteration : Integer;\r
FConsole : TThreadConsole;\r
\r
+ FErrors, FSuccesses : Integer;\r
+ procedure Expect( aTestResult : Boolean; const aTestInfo : string);\r
+ \r
procedure ClientTest;\r
+ procedure JSONProtocolReadWriteTest;\r
protected\r
procedure Execute; override;\r
public\r
- constructor Create(ATransport: ITransport; ANumIteration: Integer);\r
+ constructor Create(ATransport: ITransport; AProtocol : IProtocol; ANumIteration: Integer);\r
destructor Destroy; override;\r
end;\r
\r
\r
implementation\r
\r
+\r
{ TTestClient }\r
\r
class procedure TTestClient.Execute(const args: array of string);\r
test : Integer;\r
thread : TThread;\r
trans : ITransport;\r
+ prot : IProtocol;\r
streamtrans : IStreamTransport;\r
http : IHTTPClient;\r
-\r
+ protType, p : TKnownProtocol;\r
begin\r
bBuffered := False;;\r
bFramed := False;\r
+ protType := prot_Binary;\r
try\r
host := 'localhost';\r
port := 9090;\r
begin\r
Inc( i );\r
FNumThread := StrToInt( args[i] );\r
+ end else\r
+ if (args[i] = '-prot') then // -prot JSON|binary\r
+ begin\r
+ Inc( i );\r
+ s := args[i];\r
+ for p:= Low(TKnownProtocol) to High(TKnownProtocol) do begin\r
+ if SameText( s, KNOWN_PROTOCOLS[p]) then begin\r
+ protType := p;\r
+ Console.WriteLine('Using '+KNOWN_PROTOCOLS[protType]+' protocol');\r
+ Break;\r
+ end;\r
+ end;\r
end;\r
finally\r
Inc( i );\r
http := THTTPClientImpl.Create( url );\r
trans := http;\r
end;\r
- thread := TClientThread.Create( trans, FNumIteration);\r
+\r
+ // create protocol instance, default to BinaryProtocol\r
+ case protType of\r
+ prot_Binary: prot := TBinaryProtocolImpl.Create( trans);\r
+ prot_JSON : prot := TJSONProtocolImpl.Create( trans);\r
+ else\r
+ ASSERT( FALSE); // unhandled case!\r
+ prot := TBinaryProtocolImpl.Create( trans); // use default\r
+ end;\r
+\r
+ thread := TClientThread.Create( trans, prot, FNumIteration);\r
threads[test] := thread;\r
{$WARN SYMBOL_DEPRECATED OFF}\r
thread.Resume;\r
\r
procedure TClientThread.ClientTest;\r
var\r
- binaryProtocol : TBinaryProtocolImpl;\r
client : TThriftTest.Iface;\r
s : string;\r
i8 : ShortInt;\r
k2_2 : TNumberz;\r
k3 : TNumberz;\r
v2 : IInsanity;\r
- userMap : IThriftDictionary<TNumberz, Int64>;\r
+ userMap : IThriftDictionary<TNumberz, Int64>;\r
xtructs : IThriftList<IXtruct>;\r
x : IXtruct;\r
arg0 : ShortInt;\r
proc : TThreadProcedure;\r
\r
begin\r
- binaryProtocol := TBinaryProtocolImpl.Create( FTransport );\r
- client := TThriftTest.TClient.Create( binaryProtocol );\r
+ client := TThriftTest.TClient.Create( FProtocol);\r
try\r
if not FTransport.IsOpen then\r
begin\r
\r
end;\r
\r
-constructor TClientThread.Create(ATransport: ITransport; ANumIteration: Integer);\r
+\r
+procedure TClientThread.JSONProtocolReadWriteTest;\r
+// Tests only then read/write procedures of the JSON protocol\r
+// All tests succeed, if we can read what we wrote before\r
+// Note that passing this test does not imply, that our JSON is really compatible to what\r
+// other clients or servers expect as the real JSON. This is beyond the scope of this test.\r
+var prot : IProtocol;\r
+ stm : TStringStream;\r
+ list : IList;\r
+ binary, binRead : TBytes;\r
+ i,iErr : Integer;\r
+const\r
+ TEST_SHORT = ShortInt( $FE);\r
+ TEST_SMALL = SmallInt( $FEDC);\r
+ TEST_LONG = LongInt( $FEDCBA98);\r
+ TEST_I64 = Int64( $FEDCBA9876543210);\r
+ TEST_DOUBLE = -1.234e-56;\r
+ DELTA_DOUBLE = TEST_DOUBLE * 1e-14;\r
+ TEST_STRING = 'abc-'#$00E4#$00f6#$00fc; // german umlauts (en-us: "funny chars")\r
+begin\r
+ stm := TStringStream.Create;\r
+ try\r
+ // prepare binary data\r
+ SetLength( binary, $100);\r
+ for i := Low(binary) to High(binary) do binary[i] := i;\r
+\r
+ // output setup\r
+ prot := TJSONProtocolImpl.Create(\r
+ TStreamTransportImpl.Create(\r
+ nil, TThriftStreamAdapterDelphi.Create( stm, FALSE)));\r
+\r
+ // write\r
+ prot.WriteListBegin( TListImpl.Create( TType.String_, 9));\r
+ prot.WriteBool( TRUE);\r
+ prot.WriteBool( FALSE);\r
+ prot.WriteByte( TEST_SHORT);\r
+ prot.WriteI16( TEST_SMALL);\r
+ prot.WriteI32( TEST_LONG);\r
+ prot.WriteI64( TEST_I64);\r
+ prot.WriteDouble( TEST_DOUBLE);\r
+ prot.WriteString( TEST_STRING);\r
+ prot.WriteBinary( binary);\r
+ prot.WriteListEnd;\r
+\r
+ // input setup\r
+ Expect( stm.Position = stm.Size, 'Stream position/length after write');\r
+ stm.Position := 0;\r
+ prot := TJSONProtocolImpl.Create(\r
+ TStreamTransportImpl.Create(\r
+ TThriftStreamAdapterDelphi.Create( stm, FALSE), nil));\r
+\r
+ // read and compare\r
+ list := prot.ReadListBegin;\r
+ Expect( list.ElementType = TType.String_, 'list element type');\r
+ Expect( list.Count = 9, 'list element count');\r
+ Expect( prot.ReadBool, 'WriteBool/ReadBool: TRUE');\r
+ Expect( not prot.ReadBool, 'WriteBool/ReadBool: FALSE');\r
+ Expect( prot.ReadByte = TEST_SHORT, 'WriteByte/ReadByte');\r
+ Expect( prot.ReadI16 = TEST_SMALL, 'WriteI16/ReadI16');\r
+ Expect( prot.ReadI32 = TEST_LONG, 'WriteI32/ReadI32');\r
+ Expect( prot.ReadI64 = TEST_I64, 'WriteI64/ReadI64');\r
+ Expect( abs(prot.ReadDouble-TEST_DOUBLE) < abs(DELTA_DOUBLE), 'WriteDouble/ReadDouble');\r
+ Expect( prot.ReadString = TEST_STRING, 'WriteString/ReadString');\r
+ binRead := prot.ReadBinary;\r
+ prot.ReadListEnd;\r
+\r
+ // test binary data\r
+ Expect( Length(binary) = Length(binRead), 'Binary data length check');\r
+ iErr := -1;\r
+ for i := Low(binary) to High(binary) do begin\r
+ if binary[i] <> binRead[i] then begin\r
+ iErr := i;\r
+ Break;\r
+ end;\r
+ end;\r
+ if iErr < 0\r
+ then Expect( TRUE, 'Binary data check ('+IntToStr(Length(binary))+' Bytes)')\r
+ else Expect( FALSE, 'Binary data check at offset '+IntToStr(iErr));\r
+\r
+ Expect( stm.Position = stm.Size, 'Stream position after read');\r
+\r
+ finally\r
+ stm.Free;\r
+ prot := nil; //-> Release\r
+ end;\r
+end;\r
+\r
+\r
+procedure TClientThread.Expect( aTestResult : Boolean; const aTestInfo : string);\r
+begin\r
+ if aTestResult then begin\r
+ Inc(FSuccesses);\r
+ Console.WriteLine( aTestInfo+' = OK');\r
+ end\r
+ else begin\r
+ Inc(FErrors);\r
+ Console.WriteLine( aTestInfo+' = FAILED');\r
+ ASSERT( FALSE); // we have a failed test!\r
+ end;\r
+end;\r
+\r
+\r
+constructor TClientThread.Create(ATransport: ITransport; AProtocol : IProtocol; ANumIteration: Integer);\r
begin\r
inherited Create( True );\r
FNumIteration := ANumIteration;\r
FTransport := ATransport;\r
+ FProtocol := AProtocol;\r
FConsole := TThreadConsole.Create( Self );\r
end;\r
\r
for i := 0 to FNumIteration - 1 do\r
begin\r
ClientTest;\r
+ JSONProtocolReadWriteTest;\r
end;\r
\r
proc := procedure\r
--- /dev/null
+(*
+ * 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.
-(*\r
- * Licensed to the Apache Software Foundation (ASF) under one\r
- * or more contributor license agreements. See the NOTICE file\r
- * distributed with this work for additional information\r
- * regarding copyright ownership. The ASF licenses this file\r
- * to you under the Apache License, Version 2.0 (the\r
- * "License"); you may not use this file except in compliance\r
- * with the License. You may obtain a copy of the License at\r
- *\r
- * http://www.apache.org/licenses/LICENSE-2.0\r
- *\r
- * Unless required by applicable law or agreed to in writing,\r
- * software distributed under the License is distributed on an\r
- * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY\r
- * KIND, either express or implied. See the License for the\r
- * specific language governing permissions and limitations\r
- * under the License.\r
- *)\r
-\r
-unit TestServer;\r
-\r
-interface\r
-\r
-uses\r
- SysUtils,\r
- Generics.Collections,\r
- Thrift.Console,\r
- Thrift.Server,\r
- Thrift.Transport,\r
- Thrift.Collections,\r
- Thrift.Utils,\r
- Thrift.Test,\r
- Thrift,\r
- Contnrs;\r
-\r
-type\r
- TTestServer = class\r
- public\r
- type\r
-\r
- ITestHandler = interface( TThriftTest.Iface )\r
- procedure SetServer( AServer : IServer );\r
- end;\r
-\r
- TTestHandlerImpl = class( TInterfacedObject, ITestHandler )\r
- private\r
- FServer : IServer;\r
- protected\r
- procedure testVoid();\r
+(*
+ * 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;
procedure testException(arg: string);
function testMultiException(arg0: string; arg1: string): IXtruct;
procedure testOneway(secondsToSleep: Integer);
-\r
- procedure testStop;\r
-\r
- procedure SetServer( AServer : IServer );\r
- end;\r
-\r
- class procedure Execute( args: array of string);\r
- end;\r
-\r
-implementation\r
-\r
-{ TTestServer.TTestHandlerImpl }\r
-\r
-procedure TTestServer.TTestHandlerImpl.SetServer(AServer: IServer);\r
-begin\r
- FServer := AServer;\r
-end;\r
-\r
-function TTestServer.TTestHandlerImpl.testByte(thing: ShortInt): ShortInt;\r
-begin\r
- Console.WriteLine('testByte("' + IntToStr( thing) + '")');\r
- Result := thing;\r
-end;\r
-\r
-function TTestServer.TTestHandlerImpl.testDouble(thing: Double): Double;\r
-begin\r
- Console.WriteLine('testDouble("' + FloatToStr( thing ) + '")');\r
- Result := thing;\r
-end;\r
-\r
-function TTestServer.TTestHandlerImpl.testEnum(thing: TNumberz): TNumberz;\r
-begin\r
- Console.WriteLine('testEnum(' + IntToStr( Integer( thing)) + ')');\r
- Result := thing;\r
-end;\r
-\r
-procedure TTestServer.TTestHandlerImpl.testException(arg: string);\r
-var\r
- x : TXception;\r
-begin\r
- Console.WriteLine('testException(' + arg + ')');\r
- if ( arg = 'Xception') then\r
- begin\r
- x := TXception.Create;\r
- x.ErrorCode := 1001;\r
- x.Message_ := 'This is an Xception';\r
- raise x;\r
- end;\r
-end;\r
-\r
-function TTestServer.TTestHandlerImpl.testI32(thing: Integer): Integer;\r
-begin\r
- Console.WriteLine('testI32("' + IntToStr( thing) + '")');\r
- Result := thing;\r
-end;\r
-\r
-function TTestServer.TTestHandlerImpl.testI64(thing: Int64): Int64;\r
-begin\r
- Console.WriteLine('testI64("' + IntToStr( thing) + '")');\r
- Result := thing;\r
-end;\r
-\r
-function TTestServer.TTestHandlerImpl.testInsanity(\r
- argument: IInsanity): IThriftDictionary<Int64, IThriftDictionary<TNumberz, IInsanity>>;\r
-var\r
- hello, goodbye : IXtruct;\r
- crazy : IInsanity;\r
- looney : IInsanity;\r
- first_map : IThriftDictionary<TNumberz, IInsanity>;\r
- second_map : IThriftDictionary<TNumberz, IInsanity>;\r
- insane : IThriftDictionary<Int64, IThriftDictionary<TNumberz, IInsanity>>;\r
-\r
-begin\r
-\r
- Console.WriteLine('testInsanity()');\r
- hello := TXtructImpl.Create;\r
- hello.String_thing := 'hello';\r
- hello.Byte_thing := 2;\r
- hello.I32_thing := 2;\r
- hello.I64_thing := 2;\r
-\r
- goodbye := TXtructImpl.Create;\r
- goodbye.String_thing := 'Goodbye4';\r
- goodbye.Byte_thing := 4;\r
- goodbye.I32_thing := 4;\r
- goodbye.I64_thing := 4;\r
-\r
- crazy := TInsanityImpl.Create;\r
- crazy.UserMap := TThriftDictionaryImpl<TNumberz, Int64>.Create;\r
- crazy.UserMap.AddOrSetValue( TNumberz.EIGHT, 8);\r
- crazy.Xtructs := TThriftListImpl<IXtruct>.Create;\r
- crazy.Xtructs.Add(goodbye);\r
-\r
- looney := TInsanityImpl.Create;\r
- crazy.UserMap.AddOrSetValue( TNumberz.FIVE, 5);\r
- crazy.Xtructs.Add(hello);\r
-\r
- first_map := TThriftDictionaryImpl<TNumberz, IInsanity>.Create;\r
- second_map := TThriftDictionaryImpl<TNumberz, IInsanity>.Create;\r
-\r
- first_map.AddOrSetValue( TNumberz.SIX, crazy);\r
- first_map.AddOrSetValue( TNumberz.THREE, crazy);\r
-\r
- second_map.AddOrSetValue( TNumberz.SIX, looney);\r
-\r
- insane := TThriftDictionaryImpl<Int64, IThriftDictionary<TNumberz, IInsanity>>.Create;\r
-\r
- insane.AddOrSetValue( 1, first_map);\r
- insane.AddOrSetValue( 2, second_map);\r
-\r
- Result := insane;\r
-end;\r
-\r
-function TTestServer.TTestHandlerImpl.testList(\r
- thing: IThriftList<Integer>): IThriftList<Integer>;\r
-var\r
- first : Boolean;\r
- elem : Integer;\r
-begin\r
- Console.Write('testList({');\r
- first := True;\r
- for elem in thing do\r
- begin\r
- if first then\r
- begin\r
- first := False;\r
- end else\r
- begin\r
- Console.Write(', ');\r
- end;\r
- Console.Write( IntToStr( elem));\r
- end;\r
- Console.WriteLine('})');\r
- Result := thing;\r
-end;\r
-\r
-function TTestServer.TTestHandlerImpl.testMap(\r
- thing: IThriftDictionary<Integer, Integer>): IThriftDictionary<Integer, Integer>;\r
-var\r
- first : Boolean;\r
- key : Integer;\r
-begin\r
- Console.Write('testMap({');\r
- first := True;\r
- for key in thing.Keys do\r
- begin\r
- if (first) then\r
- begin\r
- first := false;\r
- end else\r
- begin\r
- Console.Write(', ');\r
- end;\r
- Console.Write(IntToStr(key) + ' => ' + IntToStr( thing[key]));\r
- end;\r
- Console.WriteLine('})');\r
- Result := thing;\r
-end;\r
-\r
-function TTestServer.TTestHandlerImpl.TestMapMap(\r
- hello: Integer): IThriftDictionary<Integer, IThriftDictionary<Integer, Integer>>;\r
-var\r
- mapmap : IThriftDictionary<Integer, IThriftDictionary<Integer, Integer>>;\r
- pos : IThriftDictionary<Integer, Integer>;\r
- neg : IThriftDictionary<Integer, Integer>;\r
- i : Integer;\r
-begin\r
- Console.WriteLine('testMapMap(' + IntToStr( hello) + ')');\r
- mapmap := TThriftDictionaryImpl<Integer, IThriftDictionary<Integer, Integer>>.Create;\r
- pos := TThriftDictionaryImpl<Integer, Integer>.Create;\r
- neg := TThriftDictionaryImpl<Integer, Integer>.Create;\r
-\r
- for i := 1 to 4 do\r
- begin\r
- pos.AddOrSetValue( i, i);\r
- neg.AddOrSetValue( -i, -i);\r
- end;\r
-\r
- mapmap.AddOrSetValue(4, pos);\r
- mapmap.AddOrSetValue( -4, neg);\r
-\r
- Result := mapmap;\r
-end;\r
-\r
-function TTestServer.TTestHandlerImpl.testMulti(arg0: ShortInt; arg1: Integer;\r
- arg2: Int64; arg3: IThriftDictionary<SmallInt, string>; arg4: TNumberz;\r
- arg5: Int64): IXtruct;\r
-var\r
- hello : IXtruct;\r
-begin\r
- Console.WriteLine('testMulti()');\r
- hello := TXtructImpl.Create;\r
- hello.String_thing := 'Hello2';\r
- hello.Byte_thing := arg0;\r
- hello.I32_thing := arg1;\r
- hello.I64_thing := arg2;\r
- Result := hello;\r
-end;\r
-\r
-function TTestServer.TTestHandlerImpl.testMultiException(arg0,\r
- arg1: string): IXtruct;\r
-var\r
- x : TXception;\r
- x2 : TXception2;\r
-begin\r
- Console.WriteLine('testMultiException(' + arg0 + ', ' + arg1 + ')');\r
- if ( arg0 = 'Xception') then\r
- begin\r
- x := TXception.Create;\r
- x.ErrorCode := 1001;\r
- x.Message_ := 'This is an Xception';\r
- raise x;\r
- end else\r
- if ( arg0 = 'Xception2') then\r
- begin\r
- x2 := TXception2.Create;\r
- x2.ErrorCode := 2002;\r
- x2.Struct_thing := TXtructImpl.Create;\r
- x2.Struct_thing.String_thing := 'This is an Xception2';\r
- raise x2;\r
- end;\r
-\r
- Result := TXtructImpl.Create;\r
- Result.String_thing := arg1;\r
-end;\r
-\r
-function TTestServer.TTestHandlerImpl.testNest(thing: IXtruct2): IXtruct2;\r
-var\r
- temp : IXtruct;\r
-begin\r
- temp := thing.Struct_thing;\r
- Console.WriteLine('testNest({' +\r
- IntToStr( thing.Byte_thing) + ', {' +\r
- '"' + temp.String_thing + '", ' +\r
- IntToStr( temp.Byte_thing) + ', ' +\r
- IntToStr( temp.I32_thing) + ', ' +\r
- IntToStr( temp.I64_thing) + '}, ' +\r
- IntToStr( temp.I32_thing) + '})');\r
- Result := thing;\r
-end;\r
-\r
-procedure TTestServer.TTestHandlerImpl.testOneway(secondsToSleep: Integer);\r
-begin\r
- Console.WriteLine('testOneway(' + IntToStr( secondsToSleep )+ '), sleeping...');\r
- Sleep(secondsToSleep * 1000);\r
- Console.WriteLine('testOneway finished');\r
-end;\r
-\r
-function TTestServer.TTestHandlerImpl.testSet(\r
- thing: IHashSet<Integer>):IHashSet<Integer>;\r
-var\r
- first : Boolean;\r
- elem : Integer;\r
-begin\r
- Console.Write('testSet({');\r
- first := True;\r
-\r
- for elem in thing do\r
- begin\r
- if first then\r
- begin\r
- first := False;\r
- end else\r
- begin\r
- Console.Write( ', ');\r
- end;\r
- Console.Write( IntToStr( elem));\r
- end;\r
- Console.WriteLine('})');\r
- Result := thing;\r
-end;\r
-\r
-procedure TTestServer.TTestHandlerImpl.testStop;\r
-begin\r
- if FServer <> nil then\r
- begin\r
- FServer.Stop;\r
- end;\r
-end;\r
-\r
-function TTestServer.TTestHandlerImpl.testString(thing: string): string;\r
-begin\r
- Console.WriteLine('teststring("' + thing + '")');\r
- Result := thing;\r
-end;\r
-\r
-function TTestServer.TTestHandlerImpl.testStringMap(\r
- thing: IThriftDictionary<string, string>): IThriftDictionary<string, string>;\r
-begin\r
-\r
-end;\r
-\r
-function TTestServer.TTestHandlerImpl.testTypedef(thing: Int64): Int64;\r
-begin\r
- Console.WriteLine('testTypedef(' + IntToStr( thing) + ')');\r
- Result := thing;\r
-end;\r
-\r
-procedure TTestServer.TTestHandlerImpl.TestVoid;\r
-begin\r
- Console.WriteLine('testVoid()');\r
-end;\r
-\r
-function TTestServer.TTestHandlerImpl.testStruct(thing: IXtruct): IXtruct;\r
-begin\r
- Console.WriteLine('testStruct({' +\r
- '"' + thing.String_thing + '", ' +\r
- IntToStr( thing.Byte_thing) + ', ' +\r
- IntToStr( thing.I32_thing) + ', ' +\r
- IntToStr( thing.I64_thing));\r
- Result := thing;\r
-end;\r
-\r
-{ TTestServer }\r
-\r
-class procedure TTestServer.Execute(args: array of string);\r
-var\r
- UseBufferedSockets : Boolean;\r
- UseFramed : Boolean;\r
- Port : Integer;\r
- testHandler : ITestHandler;\r
- testProcessor : IProcessor;\r
- ServerSocket : IServerTransport;\r
- ServerEngine : IServer;\r
- TransportFactroy : ITransportFactory;\r
-\r
-\r
-begin\r
- try\r
- UseBufferedSockets := False;\r
- UseFramed := False;\r
- Port := 9090;\r
-\r
- if ( Length( args) > 0) then\r
- begin\r
- Port := StrToIntDef( args[0], Port);\r
-\r
- if ( Length( args) > 0) then\r
- begin\r
- if ( args[0] = 'raw' ) then\r
- begin\r
- // as default\r
- end else\r
- if ( args[0] = 'buffered' ) then\r
- begin\r
- UseBufferedSockets := True;\r
- end else\r
- if ( args[0] = 'framed' ) then\r
- begin\r
- UseFramed := True;\r
- end else\r
- begin\r
- // Fall back to the older boolean syntax\r
- UseBufferedSockets := StrToBoolDef( args[1], UseBufferedSockets);\r
- end\r
- end\r
- end;\r
-\r
- testHandler := TTestHandlerImpl.Create;\r
-\r
- testProcessor := TThriftTest.TProcessorImpl.Create( testHandler );\r
- ServerSocket := TServerSocketImpl.Create( Port, 0, UseBufferedSockets );\r
- if UseFramed then\r
- begin\r
- TransportFactroy := TFramedTransportImpl.TFactory.Create;\r
- ServerEngine := TSimpleServer.Create( testProcessor, ServerSocket,\r
- TransportFactroy);\r
- end else\r
- begin\r
- ServerEngine := TSimpleServer.Create( testProcessor, ServerSocket);\r
- end;\r
-\r
- testHandler.SetServer( ServerEngine);\r
-\r
- Console.WriteLine('Starting the server on port ' + IntToStr( Port) +\r
- IfValue(UseBufferedSockets, ' with buffered socket', '') +\r
- IfValue(useFramed, ' with framed transport', '') +\r
- '...');\r
-\r
- serverEngine.Serve;\r
- testHandler.SetServer( nil);\r
-\r
- except\r
- on E: Exception do\r
- begin\r
- Console.Write( E.Message);\r
- end;\r
- end;\r
- Console.WriteLine( 'done.');\r
-end;\r
-\r
-end.\r
+
+ 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.
-(*\r
- * Licensed to the Apache Software Foundation (ASF) under one\r
- * or more contributor license agreements. See the NOTICE file\r
- * distributed with this work for additional information\r
- * regarding copyright ownership. The ASF licenses this file\r
- * to you under the Apache License, Version 2.0 (the\r
- * "License"); you may not use this file except in compliance\r
- * with the License. You may obtain a copy of the License at\r
- *\r
- * http://www.apache.org/licenses/LICENSE-2.0\r
- *\r
- * Unless required by applicable law or agreed to in writing,\r
- * software distributed under the License is distributed on an\r
- * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY\r
- * KIND, either express or implied. See the License for the\r
- * specific language governing permissions and limitations\r
- * under the License.\r
- *)\r
-\r
-\r
-program client;\r
-\r
-{$APPTYPE CONSOLE}\r
-\r
-uses\r
- SysUtils,\r
- TestClient in 'TestClient.pas',\r
- Thrift.Test in 'gen-delphi\Thrift.Test.pas',\r
- Thrift in '..\..\..\lib\delphi\src\Thrift.pas',\r
- Thrift.Transport in '..\..\..\lib\delphi\src\Thrift.Transport.pas',\r
- Thrift.Protocol in '..\..\..\lib\delphi\src\Thrift.Protocol.pas',\r
- Thrift.Collections in '..\..\..\lib\delphi\src\Thrift.Collections.pas',\r
- Thrift.Server in '..\..\..\lib\delphi\src\Thrift.Server.pas',\r
- Thrift.Stream in '..\..\..\lib\delphi\src\Thrift.Stream.pas',\r
- Thrift.Console in '..\..\..\lib\delphi\src\Thrift.Console.pas',\r
- Thrift.Utils in '..\..\..\lib\delphi\src\Thrift.Utils.pas';\r
-\r
-var\r
- nParamCount : Integer;\r
- args : array of string;\r
- i : Integer;\r
- arg : string;\r
- s : string;\r
-\r
-begin\r
- try\r
- Writeln( 'Delphi TestClient '+Thrift.Version);\r
- nParamCount := ParamCount;\r
- SetLength( args, nParamCount);\r
- for i := 1 to nParamCount do\r
- begin\r
- arg := ParamStr( i );\r
- args[i-1] := arg;\r
- end;\r
- TTestClient.Execute( args );\r
- Readln;\r
- except\r
- on E: Exception do\r
- Writeln(E.ClassName, ': ', E.Message);\r
- end;\r
-end.\r
-\r
+(*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
-(*\r
- * Licensed to the Apache Software Foundation (ASF) under one\r
- * or more contributor license agreements. See the NOTICE file\r
- * distributed with this work for additional information\r
- * regarding copyright ownership. The ASF licenses this file\r
- * to you under the Apache License, Version 2.0 (the\r
- * "License"); you may not use this file except in compliance\r
- * with the License. You may obtain a copy of the License at\r
- *\r
- * http://www.apache.org/licenses/LICENSE-2.0\r
- *\r
- * Unless required by applicable law or agreed to in writing,\r
- * software distributed under the License is distributed on an\r
- * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY\r
- * KIND, either express or implied. See the License for the\r
- * specific language governing permissions and limitations\r
- * under the License.\r
- *)\r
-\r
-program server;\r
-\r
-{$APPTYPE CONSOLE}\r
-\r
-uses\r
- SysUtils,\r
- TestServer in 'TestServer.pas',\r
- Thrift.Test in 'gen-delphi\Thrift.Test.pas',\r
- Thrift in '..\..\..\lib\delphi\src\Thrift.pas',\r
- Thrift.Transport in '..\..\..\lib\delphi\src\Thrift.Transport.pas',\r
- Thrift.Protocol in '..\..\..\lib\delphi\src\Thrift.Protocol.pas',\r
- Thrift.Collections in '..\..\..\lib\delphi\src\Thrift.Collections.pas',\r
- Thrift.Server in '..\..\..\lib\delphi\src\Thrift.Server.pas',\r
- Thrift.Console in '..\..\..\lib\delphi\src\Thrift.Console.pas',\r
- Thrift.Utils in '..\..\..\lib\delphi\src\Thrift.Utils.pas',\r
- Thrift.Stream in '..\..\..\lib\delphi\src\Thrift.Stream.pas';\r
-\r
-var\r
- nParamCount : Integer;\r
- args : array of string;\r
- i : Integer;\r
- arg : string;\r
- s : string;\r
-\r
-begin\r
- try\r
- Writeln( 'Delphi TestServer '+Thrift.Version);\r
- nParamCount := ParamCount;\r
- SetLength( args, nParamCount);\r
- for i := 1 to nParamCount do\r
- begin\r
- arg := ParamStr( i );\r
- args[i-1] := arg;\r
- end;\r
- TTestServer.Execute( args );\r
- Readln;\r
- except\r
- on E: Exception do\r
- Writeln(E.ClassName, ': ', E.Message);\r
- end;\r
-end.\r
-\r
-\r
-\r
+(*
+ * 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.
+
Code Review / common / thrift.git / commitdiff
