diff options
Diffstat (limited to 'src/jaegertracing/thrift/lib/delphi/test')
29 files changed, 5462 insertions, 0 deletions
diff --git a/src/jaegertracing/thrift/lib/delphi/test/ConsoleHelper.pas b/src/jaegertracing/thrift/lib/delphi/test/ConsoleHelper.pas new file mode 100644 index 000000000..0a8ddcf10 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/ConsoleHelper.pas @@ -0,0 +1,132 @@ +(* + * 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 ConsoleHelper; + +interface + +uses Classes; + +type + TThriftConsole = class + public + procedure Write( const S: string); virtual; + procedure WriteLine( const S: string); virtual; + end; + + TGUIConsole = class( TThriftConsole ) + private + FLineBreak : Boolean; + FMemo : TStrings; + + procedure InternalWrite( const S: string; bWriteLine: Boolean); + public + procedure Write( const S: string); override; + procedure WriteLine( const S: string); override; + constructor Create( AMemo: TStrings); + end; + +function Console: TThriftConsole; +procedure ChangeConsole( AConsole: TThriftConsole ); +procedure RestoreConsoleToDefault; + +implementation + +var + FDefaultConsole : TThriftConsole; + FConsole : TThriftConsole; + +function Console: TThriftConsole; +begin + Result := FConsole; +end; + +{ TThriftConsole } + +procedure TThriftConsole.Write(const S: string); +begin + System.Write( S ); +end; + +procedure TThriftConsole.WriteLine(const S: string); +begin + System.Writeln( S ); +end; + +procedure ChangeConsole( AConsole: TThriftConsole ); +begin + FConsole := AConsole; +end; + +procedure RestoreConsoleToDefault; +begin + FConsole := FDefaultConsole; +end; + +{ TGUIConsole } + +constructor TGUIConsole.Create( AMemo: TStrings); +begin + inherited Create; + FMemo := AMemo; + FLineBreak := True; +end; + +procedure TGUIConsole.InternalWrite(const S: string; bWriteLine: Boolean); +var + idx : Integer; +begin + if FLineBreak then + begin + FMemo.Add( S ); + end else + begin + idx := FMemo.Count - 1; + if idx < 0 then + FMemo.Add( S ) + else + FMemo[idx] := FMemo[idx] + S; + end; + FLineBreak := bWriteLine; +end; + +procedure TGUIConsole.Write(const S: string); +begin + InternalWrite( S, False); +end; + +procedure TGUIConsole.WriteLine(const S: string); +begin + InternalWrite( S, True); +end; + +initialization +begin + FDefaultConsole := TThriftConsole.Create; + FConsole := FDefaultConsole; +end; + +finalization +begin + FDefaultConsole.Free; +end; + +end. + + diff --git a/src/jaegertracing/thrift/lib/delphi/test/Performance/DataFactory.pas b/src/jaegertracing/thrift/lib/delphi/test/Performance/DataFactory.pas new file mode 100644 index 000000000..e131822a3 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/Performance/DataFactory.pas @@ -0,0 +1,176 @@ +// 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 DataFactory; + +interface + +uses + SysUtils, + Thrift.Collections, + Thrift.Test; + +type + TestDataFactory = class + strict protected + class function CreateSetField(const count : Integer) : IHashSet< IInsanity>; static; + class function CreateInsanity(const count : Integer) : IInsanity; static; + class function CreateBytesArray(const count : Integer) : TBytes; static; + class function CreateXtructs(const count : Integer) : IThriftList< IXtruct>; static; + class function CreateXtruct(const count : Integer) : IXtruct; static; + class function CreateListField(const count : Integer) : IThriftList< IThriftDictionary< IHashSet< Integer>, IThriftDictionary< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>>>; static; + class function CreateUserMap(const count : Integer) : IThriftDictionary< TNumberz, Int64>; static; + class function CreateListFieldData(const count : Integer) : IThriftDictionary< IHashSet< Integer>, IThriftDictionary< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>>; static; + class function CreateIntHashSet(const count : Integer) : IHashSet< Integer>; static; + class function CreateListFieldDataDict(const count : Integer) : IThriftDictionary< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>; static; + class function CreateListFieldDataDictValue(const count : Integer) : IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>; static; + class function CreateListFieldDataDictValueList(const count : Integer) : IThriftList< IThriftDictionary< IInsanity, string>>; static; + class function CreateListFieldDataDictValueListDict(const count : Integer) : IThriftDictionary< IInsanity, string>; static; + public + class function CreateCrazyNesting(const count : Integer = 10) : ICrazyNesting; static; + end; + +implementation + + +class function TestDataFactory.CreateCrazyNesting(const count : Integer = 10) : ICrazyNesting; +begin + if (count <= 0) + then Exit(nil); + + result := TCrazyNestingImpl.Create; + result.Binary_field := CreateBytesArray(count); + result.List_field := CreateListField(count); + result.Set_field := CreateSetField(count); + result.String_field := Format('data level %d', [count]); +end; + +class function TestDataFactory.CreateSetField(const count : Integer) : IHashSet< IInsanity>; +var i : Integer; +begin + result := THashSetImpl< IInsanity>.Create; + for i := 0 to count-1 do begin + result.Add(CreateInsanity(count)); + end; +end; + +class function TestDataFactory.CreateInsanity(const count : Integer) : IInsanity; +begin + result := TInsanityImpl.Create; + result.UserMap := CreateUserMap(count); + result.Xtructs := CreateXtructs(count); +end; + +class function TestDataFactory.CreateXtructs(const count : Integer) : IThriftList< IXtruct>; +var i : Integer; +begin + result := TThriftListImpl< IXtruct>.Create; + for i := 0 to count-1 do begin + result.Add(CreateXtruct(count)); + end; +end; + +class function TestDataFactory.CreateXtruct(const count : Integer) : IXtruct; +begin + result := TXtructImpl.Create; + result.Byte_thing := SmallInt(count mod 128); + result.I32_thing := count; + result.I64_thing := count; + result.String_thing := Format('data level %d', [count]); +end; + +class function TestDataFactory.CreateUserMap(const count : Integer) : IThriftDictionary< TNumberz, Int64>; +begin + result := TThriftDictionaryImpl< TNumberz, Int64>.Create; + result.Add(TNumberz.ONE, count); + result.Add(TNumberz.TWO, count); + result.Add(TNumberz.THREE, count); + result.Add(TNumberz.FIVE, count); + result.Add(TNumberz.SIX, count); + result.Add(TNumberz.EIGHT, count); +end; + +class function TestDataFactory.CreateListField(const count : Integer) : IThriftList< IThriftDictionary< IHashSet< Integer>, IThriftDictionary< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>>>; +var i : Integer; +begin + result := TThriftListImpl< IThriftDictionary< IHashSet< Integer>, IThriftDictionary< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>>>.Create; + for i := 0 to count-1 do begin + result.Add(CreateListFieldData(count)); + end; +end; + +class function TestDataFactory.CreateListFieldData(const count : Integer) : IThriftDictionary< IHashSet< Integer>, IThriftDictionary< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>>; +var i : Integer; +begin + result := TThriftDictionaryImpl< IHashSet< Integer>, IThriftDictionary< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>>.Create; + for i := 0 to count-1 do begin + result.Add( CreateIntHashSet(count), CreateListFieldDataDict(count)); + end; +end; + +class function TestDataFactory.CreateIntHashSet(const count : Integer) : IHashSet< Integer>; +var i : Integer; +begin + result := THashSetImpl< Integer>.Create; + for i := 0 to count-1 do begin + result.Add(i); + end; +end; + +class function TestDataFactory.CreateListFieldDataDict(const count : Integer) : IThriftDictionary< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>; +var i : Integer; +begin + result := TThriftDictionaryImpl< Integer, IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>>.Create; + for i := 0 to count-1 do begin + result.Add(i, CreateListFieldDataDictValue(count)); + end; +end; + +class function TestDataFactory.CreateListFieldDataDictValue(const count : Integer) : IHashSet< IThriftList< IThriftDictionary< IInsanity, string>>>; +var i : Integer; +begin + result := THashSetImpl< IThriftList< IThriftDictionary< IInsanity, string>>>.Create; + for i := 0 to count-1 do begin + result.Add( CreateListFieldDataDictValueList(count)); + end; +end; + +class function TestDataFactory.CreateListFieldDataDictValueList(const count : Integer) : IThriftList< IThriftDictionary< IInsanity, string>>; +var i : Integer; +begin + result := TThriftListImpl< IThriftDictionary< IInsanity, string>>.Create; + for i := 0 to count-1 do begin + result.Add(CreateListFieldDataDictValueListDict(count)); + end; +end; + +class function TestDataFactory.CreateListFieldDataDictValueListDict(const count : Integer) : IThriftDictionary< IInsanity, string>; +begin + result := TThriftDictionaryImpl< IInsanity, string>.Create; + result.Add(CreateInsanity(count), Format('data level %d', [count])); +end; + +class function TestDataFactory.CreateBytesArray(const count : Integer) : TBytes; +var i : Integer; +begin + SetLength( result, count); + for i := 0 to count-1 do begin + result[i] := i mod $FF; + end; +end; + +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/Performance/PerfTests.pas b/src/jaegertracing/thrift/lib/delphi/test/Performance/PerfTests.pas new file mode 100644 index 000000000..2c820b1f3 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/Performance/PerfTests.pas @@ -0,0 +1,173 @@ +// Licensed to the Apache Software Foundation(ASF) under one +// or more contributor license agreements.See the NOTICE file +// distributed with this work for additional information +// regarding copyright ownership.The ASF licenses this file +// to you under the Apache License, Version 2.0 (the +// "License"); you may not use this file except in compliance +// with the License. You may obtain a copy of the License at +// +// http://www.apache.org/licenses/LICENSE-2.0 +// +// Unless required by applicable law or agreed to in writing, +// software distributed under the License is distributed on an +// "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +// KIND, either express or implied. See the License for the +// specific language governing permissions and limitations +// under the License. +unit PerfTests; + +interface + +uses + Windows, Classes, SysUtils, + Thrift.Collections, + Thrift.Test, + Thrift.Protocol, + Thrift.Protocol.JSON, + Thrift.Protocol.Compact, + Thrift.Transport, + Thrift.Stream, + ConsoleHelper, + TestConstants, + DataFactory; + +type + TPerformanceTests = class + strict private + Testdata : ICrazyNesting; + MemBuffer : TMemoryStream; + Transport : ITransport; + + procedure ProtocolPeformanceTest; + procedure RunTest( const ptyp : TKnownProtocol; const layered : TLayeredTransport); + function GenericProtocolFactory(const ptyp : TKnownProtocol; const layered : TLayeredTransport; const forWrite : Boolean) : IProtocol; + function GetProtocolTransportName(const ptyp : TKnownProtocol; const layered : TLayeredTransport) : string; + public + class function Execute : Integer; + end; + + +implementation + + +// not available in all versions, so make sure we have this one imported +function IsDebuggerPresent: BOOL; stdcall; external KERNEL32 name 'IsDebuggerPresent'; + + +class function TPerformanceTests.Execute : Integer; +var instance : TPerformanceTests; +begin + instance := TPerformanceTests.Create; + instance.ProtocolPeformanceTest; + + // debug only + if IsDebuggerPresent then begin + Console.Write('Hit ENTER ...'); + ReadLn; + end; + + result := 0; +end; + + +procedure TPerformanceTests.ProtocolPeformanceTest; +var layered : TLayeredTransport; +begin + Console.WriteLine('Setting up for ProtocolPeformanceTest ...'); + Testdata := TestDataFactory.CreateCrazyNesting(); + + for layered := Low(TLayeredTransport) to High(TLayeredTransport) do begin + RunTest( TKnownProtocol.prot_Binary, layered); + RunTest( TKnownProtocol.prot_Compact, layered); + RunTest( TKnownProtocol.prot_JSON, layered); + end; +end; + + +procedure TPerformanceTests.RunTest( const ptyp : TKnownProtocol; const layered : TLayeredTransport); +var freq, start, stop : Int64; + proto : IProtocol; + restored : ICrazyNesting; +begin + QueryPerformanceFrequency( freq); + + proto := GenericProtocolFactory( ptyp, layered, TRUE); + QueryPerformanceCounter( start); + Testdata.Write(proto); + Transport.Flush; + QueryPerformanceCounter( stop); + Console.WriteLine( Format('RunTest(%s): write = %d msec', [ + GetProtocolTransportName(ptyp,layered), + Round(1000.0*(stop-start)/freq) + ])); + + restored := TCrazyNestingImpl.Create; + proto := GenericProtocolFactory( ptyp, layered, FALSE); + QueryPerformanceCounter( start); + restored.Read(proto); + QueryPerformanceCounter( stop); + Console.WriteLine( Format('RunTest(%s): read = %d msec', [ + GetProtocolTransportName(ptyp,layered), + Round(1000.0*(stop-start)/freq) + ])); +end; + + +function TPerformanceTests.GenericProtocolFactory(const ptyp : TKnownProtocol; const layered : TLayeredTransport; const forWrite : Boolean) : IProtocol; +var newBuf : TMemoryStream; + stream : IThriftStream; + trans : IStreamTransport; +const COPY_ENTIRE_STREAM = 0; +begin + // read happens after write here, so let's take over the written bytes + newBuf := TMemoryStream.Create; + if not forWrite then newBuf.CopyFrom( MemBuffer, COPY_ENTIRE_STREAM); + MemBuffer := newBuf; + MemBuffer.Position := 0; + + // layered transports anyone? + stream := TThriftStreamAdapterDelphi.Create( newBuf, TRUE); + if forWrite + then trans := TStreamTransportImpl.Create( nil, stream) + else trans := TStreamTransportImpl.Create( stream, nil); + case layered of + trns_Framed : Transport := TFramedTransportImpl.Create( trans); + trns_Buffered : Transport := TBufferedTransportImpl.Create( trans); + else + Transport := trans; + end; + + if not Transport.IsOpen + then Transport.Open; + + case ptyp of + prot_Binary : result := TBinaryProtocolImpl.Create(trans); + prot_Compact : result := TCompactProtocolImpl.Create(trans); + prot_JSON : result := TJSONProtocolImpl.Create(trans); + else + ASSERT(FALSE); + end; +end; + + +function TPerformanceTests.GetProtocolTransportName(const ptyp : TKnownProtocol; const layered : TLayeredTransport) : string; +begin + case layered of + trns_Framed : result := ' + framed'; + trns_Buffered : result := ' + buffered'; + else + result := ''; + end; + + case ptyp of + prot_Binary : result := 'binary' + result; + prot_Compact : result := 'compact' + result; + prot_JSON : result := 'JSON' + result; + else + ASSERT(FALSE); + end; +end; + + +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/TestClient.pas b/src/jaegertracing/thrift/lib/delphi/test/TestClient.pas new file mode 100644 index 000000000..e59c32720 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/TestClient.pas @@ -0,0 +1,1506 @@ +(* + * 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 TestClient; + +{$I ../src/Thrift.Defines.inc} + +{.$DEFINE StressTest} // activate to stress-test the server with frequent connects/disconnects +{.$DEFINE PerfTest} // activate the performance test +{$DEFINE Exceptions} // activate the exceptions test (or disable while debugging) + +{$if CompilerVersion >= 28} +{$DEFINE SupportsAsync} +{$ifend} + +{$WARN SYMBOL_PLATFORM OFF} // Win32Check + +interface + +uses + Windows, SysUtils, Classes, Math, ComObj, ActiveX, + {$IFDEF SupportsAsync} System.Threading, {$ENDIF} + DateUtils, + Generics.Collections, + TestConstants, + ConsoleHelper, + PerfTests, + Thrift, + Thrift.Protocol.Compact, + Thrift.Protocol.JSON, + Thrift.Protocol, + Thrift.Transport.Pipes, + Thrift.Transport.WinHTTP, + Thrift.Transport.MsxmlHTTP, + Thrift.Transport, + Thrift.Stream, + Thrift.Test, + Thrift.WinHTTP, + Thrift.Utils, + Thrift.Collections; + +type + TThreadConsole = class + private + FThread : TThread; + public + procedure Write( const S : string); + procedure WriteLine( const S : string); + constructor Create( AThread: TThread); + end; + + TTestSetup = record + protType : TKnownProtocol; + endpoint : TEndpointTransport; + layered : TLayeredTransports; + useSSL : Boolean; // include where appropriate (TLayeredTransport?) + host : string; + port : Integer; + sPipeName : string; + hAnonRead, hAnonWrite : THandle; + end; + + TClientThread = class( TThread ) + private type + TTestGroup = ( + test_Unknown, + test_BaseTypes, + test_Structs, + test_Containers, + test_Exceptions + // new values here + ); + TTestGroups = set of TTestGroup; + + TTestSize = ( + Empty, // Edge case: the zero-length empty binary + Normal, // Fairly small array of usual size (256 bytes) + ByteArrayTest, // THRIFT-4454 Large writes/reads may cause range check errors in debug mode + PipeWriteLimit, // THRIFT-4372 Pipe write operations across a network are limited to 65,535 bytes per write. + TwentyMB // that's quite a bit of data + ); + + private + FSetup : TTestSetup; + FTransport : ITransport; + FProtocol : IProtocol; + FNumIteration : Integer; + FConsole : TThreadConsole; + + // test reporting, will be refactored out into separate class later + FTestGroup : string; + FCurrentTest : TTestGroup; + FSuccesses : Integer; + FErrors : TStringList; + FFailed : TTestGroups; + FExecuted : TTestGroups; + procedure StartTestGroup( const aGroup : string; const aTest : TTestGroup); + procedure Expect( aTestResult : Boolean; const aTestInfo : string); + procedure ReportResults; + function CalculateExitCode : Byte; + + procedure ClientTest; + {$IFDEF SupportsAsync} + procedure ClientAsyncTest; + {$ENDIF} + + procedure InitializeProtocolTransportStack; + procedure ShutdownProtocolTransportStack; + function InitializeHttpTransport( const aTimeoutSetting : Integer) : IHTTPClient; + + procedure JSONProtocolReadWriteTest; + function PrepareBinaryData( aRandomDist : Boolean; aSize : TTestSize) : TBytes; + {$IFDEF StressTest} + procedure StressTest(const client : TThriftTest.Iface); + {$ENDIF} + {$IFDEF Win64} + procedure UseInterlockedExchangeAdd64; + {$ENDIF} + protected + procedure Execute; override; + public + constructor Create( const aSetup : TTestSetup; const aNumIteration: Integer); + destructor Destroy; override; + end; + + TTestClient = class + private + class var + FNumIteration : Integer; + FNumThread : Integer; + + class procedure PrintCmdLineHelp; + class procedure InvalidArgs; + public + class function Execute( const args: array of string) : Byte; + end; + + +implementation + +const + EXITCODE_SUCCESS = $00; // no errors bits set + // + EXITCODE_FAILBIT_BASETYPES = $01; + EXITCODE_FAILBIT_STRUCTS = $02; + EXITCODE_FAILBIT_CONTAINERS = $04; + EXITCODE_FAILBIT_EXCEPTIONS = $08; + + MAP_FAILURES_TO_EXITCODE_BITS : array[TClientThread.TTestGroup] of Byte = ( + EXITCODE_SUCCESS, // no bits here + EXITCODE_FAILBIT_BASETYPES, + EXITCODE_FAILBIT_STRUCTS, + EXITCODE_FAILBIT_CONTAINERS, + EXITCODE_FAILBIT_EXCEPTIONS + ); + + + +function BoolToString( b : Boolean) : string; +// overrides global BoolToString() +begin + if b + then result := 'true' + else result := 'false'; +end; + +// not available in all versions, so make sure we have this one imported +function IsDebuggerPresent: BOOL; stdcall; external KERNEL32 name 'IsDebuggerPresent'; + +{ TTestClient } + +class procedure TTestClient.PrintCmdLineHelp; +const HELPTEXT = ' [options]'#10 + + #10 + + 'Allowed options:'#10 + + ' -h [ --help ] produce help message'#10 + + ' --host arg (=localhost) Host to connect'#10 + + ' --port arg (=9090) Port number to connect'#10 + + ' --domain-socket arg Domain Socket (e.g. /tmp/ThriftTest.thrift),'#10 + + ' instead of host and port'#10 + + ' --named-pipe arg Windows Named Pipe (e.g. MyThriftPipe)'#10 + + ' --anon-pipes hRead hWrite Windows Anonymous Pipes pair (handles)'#10 + + ' --transport arg (=sockets) Transport: buffered, framed, http, winhttp'#10 + + ' --protocol arg (=binary) Protocol: binary, compact, json'#10 + + ' --ssl Encrypted Transport using SSL'#10 + + ' -n [ --testloops ] arg (=1) Number of Tests'#10 + + ' -t [ --threads ] arg (=1) Number of Test threads'#10 + + ' --performance Run the built-in performance test (no other arguments)'#10 + ; +begin + Writeln( ChangeFileExt(ExtractFileName(ParamStr(0)),'') + HELPTEXT); +end; + +class procedure TTestClient.InvalidArgs; +begin + Console.WriteLine( 'Invalid args.'); + Console.WriteLine( ChangeFileExt(ExtractFileName(ParamStr(0)),'') + ' -h for more information'); + Abort; +end; + +class function TTestClient.Execute(const args: array of string) : Byte; +var + i : Integer; + threadExitCode : Byte; + s : string; + threads : array of TThread; + dtStart : TDateTime; + test : Integer; + thread : TThread; + setup : TTestSetup; +begin + // init record + with setup do begin + protType := prot_Binary; + endpoint := trns_Sockets; + layered := []; + useSSL := FALSE; + host := 'localhost'; + port := 9090; + sPipeName := ''; + hAnonRead := INVALID_HANDLE_VALUE; + hAnonWrite := INVALID_HANDLE_VALUE; + end; + + try + i := 0; + while ( i < Length(args) ) do begin + s := args[i]; + Inc( i); + + if (s = '-h') or (s = '--help') then begin + // -h [ --help ] produce help message + PrintCmdLineHelp; + result := $FF; // all tests failed + Exit; + end + else if s = '--host' then begin + // --host arg (=localhost) Host to connect + setup.host := args[i]; + Inc( i); + end + else if s = '--port' then begin + // --port arg (=9090) Port number to connect + s := args[i]; + Inc( i); + setup.port := StrToIntDef(s,0); + if setup.port <= 0 then InvalidArgs; + end + else if s = '--domain-socket' then begin + // --domain-socket arg Domain Socket (e.g. /tmp/ThriftTest.thrift), instead of host and port + raise Exception.Create('domain-socket not supported'); + end + else if s = '--named-pipe' then begin + // --named-pipe arg Windows Named Pipe (e.g. MyThriftPipe) + setup.endpoint := trns_NamedPipes; + setup.sPipeName := args[i]; + Inc( i); + Console.WriteLine('Using named pipe ('+setup.sPipeName+')'); + end + else if s = '--anon-pipes' then begin + // --anon-pipes hRead hWrite Windows Anonymous Pipes pair (handles) + setup.endpoint := trns_AnonPipes; + setup.hAnonRead := THandle( StrToIntDef( args[i], Integer(INVALID_HANDLE_VALUE))); + Inc( i); + setup.hAnonWrite := THandle( StrToIntDef( args[i], Integer(INVALID_HANDLE_VALUE))); + Inc( i); + Console.WriteLine('Using anonymous pipes ('+IntToStr(Integer(setup.hAnonRead))+' and '+IntToStr(Integer(setup.hAnonWrite))+')'); + end + else if s = '--transport' then begin + // --transport arg (=sockets) Transport: buffered, framed, http, winhttp, evhttp + s := args[i]; + Inc( i); + + if s = 'buffered' then Include( setup.layered, trns_Buffered) + else if s = 'framed' then Include( setup.layered, trns_Framed) + else if s = 'http' then setup.endpoint := trns_MsXmlHttp + else if s = 'winhttp' then setup.endpoint := trns_WinHttp + else if s = 'evhttp' then setup.endpoint := trns_EvHttp // recognized, but not supported + else InvalidArgs; + end + else if s = '--protocol' then begin + // --protocol arg (=binary) Protocol: binary, compact, json + s := args[i]; + Inc( i); + + if s = 'binary' then setup.protType := prot_Binary + else if s = 'compact' then setup.protType := prot_Compact + else if s = 'json' then setup.protType := prot_JSON + else InvalidArgs; + end + else if s = '--ssl' then begin + // --ssl Encrypted Transport using SSL + setup.useSSL := TRUE; + + end + else if (s = '-n') or (s = '--testloops') then begin + // -n [ --testloops ] arg (=1) Number of Tests + FNumIteration := StrToIntDef( args[i], 0); + Inc( i); + if FNumIteration <= 0 + then InvalidArgs; + + end + else if (s = '-t') or (s = '--threads') then begin + // -t [ --threads ] arg (=1) Number of Test threads + FNumThread := StrToIntDef( args[i], 0); + Inc( i); + if FNumThread <= 0 + then InvalidArgs; + end + else if (s = '--performance') then begin + result := TPerformanceTests.Execute; + Exit; + end + else begin + InvalidArgs; + end; + end; + + + // In the anonymous pipes mode the client is launched by the test server + // -> behave nicely and allow for attaching a debugger to this process + if (setup.endpoint = trns_AnonPipes) and not IsDebuggerPresent + then MessageBox( 0, 'Attach Debugger and/or click OK to continue.', + 'Thrift TestClient (Delphi)', + MB_OK or MB_ICONEXCLAMATION); + + SetLength( threads, FNumThread); + dtStart := Now; + + // layered transports are not really meant to be stacked upon each other + if (trns_Framed in setup.layered) then begin + Console.WriteLine('Using framed transport'); + end + else if (trns_Buffered in setup.layered) then begin + Console.WriteLine('Using buffered transport'); + end; + + Console.WriteLine(THRIFT_PROTOCOLS[setup.protType]+' protocol'); + + for test := 0 to FNumThread - 1 do begin + thread := TClientThread.Create( setup, FNumIteration); + threads[test] := thread; + thread.Start; + end; + + result := 0; + for test := 0 to FNumThread - 1 do begin + threadExitCode := threads[test].WaitFor; + result := result or threadExitCode; + threads[test].Free; + threads[test] := nil; + end; + + Console.Write('Total time: ' + IntToStr( MilliSecondsBetween(Now, dtStart))); + + except + on E: EAbort do raise; + on E: Exception do begin + Console.WriteLine( E.Message + #10 + E.StackTrace); + raise; + end; + end; + + Console.WriteLine(''); + Console.WriteLine('done!'); +end; + +{ TClientThread } + +procedure TClientThread.ClientTest; +var + client : TThriftTest.Iface; + s : string; + i8 : ShortInt; + i32 : Integer; + i64 : Int64; + binOut,binIn : TBytes; + dub : Double; + o : IXtruct; + o2 : IXtruct2; + i : IXtruct; + i2 : IXtruct2; + mapout : IThriftDictionary<Integer,Integer>; + mapin : IThriftDictionary<Integer,Integer>; + strmapout : IThriftDictionary<string,string>; + strmapin : IThriftDictionary<string,string>; + j : Integer; + first : Boolean; + key : Integer; + strkey : string; + listout : IThriftList<Integer>; + listin : IThriftList<Integer>; + setout : IHashSet<Integer>; + setin : IHashSet<Integer>; + ret : TNumberz; + uid : Int64; + mm : IThriftDictionary<Integer, IThriftDictionary<Integer, Integer>>; + pos : IThriftDictionary<Integer, Integer>; + neg : IThriftDictionary<Integer, Integer>; + m2 : IThriftDictionary<Integer, Integer>; + k2 : Integer; + insane : IInsanity; + truck : IXtruct; + whoa : IThriftDictionary<Int64, IThriftDictionary<TNumberz, IInsanity>>; + key64 : Int64; + val : IThriftDictionary<TNumberz, IInsanity>; + k2_2 : TNumberz; + k3 : TNumberz; + v2 : IInsanity; + userMap : IThriftDictionary<TNumberz, Int64>; + xtructs : IThriftList<IXtruct>; + x : IXtruct; + arg0 : ShortInt; + arg1 : Integer; + arg2 : Int64; + arg3 : IThriftDictionary<SmallInt, string>; + arg4 : TNumberz; + arg5 : Int64; + {$IFDEF PerfTest} + StartTick : Cardinal; + k : Integer; + {$ENDIF} + hello, goodbye : IXtruct; + crazy : IInsanity; + looney : IInsanity; + first_map : IThriftDictionary<TNumberz, IInsanity>; + second_map : IThriftDictionary<TNumberz, IInsanity>; + pair : TPair<TNumberz, TUserId>; + testsize : TTestSize; +begin + client := TThriftTest.TClient.Create( FProtocol); + FTransport.Open; + + {$IFDEF StressTest} + StressTest( client); + {$ENDIF StressTest} + + {$IFDEF Exceptions} + // in-depth exception test + // (1) do we get an exception at all? + // (2) do we get the right exception? + // (3) does the exception contain the expected data? + StartTestGroup( 'testException', test_Exceptions); + // case 1: exception type declared in IDL at the function call + try + client.testException('Xception'); + Expect( FALSE, 'testException(''Xception''): must trow an exception'); + except + on e:TXception do begin + Expect( e.ErrorCode = 1001, 'error code'); + Expect( e.Message_ = 'Xception', 'error message'); + Console.WriteLine( ' = ' + IntToStr(e.ErrorCode) + ', ' + e.Message_ ); + end; + on e:TTransportException do Expect( FALSE, 'Unexpected : "'+e.ToString+'"'); + on e:Exception do Expect( FALSE, 'Unexpected exception "'+e.ClassName+'": '+e.Message); + end; + + // case 2: exception type NOT declared in IDL at the function call + // this will close the connection + try + client.testException('TException'); + Expect( FALSE, 'testException(''TException''): must trow an exception'); + except + on e:TTransportException do begin + Console.WriteLine( e.ClassName+' = '+e.Message); // this is what we get + end; + on e:TApplicationException do begin + Console.WriteLine( e.ClassName+' = '+e.Message); // this is what we get + end; + on e:TException do Expect( FALSE, 'Unexpected exception "'+e.ClassName+'": '+e.Message); + on e:Exception do Expect( FALSE, 'Unexpected exception "'+e.ClassName+'": '+e.Message); + end; + + + if FTransport.IsOpen then FTransport.Close; + FTransport.Open; // re-open connection, server has already closed + + + // case 3: no exception + try + client.testException('something'); + Expect( TRUE, 'testException(''something''): must not trow an exception'); + except + on e:TTransportException do Expect( FALSE, 'Unexpected : "'+e.ToString+'"'); + on e:Exception do Expect( FALSE, 'Unexpected exception "'+e.ClassName+'": '+e.Message); + end; + {$ENDIF Exceptions} + + + // simple things + StartTestGroup( 'simple Thrift calls', test_BaseTypes); + client.testVoid(); + Expect( TRUE, 'testVoid()'); // success := no exception + + s := BoolToString( client.testBool(TRUE)); + Expect( s = BoolToString(TRUE), 'testBool(TRUE) = '+s); + s := BoolToString( client.testBool(FALSE)); + Expect( s = BoolToString(FALSE), 'testBool(FALSE) = '+s); + + s := client.testString('Test'); + Expect( s = 'Test', 'testString(''Test'') = "'+s+'"'); + + s := client.testString(''); // empty string + Expect( s = '', 'testString('''') = "'+s+'"'); + + s := client.testString(HUGE_TEST_STRING); + Expect( length(s) = length(HUGE_TEST_STRING), + 'testString( length(HUGE_TEST_STRING) = '+IntToStr(Length(HUGE_TEST_STRING))+') ' + +'=> length(result) = '+IntToStr(Length(s))); + + i8 := client.testByte(1); + Expect( i8 = 1, 'testByte(1) = ' + IntToStr( i8 )); + + i32 := client.testI32(-1); + Expect( i32 = -1, 'testI32(-1) = ' + IntToStr(i32)); + + Console.WriteLine('testI64(-34359738368)'); + i64 := client.testI64(-34359738368); + Expect( i64 = -34359738368, 'testI64(-34359738368) = ' + IntToStr( i64)); + + // random binary small + for testsize := Low(TTestSize) to High(TTestSize) do begin + binOut := PrepareBinaryData( TRUE, testsize); + Console.WriteLine('testBinary('+IntToStr(Length(binOut))+' bytes)'); + try + binIn := client.testBinary(binOut); + Expect( Length(binOut) = Length(binIn), 'testBinary('+IntToStr(Length(binOut))+' bytes): '+IntToStr(Length(binIn))+' bytes received'); + i32 := Min( Length(binOut), Length(binIn)); + Expect( CompareMem( binOut, binIn, i32), 'testBinary('+IntToStr(Length(binOut))+' bytes): validating received data'); + except + on e:TApplicationException do Console.WriteLine('testBinary(): '+e.Message); + on e:Exception do Expect( FALSE, 'testBinary(): Unexpected exception "'+e.ClassName+'": '+e.Message); + end; + end; + + Console.WriteLine('testDouble(5.325098235)'); + dub := client.testDouble(5.325098235); + Expect( abs(dub-5.325098235) < 1e-14, 'testDouble(5.325098235) = ' + FloatToStr( dub)); + + // structs + StartTestGroup( 'testStruct', test_Structs); + Console.WriteLine('testStruct({''Zero'', 1, -3, -5})'); + o := TXtructImpl.Create; + o.String_thing := 'Zero'; + o.Byte_thing := 1; + o.I32_thing := -3; + o.I64_thing := -5; + i := client.testStruct(o); + Expect( i.String_thing = 'Zero', 'i.String_thing = "'+i.String_thing+'"'); + Expect( i.Byte_thing = 1, 'i.Byte_thing = '+IntToStr(i.Byte_thing)); + Expect( i.I32_thing = -3, 'i.I32_thing = '+IntToStr(i.I32_thing)); + Expect( i.I64_thing = -5, 'i.I64_thing = '+IntToStr(i.I64_thing)); + Expect( i.__isset_String_thing, 'i.__isset_String_thing = '+BoolToString(i.__isset_String_thing)); + Expect( i.__isset_Byte_thing, 'i.__isset_Byte_thing = '+BoolToString(i.__isset_Byte_thing)); + Expect( i.__isset_I32_thing, 'i.__isset_I32_thing = '+BoolToString(i.__isset_I32_thing)); + Expect( i.__isset_I64_thing, 'i.__isset_I64_thing = '+BoolToString(i.__isset_I64_thing)); + + // nested structs + StartTestGroup( 'testNest', test_Structs); + Console.WriteLine('testNest({1, {''Zero'', 1, -3, -5}, 5})'); + o2 := TXtruct2Impl.Create; + o2.Byte_thing := 1; + o2.Struct_thing := o; + o2.I32_thing := 5; + i2 := client.testNest(o2); + i := i2.Struct_thing; + Expect( i.String_thing = 'Zero', 'i.String_thing = "'+i.String_thing+'"'); + Expect( i.Byte_thing = 1, 'i.Byte_thing = '+IntToStr(i.Byte_thing)); + Expect( i.I32_thing = -3, 'i.I32_thing = '+IntToStr(i.I32_thing)); + Expect( i.I64_thing = -5, 'i.I64_thing = '+IntToStr(i.I64_thing)); + Expect( i2.Byte_thing = 1, 'i2.Byte_thing = '+IntToStr(i2.Byte_thing)); + Expect( i2.I32_thing = 5, 'i2.I32_thing = '+IntToStr(i2.I32_thing)); + Expect( i.__isset_String_thing, 'i.__isset_String_thing = '+BoolToString(i.__isset_String_thing)); + Expect( i.__isset_Byte_thing, 'i.__isset_Byte_thing = '+BoolToString(i.__isset_Byte_thing)); + Expect( i.__isset_I32_thing, 'i.__isset_I32_thing = '+BoolToString(i.__isset_I32_thing)); + Expect( i.__isset_I64_thing, 'i.__isset_I64_thing = '+BoolToString(i.__isset_I64_thing)); + Expect( i2.__isset_Byte_thing, 'i2.__isset_Byte_thing'); + Expect( i2.__isset_I32_thing, 'i2.__isset_I32_thing'); + + // map<type1,type2>: A map of strictly unique keys to values. + // Translates to an STL map, Java HashMap, PHP associative array, Python/Ruby dictionary, etc. + StartTestGroup( 'testMap', test_Containers); + mapout := TThriftDictionaryImpl<Integer,Integer>.Create; + for j := 0 to 4 do + begin + mapout.AddOrSetValue( j, j - 10); + end; + Console.Write('testMap({'); + first := True; + for key in mapout.Keys do + begin + if first + then first := False + else Console.Write( ', ' ); + Console.Write( IntToStr( key) + ' => ' + IntToStr( mapout[key])); + end; + Console.WriteLine('})'); + + mapin := client.testMap( mapout ); + Expect( mapin.Count = mapout.Count, 'testMap: mapin.Count = mapout.Count'); + for j := 0 to 4 do + begin + Expect( mapout.ContainsKey(j), 'testMap: mapout.ContainsKey('+IntToStr(j)+') = '+BoolToString(mapout.ContainsKey(j))); + end; + for key in mapin.Keys do + begin + Expect( mapin[key] = mapout[key], 'testMap: '+IntToStr(key) + ' => ' + IntToStr( mapin[key])); + Expect( mapin[key] = key - 10, 'testMap: mapin['+IntToStr(key)+'] = '+IntToStr( mapin[key])); + end; + + + // map<type1,type2>: A map of strictly unique keys to values. + // Translates to an STL map, Java HashMap, PHP associative array, Python/Ruby dictionary, etc. + StartTestGroup( 'testStringMap', test_Containers); + strmapout := TThriftDictionaryImpl<string,string>.Create; + for j := 0 to 4 do + begin + strmapout.AddOrSetValue( IntToStr(j), IntToStr(j - 10)); + end; + Console.Write('testStringMap({'); + first := True; + for strkey in strmapout.Keys do + begin + if first + then first := False + else Console.Write( ', ' ); + Console.Write( strkey + ' => ' + strmapout[strkey]); + end; + Console.WriteLine('})'); + + strmapin := client.testStringMap( strmapout ); + Expect( strmapin.Count = strmapout.Count, 'testStringMap: strmapin.Count = strmapout.Count'); + for j := 0 to 4 do + begin + Expect( strmapout.ContainsKey(IntToStr(j)), + 'testStringMap: strmapout.ContainsKey('+IntToStr(j)+') = ' + + BoolToString(strmapout.ContainsKey(IntToStr(j)))); + end; + for strkey in strmapin.Keys do + begin + Expect( strmapin[strkey] = strmapout[strkey], 'testStringMap: '+strkey + ' => ' + strmapin[strkey]); + Expect( strmapin[strkey] = IntToStr( StrToInt(strkey) - 10), 'testStringMap: strmapin['+strkey+'] = '+strmapin[strkey]); + end; + + + // set<type>: An unordered set of unique elements. + // Translates to an STL set, Java HashSet, set in Python, etc. + // Note: PHP does not support sets, so it is treated similar to a List + StartTestGroup( 'testSet', test_Containers); + setout := THashSetImpl<Integer>.Create; + for j := -2 to 2 do + begin + setout.Add( j ); + end; + Console.Write('testSet({'); + first := True; + for j in setout do + begin + if first + then first := False + else Console.Write(', '); + Console.Write(IntToStr( j)); + end; + Console.WriteLine('})'); + + setin := client.testSet(setout); + Expect( setin.Count = setout.Count, 'testSet: setin.Count = setout.Count'); + Expect( setin.Count = 5, 'testSet: setin.Count = '+IntToStr(setin.Count)); + for j := -2 to 2 do // unordered, we can't rely on the order => test for known elements only + begin + Expect( setin.Contains(j), 'testSet: setin.Contains('+IntToStr(j)+') => '+BoolToString(setin.Contains(j))); + end; + + // list<type>: An ordered list of elements. + // Translates to an STL vector, Java ArrayList, native arrays in scripting languages, etc. + StartTestGroup( 'testList', test_Containers); + listout := TThriftListImpl<Integer>.Create; + listout.Add( +1); + listout.Add( -2); + listout.Add( +3); + listout.Add( -4); + listout.Add( 0); + Console.Write('testList({'); + first := True; + for j in listout do + begin + if first + then first := False + else Console.Write(', '); + Console.Write(IntToStr( j)); + end; + Console.WriteLine('})'); + + listin := client.testList(listout); + Expect( listin.Count = listout.Count, 'testList: listin.Count = listout.Count'); + Expect( listin.Count = 5, 'testList: listin.Count = '+IntToStr(listin.Count)); + Expect( listin[0] = +1, 'listin[0] = '+IntToStr( listin[0])); + Expect( listin[1] = -2, 'listin[1] = '+IntToStr( listin[1])); + Expect( listin[2] = +3, 'listin[2] = '+IntToStr( listin[2])); + Expect( listin[3] = -4, 'listin[3] = '+IntToStr( listin[3])); + Expect( listin[4] = 0, 'listin[4] = '+IntToStr( listin[4])); + + // enums + ret := client.testEnum(TNumberz.ONE); + Expect( ret = TNumberz.ONE, 'testEnum(ONE) = '+IntToStr(Ord(ret))); + + ret := client.testEnum(TNumberz.TWO); + Expect( ret = TNumberz.TWO, 'testEnum(TWO) = '+IntToStr(Ord(ret))); + + ret := client.testEnum(TNumberz.THREE); + Expect( ret = TNumberz.THREE, 'testEnum(THREE) = '+IntToStr(Ord(ret))); + + ret := client.testEnum(TNumberz.FIVE); + Expect( ret = TNumberz.FIVE, 'testEnum(FIVE) = '+IntToStr(Ord(ret))); + + ret := client.testEnum(TNumberz.EIGHT); + Expect( ret = TNumberz.EIGHT, 'testEnum(EIGHT) = '+IntToStr(Ord(ret))); + + + // typedef + uid := client.testTypedef(309858235082523); + Expect( uid = 309858235082523, 'testTypedef(309858235082523) = '+IntToStr(uid)); + + + // maps of maps + StartTestGroup( 'testMapMap(1)', test_Containers); + mm := client.testMapMap(1); + Console.Write(' = {'); + for key in mm.Keys do + begin + Console.Write( IntToStr( key) + ' => {'); + m2 := mm[key]; + for k2 in m2.Keys do + begin + Console.Write( IntToStr( k2) + ' => ' + IntToStr( m2[k2]) + ', '); + end; + Console.Write('}, '); + end; + Console.WriteLine('}'); + + // verify result data + Expect( mm.Count = 2, 'mm.Count = '+IntToStr(mm.Count)); + pos := mm[4]; + neg := mm[-4]; + for j := 1 to 4 do + begin + Expect( pos[j] = j, 'pos[j] = '+IntToStr(pos[j])); + Expect( neg[-j] = -j, 'neg[-j] = '+IntToStr(neg[-j])); + end; + + + + // insanity + StartTestGroup( 'testInsanity', test_Structs); + insane := TInsanityImpl.Create; + insane.UserMap := TThriftDictionaryImpl<TNumberz, Int64>.Create; + insane.UserMap.AddOrSetValue( TNumberz.FIVE, 5000); + truck := TXtructImpl.Create; + truck.String_thing := 'Truck'; + truck.Byte_thing := -8; // byte is signed + truck.I32_thing := 32; + truck.I64_thing := 64; + insane.Xtructs := TThriftListImpl<IXtruct>.Create; + insane.Xtructs.Add( truck ); + whoa := client.testInsanity( insane ); + Console.Write(' = {'); + for key64 in whoa.Keys do + begin + val := whoa[key64]; + Console.Write( IntToStr( key64) + ' => {'); + for k2_2 in val.Keys do + begin + v2 := val[k2_2]; + Console.Write( IntToStr( Integer( k2_2)) + ' => {'); + userMap := v2.UserMap; + Console.Write('{'); + if userMap <> nil then + begin + for k3 in userMap.Keys do + begin + Console.Write( IntToStr( Integer( k3)) + ' => ' + IntToStr( userMap[k3]) + ', '); + end; + end else + begin + Console.Write('null'); + end; + Console.Write('}, '); + xtructs := v2.Xtructs; + Console.Write('{'); + + if xtructs <> nil then + begin + for x in xtructs do + begin + Console.Write('{"' + x.String_thing + '", ' + + IntToStr( x.Byte_thing) + ', ' + + IntToStr( x.I32_thing) + ', ' + + IntToStr( x.I32_thing) + '}, '); + end; + end else + begin + Console.Write('null'); + end; + Console.Write('}'); + Console.Write('}, '); + end; + Console.Write('}, '); + end; + Console.WriteLine('}'); + + (** + * So you think you've got this all worked, out eh? + * + * Creates a the returned map with these values and prints it out: + * { 1 => { 2 => argument, + * 3 => argument, + * }, + * 2 => { 6 => <empty Insanity struct>, }, + * } + * @return map<UserId, map<Numberz,Insanity>> - a map with the above values + *) + + // verify result data + Expect( whoa.Count = 2, 'whoa.Count = '+IntToStr(whoa.Count)); + // + first_map := whoa[1]; + second_map := whoa[2]; + Expect( first_map.Count = 2, 'first_map.Count = '+IntToStr(first_map.Count)); + Expect( second_map.Count = 1, 'second_map.Count = '+IntToStr(second_map.Count)); + // + looney := second_map[TNumberz.SIX]; + Expect( Assigned(looney), 'Assigned(looney) = '+BoolToString(Assigned(looney))); + Expect( not looney.__isset_UserMap, 'looney.__isset_UserMap = '+BoolToString(looney.__isset_UserMap)); + Expect( not looney.__isset_Xtructs, 'looney.__isset_Xtructs = '+BoolToString(looney.__isset_Xtructs)); + // + for ret in [TNumberz.TWO, TNumberz.THREE] do begin + crazy := first_map[ret]; + Console.WriteLine('first_map['+intToStr(Ord(ret))+']'); + + Expect( crazy.__isset_UserMap, 'crazy.__isset_UserMap = '+BoolToString(crazy.__isset_UserMap)); + Expect( crazy.__isset_Xtructs, 'crazy.__isset_Xtructs = '+BoolToString(crazy.__isset_Xtructs)); + + Expect( crazy.UserMap.Count = insane.UserMap.Count, 'crazy.UserMap.Count = '+IntToStr(crazy.UserMap.Count)); + for pair in insane.UserMap do begin + Expect( crazy.UserMap[pair.Key] = pair.Value, 'crazy.UserMap['+IntToStr(Ord(pair.key))+'] = '+IntToStr(crazy.UserMap[pair.Key])); + end; + + Expect( crazy.Xtructs.Count = insane.Xtructs.Count, 'crazy.Xtructs.Count = '+IntToStr(crazy.Xtructs.Count)); + for arg0 := 0 to insane.Xtructs.Count-1 do begin + hello := insane.Xtructs[arg0]; + goodbye := crazy.Xtructs[arg0]; + Expect( goodbye.String_thing = hello.String_thing, 'goodbye.String_thing = '+goodbye.String_thing); + Expect( goodbye.Byte_thing = hello.Byte_thing, 'goodbye.Byte_thing = '+IntToStr(goodbye.Byte_thing)); + Expect( goodbye.I32_thing = hello.I32_thing, 'goodbye.I32_thing = '+IntToStr(goodbye.I32_thing)); + Expect( goodbye.I64_thing = hello.I64_thing, 'goodbye.I64_thing = '+IntToStr(goodbye.I64_thing)); + end; + end; + + + // multi args + StartTestGroup( 'testMulti', test_BaseTypes); + arg0 := 1; + arg1 := 2; + arg2 := High(Int64); + arg3 := TThriftDictionaryImpl<SmallInt, string>.Create; + arg3.AddOrSetValue( 1, 'one'); + arg4 := TNumberz.FIVE; + arg5 := 5000000; + Console.WriteLine('Test Multi(' + IntToStr( arg0) + ',' + + IntToStr( arg1) + ',' + IntToStr( arg2) + ',' + + arg3.ToString + ',' + IntToStr( Integer( arg4)) + ',' + + IntToStr( arg5) + ')'); + + i := client.testMulti( arg0, arg1, arg2, arg3, arg4, arg5); + Expect( i.String_thing = 'Hello2', 'testMulti: i.String_thing = "'+i.String_thing+'"'); + Expect( i.Byte_thing = arg0, 'testMulti: i.Byte_thing = '+IntToStr(i.Byte_thing)); + Expect( i.I32_thing = arg1, 'testMulti: i.I32_thing = '+IntToStr(i.I32_thing)); + Expect( i.I64_thing = arg2, 'testMulti: i.I64_thing = '+IntToStr(i.I64_thing)); + Expect( i.__isset_String_thing, 'testMulti: i.__isset_String_thing = '+BoolToString(i.__isset_String_thing)); + Expect( i.__isset_Byte_thing, 'testMulti: i.__isset_Byte_thing = '+BoolToString(i.__isset_Byte_thing)); + Expect( i.__isset_I32_thing, 'testMulti: i.__isset_I32_thing = '+BoolToString(i.__isset_I32_thing)); + Expect( i.__isset_I64_thing, 'testMulti: i.__isset_I64_thing = '+BoolToString(i.__isset_I64_thing)); + + // multi exception + StartTestGroup( 'testMultiException(1)', test_Exceptions); + try + i := client.testMultiException( 'need more pizza', 'run out of beer'); + Expect( i.String_thing = 'run out of beer', 'i.String_thing = "' +i.String_thing+ '"'); + Expect( i.__isset_String_thing, 'i.__isset_String_thing = '+BoolToString(i.__isset_String_thing)); + { this is not necessarily true, these fields are default-serialized + Expect( not i.__isset_Byte_thing, 'i.__isset_Byte_thing = '+BoolToString(i.__isset_Byte_thing)); + Expect( not i.__isset_I32_thing, 'i.__isset_I32_thing = '+BoolToString(i.__isset_I32_thing)); + Expect( not i.__isset_I64_thing, 'i.__isset_I64_thing = '+BoolToString(i.__isset_I64_thing)); + } + except + on e:Exception do Expect( FALSE, 'Unexpected exception "'+e.ClassName+'": '+e.Message); + end; + + StartTestGroup( 'testMultiException(Xception)', test_Exceptions); + try + i := client.testMultiException( 'Xception', 'second test'); + Expect( FALSE, 'testMultiException(''Xception''): must trow an exception'); + except + on x:TXception do begin + Expect( x.__isset_ErrorCode, 'x.__isset_ErrorCode = '+BoolToString(x.__isset_ErrorCode)); + Expect( x.__isset_Message_, 'x.__isset_Message_ = '+BoolToString(x.__isset_Message_)); + Expect( x.ErrorCode = 1001, 'x.ErrorCode = '+IntToStr(x.ErrorCode)); + Expect( x.Message_ = 'This is an Xception', 'x.Message = "'+x.Message_+'"'); + end; + on e:Exception do Expect( FALSE, 'Unexpected exception "'+e.ClassName+'": '+e.Message); + end; + + StartTestGroup( 'testMultiException(Xception2)', test_Exceptions); + try + i := client.testMultiException( 'Xception2', 'third test'); + Expect( FALSE, 'testMultiException(''Xception2''): must trow an exception'); + except + on x:TXception2 do begin + Expect( x.__isset_ErrorCode, 'x.__isset_ErrorCode = '+BoolToString(x.__isset_ErrorCode)); + Expect( x.__isset_Struct_thing, 'x.__isset_Struct_thing = '+BoolToString(x.__isset_Struct_thing)); + Expect( x.ErrorCode = 2002, 'x.ErrorCode = '+IntToStr(x.ErrorCode)); + Expect( x.Struct_thing.String_thing = 'This is an Xception2', 'x.Struct_thing.String_thing = "'+x.Struct_thing.String_thing+'"'); + Expect( x.Struct_thing.__isset_String_thing, 'x.Struct_thing.__isset_String_thing = '+BoolToString(x.Struct_thing.__isset_String_thing)); + { this is not necessarily true, these fields are default-serialized + Expect( not x.Struct_thing.__isset_Byte_thing, 'x.Struct_thing.__isset_Byte_thing = '+BoolToString(x.Struct_thing.__isset_Byte_thing)); + Expect( not x.Struct_thing.__isset_I32_thing, 'x.Struct_thing.__isset_I32_thing = '+BoolToString(x.Struct_thing.__isset_I32_thing)); + Expect( not x.Struct_thing.__isset_I64_thing, 'x.Struct_thing.__isset_I64_thing = '+BoolToString(x.Struct_thing.__isset_I64_thing)); + } + end; + on e:Exception do Expect( FALSE, 'Unexpected exception "'+e.ClassName+'": '+e.Message); + end; + + + // oneway functions + StartTestGroup( 'Test Oneway(1)', test_Unknown); + client.testOneway(1); + Expect( TRUE, 'Test Oneway(1)'); // success := no exception + + // call time + {$IFDEF PerfTest} + StartTestGroup( 'Test Calltime()'); + StartTick := GetTickCount; + for k := 0 to 1000 - 1 do + begin + client.testVoid(); + end; + Console.WriteLine(' = ' + FloatToStr( (GetTickCount - StartTick) / 1000 ) + ' ms a testVoid() call' ); + {$ENDIF PerfTest} + + // no more tests here + StartTestGroup( '', test_Unknown); +end; + + +{$IFDEF SupportsAsync} +procedure TClientThread.ClientAsyncTest; +var + client : TThriftTest.IAsync; + s : string; + i8 : ShortInt; +begin + StartTestGroup( 'Async Tests', test_Unknown); + client := TThriftTest.TClient.Create( FProtocol); + FTransport.Open; + + // oneway void functions + client.testOnewayAsync(1).Wait; + Expect( TRUE, 'Test Oneway(1)'); // success := no exception + + // normal functions + s := client.testStringAsync(HUGE_TEST_STRING).Value; + Expect( length(s) = length(HUGE_TEST_STRING), + 'testString( length(HUGE_TEST_STRING) = '+IntToStr(Length(HUGE_TEST_STRING))+') ' + +'=> length(result) = '+IntToStr(Length(s))); + + i8 := client.testByte(1).Value; + Expect( i8 = 1, 'testByte(1) = ' + IntToStr( i8 )); +end; +{$ENDIF} + + +{$IFDEF StressTest} +procedure TClientThread.StressTest(const client : TThriftTest.Iface); +begin + while TRUE do begin + try + if not FTransport.IsOpen then FTransport.Open; // re-open connection, server has already closed + try + client.testString('Test'); + Write('.'); + finally + if FTransport.IsOpen then FTransport.Close; + end; + except + on e:Exception do Writeln(#10+e.message); + end; + end; +end; +{$ENDIF} + + +function TClientThread.PrepareBinaryData( aRandomDist : Boolean; aSize : TTestSize) : TBytes; +var i : Integer; +begin + case aSize of + Empty : SetLength( result, 0); + Normal : SetLength( result, $100); + ByteArrayTest : SetLength( result, SizeOf(TByteArray) + 128); + PipeWriteLimit : SetLength( result, 65535 + 128); + TwentyMB : SetLength( result, 20 * 1024 * 1024); + else + raise EArgumentException.Create('aSize'); + end; + + ASSERT( Low(result) = 0); + if Length(result) = 0 then Exit; + + // linear distribution, unless random is requested + if not aRandomDist then begin + for i := Low(result) to High(result) do begin + result[i] := i mod $100; + end; + Exit; + end; + + // random distribution of all 256 values + FillChar( result[0], Length(result) * SizeOf(result[0]), $0); + for i := Low(result) to High(result) do begin + result[i] := Byte( Random($100)); + end; +end; + + +{$IFDEF Win64} +procedure TClientThread.UseInterlockedExchangeAdd64; +var a,b : Int64; +begin + a := 1; + b := 2; + Thrift.Utils.InterlockedExchangeAdd64( a,b); + Expect( a = 3, 'InterlockedExchangeAdd64'); +end; +{$ENDIF} + + +procedure TClientThread.JSONProtocolReadWriteTest; +// Tests only then read/write procedures of the JSON protocol +// All tests succeed, if we can read what we wrote before +// Note that passing this test does not imply, that our JSON is really compatible to what +// other clients or servers expect as the real JSON. This is beyond the scope of this test. +var prot : IProtocol; + stm : TStringStream; + list : TThriftList; + binary, binRead, emptyBinary : TBytes; + i,iErr : Integer; +const + TEST_SHORT = ShortInt( $FE); + TEST_SMALL = SmallInt( $FEDC); + TEST_LONG = LongInt( $FEDCBA98); + TEST_I64 = Int64( $FEDCBA9876543210); + TEST_DOUBLE = -1.234e-56; + DELTA_DOUBLE = TEST_DOUBLE * 1e-14; + TEST_STRING = 'abc-'#$00E4#$00f6#$00fc; // german umlauts (en-us: "funny chars") + // Test THRIFT-2336 and THRIFT-3404 with U+1D11E (G Clef symbol) and 'Русское Название'; + G_CLEF_AND_CYRILLIC_TEXT = #$1d11e' '#$0420#$0443#$0441#$0441#$043a#$043e#$0435' '#$041d#$0430#$0437#$0432#$0430#$043d#$0438#$0435; + G_CLEF_AND_CYRILLIC_JSON = '"\ud834\udd1e \u0420\u0443\u0441\u0441\u043a\u043e\u0435 \u041d\u0430\u0437\u0432\u0430\u043d\u0438\u0435"'; + // test both possible solidus encodings + SOLIDUS_JSON_DATA = '"one/two\/three"'; + SOLIDUS_EXCPECTED = 'one/two/three'; +begin + stm := TStringStream.Create; + try + StartTestGroup( 'JsonProtocolTest', test_Unknown); + + // prepare binary data + binary := PrepareBinaryData( FALSE, Normal); + SetLength( emptyBinary, 0); // empty binary data block + + // output setup + prot := TJSONProtocolImpl.Create( + TStreamTransportImpl.Create( + nil, TThriftStreamAdapterDelphi.Create( stm, FALSE))); + + // write + Init( list, TType.String_, 9); + prot.WriteListBegin( list); + prot.WriteBool( TRUE); + prot.WriteBool( FALSE); + prot.WriteByte( TEST_SHORT); + prot.WriteI16( TEST_SMALL); + prot.WriteI32( TEST_LONG); + prot.WriteI64( TEST_I64); + prot.WriteDouble( TEST_DOUBLE); + prot.WriteString( TEST_STRING); + prot.WriteBinary( binary); + prot.WriteString( ''); // empty string + prot.WriteBinary( emptyBinary); // empty binary data block + prot.WriteListEnd; + + // input setup + Expect( stm.Position = stm.Size, 'Stream position/length after write'); + stm.Position := 0; + prot := TJSONProtocolImpl.Create( + TStreamTransportImpl.Create( + TThriftStreamAdapterDelphi.Create( stm, FALSE), nil)); + + // read and compare + list := prot.ReadListBegin; + Expect( list.ElementType = TType.String_, 'list element type'); + Expect( list.Count = 9, 'list element count'); + Expect( prot.ReadBool, 'WriteBool/ReadBool: TRUE'); + Expect( not prot.ReadBool, 'WriteBool/ReadBool: FALSE'); + Expect( prot.ReadByte = TEST_SHORT, 'WriteByte/ReadByte'); + Expect( prot.ReadI16 = TEST_SMALL, 'WriteI16/ReadI16'); + Expect( prot.ReadI32 = TEST_LONG, 'WriteI32/ReadI32'); + Expect( prot.ReadI64 = TEST_I64, 'WriteI64/ReadI64'); + Expect( abs(prot.ReadDouble-TEST_DOUBLE) < abs(DELTA_DOUBLE), 'WriteDouble/ReadDouble'); + Expect( prot.ReadString = TEST_STRING, 'WriteString/ReadString'); + binRead := prot.ReadBinary; + Expect( Length(prot.ReadString) = 0, 'WriteString/ReadString (empty string)'); + Expect( Length(prot.ReadBinary) = 0, 'empty WriteBinary/ReadBinary (empty data block)'); + prot.ReadListEnd; + + // test binary data + Expect( Length(binary) = Length(binRead), 'Binary data length check'); + iErr := -1; + for i := Low(binary) to High(binary) do begin + if binary[i] <> binRead[i] then begin + iErr := i; + Break; + end; + end; + if iErr < 0 + then Expect( TRUE, 'Binary data check ('+IntToStr(Length(binary))+' Bytes)') + else Expect( FALSE, 'Binary data check at offset '+IntToStr(iErr)); + + Expect( stm.Position = stm.Size, 'Stream position after read'); + + + // Solidus can be encoded in two ways. Make sure we can read both + stm.Position := 0; + stm.Size := 0; + stm.WriteString(SOLIDUS_JSON_DATA); + stm.Position := 0; + prot := TJSONProtocolImpl.Create( + TStreamTransportImpl.Create( + TThriftStreamAdapterDelphi.Create( stm, FALSE), nil)); + Expect( prot.ReadString = SOLIDUS_EXCPECTED, 'Solidus encoding'); + + + // Widechars should work too. Do they? + // After writing, we ensure that we are able to read it back + // We can't assume hex-encoding, since (nearly) any Unicode char is valid JSON + stm.Position := 0; + stm.Size := 0; + prot := TJSONProtocolImpl.Create( + TStreamTransportImpl.Create( + nil, TThriftStreamAdapterDelphi.Create( stm, FALSE))); + prot.WriteString( G_CLEF_AND_CYRILLIC_TEXT); + stm.Position := 0; + prot := TJSONProtocolImpl.Create( + TStreamTransportImpl.Create( + TThriftStreamAdapterDelphi.Create( stm, FALSE), nil)); + Expect( prot.ReadString = G_CLEF_AND_CYRILLIC_TEXT, 'Writing JSON with chars > 8 bit'); + + // Widechars should work with hex-encoding too. Do they? + stm.Position := 0; + stm.Size := 0; + stm.WriteString( G_CLEF_AND_CYRILLIC_JSON); + stm.Position := 0; + prot := TJSONProtocolImpl.Create( + TStreamTransportImpl.Create( + TThriftStreamAdapterDelphi.Create( stm, FALSE), nil)); + Expect( prot.ReadString = G_CLEF_AND_CYRILLIC_TEXT, 'Reading JSON with chars > 8 bit'); + + + finally + stm.Free; + prot := nil; //-> Release + StartTestGroup( '', test_Unknown); // no more tests here + end; +end; + + +procedure TClientThread.StartTestGroup( const aGroup : string; const aTest : TTestGroup); +begin + FTestGroup := aGroup; + FCurrentTest := aTest; + + Include( FExecuted, aTest); + + if FTestGroup <> '' then begin + Console.WriteLine(''); + Console.WriteLine( aGroup+' tests'); + Console.WriteLine( StringOfChar('-',60)); + end; +end; + + +procedure TClientThread.Expect( aTestResult : Boolean; const aTestInfo : string); +begin + if aTestResult then begin + Inc(FSuccesses); + Console.WriteLine( aTestInfo+': passed'); + end + else begin + FErrors.Add( FTestGroup+': '+aTestInfo); + Include( FFailed, FCurrentTest); + Console.WriteLine( aTestInfo+': *** FAILED ***'); + + // We have a failed test! + // -> issue DebugBreak ONLY if a debugger is attached, + // -> unhandled DebugBreaks would cause Windows to terminate the app otherwise + if IsDebuggerPresent + then {$IFDEF CPUX64} DebugBreak {$ELSE} asm int 3 end {$ENDIF}; + end; +end; + + +procedure TClientThread.ReportResults; +var nTotal : Integer; + sLine : string; +begin + // prevent us from stupid DIV/0 errors + nTotal := FSuccesses + FErrors.Count; + if nTotal = 0 then begin + Console.WriteLine('No results logged'); + Exit; + end; + + Console.WriteLine(''); + Console.WriteLine( StringOfChar('=',60)); + Console.WriteLine( IntToStr(nTotal)+' tests performed'); + Console.WriteLine( IntToStr(FSuccesses)+' tests succeeded ('+IntToStr(round(100*FSuccesses/nTotal))+'%)'); + Console.WriteLine( IntToStr(FErrors.Count)+' tests failed ('+IntToStr(round(100*FErrors.Count/nTotal))+'%)'); + Console.WriteLine( StringOfChar('=',60)); + if FErrors.Count > 0 then begin + Console.WriteLine('FAILED TESTS:'); + for sLine in FErrors do Console.WriteLine('- '+sLine); + Console.WriteLine( StringOfChar('=',60)); + InterlockedIncrement( ExitCode); // return <> 0 on errors + end; + Console.WriteLine(''); +end; + + +function TClientThread.CalculateExitCode : Byte; +var test : TTestGroup; +begin + result := EXITCODE_SUCCESS; + for test := Low(TTestGroup) to High(TTestGroup) do begin + if (test in FFailed) or not (test in FExecuted) + then result := result or MAP_FAILURES_TO_EXITCODE_BITS[test]; + end; +end; + + +constructor TClientThread.Create( const aSetup : TTestSetup; const aNumIteration: Integer); +begin + FSetup := aSetup; + FNumIteration := ANumIteration; + + FConsole := TThreadConsole.Create( Self ); + FCurrentTest := test_Unknown; + + // error list: keep correct order, allow for duplicates + FErrors := TStringList.Create; + FErrors.Sorted := FALSE; + FErrors.Duplicates := dupAccept; + + inherited Create( TRUE); +end; + +destructor TClientThread.Destroy; +begin + FreeAndNil( FConsole); + FreeAndNil( FErrors); + inherited; +end; + +procedure TClientThread.Execute; +var + i : Integer; +begin + // perform all tests + try + {$IFDEF Win64} + UseInterlockedExchangeAdd64; + {$ENDIF} + JSONProtocolReadWriteTest; + + // must be run in the context of the thread + InitializeProtocolTransportStack; + try + for i := 0 to FNumIteration - 1 do begin + ClientTest; + {$IFDEF SupportsAsync} + ClientAsyncTest; + {$ENDIF} + end; + + // report the outcome + ReportResults; + SetReturnValue( CalculateExitCode); + + finally + ShutdownProtocolTransportStack; + end; + + except + on e:Exception do Expect( FALSE, 'unexpected exception: "'+e.message+'"'); + end; +end; + + +function TClientThread.InitializeHttpTransport( const aTimeoutSetting : Integer) : IHTTPClient; +var sUrl : string; + comps : URL_COMPONENTS; + dwChars : DWORD; +begin + ASSERT( FSetup.endpoint in [trns_MsxmlHttp, trns_WinHttp]); + + if FSetup.useSSL + then sUrl := 'https://' + else sUrl := 'http://'; + + sUrl := sUrl + FSetup.host; + + // add the port number if necessary and at the right place + FillChar( comps, SizeOf(comps), 0); + comps.dwStructSize := SizeOf(comps); + comps.dwSchemeLength := MAXINT; + comps.dwHostNameLength := MAXINT; + comps.dwUserNameLength := MAXINT; + comps.dwPasswordLength := MAXINT; + comps.dwUrlPathLength := MAXINT; + comps.dwExtraInfoLength := MAXINT; + Win32Check( WinHttpCrackUrl( PChar(sUrl), Length(sUrl), 0, comps)); + case FSetup.port of + 80 : if FSetup.useSSL then comps.nPort := FSetup.port; + 443 : if not FSetup.useSSL then comps.nPort := FSetup.port; + else + if FSetup.port > 0 then comps.nPort := FSetup.port; + end; + dwChars := Length(sUrl) + 64; + SetLength( sUrl, dwChars); + Win32Check( WinHttpCreateUrl( comps, 0, @sUrl[1], dwChars)); + SetLength( sUrl, dwChars); + + + Console.WriteLine('Target URL: '+sUrl); + case FSetup.endpoint of + trns_MsxmlHttp : result := TMsxmlHTTPClientImpl.Create( sUrl); + trns_WinHttp : result := TWinHTTPClientImpl.Create( sUrl); + else + raise Exception.Create(ENDPOINT_TRANSPORTS[FSetup.endpoint]+' unhandled case'); + end; + + result.DnsResolveTimeout := aTimeoutSetting; + result.ConnectionTimeout := aTimeoutSetting; + result.SendTimeout := aTimeoutSetting; + result.ReadTimeout := aTimeoutSetting; +end; + + +procedure TClientThread.InitializeProtocolTransportStack; +var streamtrans : IStreamTransport; + canSSL : Boolean; +const + DEBUG_TIMEOUT = 30 * 1000; + RELEASE_TIMEOUT = DEFAULT_THRIFT_TIMEOUT; + PIPE_TIMEOUT = RELEASE_TIMEOUT; + HTTP_TIMEOUTS = 10 * 1000; +begin + // needed for HTTP clients as they utilize the MSXML COM components + OleCheck( CoInitialize( nil)); + + canSSL := FALSE; + case FSetup.endpoint of + trns_Sockets: begin + Console.WriteLine('Using sockets ('+FSetup.host+' port '+IntToStr(FSetup.port)+')'); + streamtrans := TSocketImpl.Create( FSetup.host, FSetup.port ); + FTransport := streamtrans; + end; + + trns_MsxmlHttp, + trns_WinHttp: begin + Console.WriteLine('Using HTTPClient'); + FTransport := InitializeHttpTransport( HTTP_TIMEOUTS); + canSSL := TRUE; + end; + + trns_EvHttp: begin + raise Exception.Create(ENDPOINT_TRANSPORTS[FSetup.endpoint]+' transport not implemented'); + end; + + trns_NamedPipes: begin + streamtrans := TNamedPipeTransportClientEndImpl.Create( FSetup.sPipeName, 0, nil, PIPE_TIMEOUT, PIPE_TIMEOUT); + FTransport := streamtrans; + end; + + trns_AnonPipes: begin + streamtrans := TAnonymousPipeTransportImpl.Create( FSetup.hAnonRead, FSetup.hAnonWrite, FALSE); + FTransport := streamtrans; + end; + + else + raise Exception.Create('Unhandled endpoint transport'); + end; + ASSERT( FTransport <> nil); + + // layered transports are not really meant to be stacked upon each other + if (trns_Framed in FSetup.layered) then begin + FTransport := TFramedTransportImpl.Create( FTransport); + end + else if (trns_Buffered in FSetup.layered) and (streamtrans <> nil) then begin + FTransport := TBufferedTransportImpl.Create( streamtrans, 32); // small buffer to test read() + end; + + if FSetup.useSSL and not canSSL then begin + raise Exception.Create('SSL/TLS not implemented'); + end; + + // create protocol instance, default to BinaryProtocol + case FSetup.protType of + prot_Binary : FProtocol := TBinaryProtocolImpl.Create( FTransport, BINARY_STRICT_READ, BINARY_STRICT_WRITE); + prot_JSON : FProtocol := TJSONProtocolImpl.Create( FTransport); + prot_Compact : FProtocol := TCompactProtocolImpl.Create( FTransport); + else + raise Exception.Create('Unhandled protocol'); + end; + + ASSERT( (FTransport <> nil) and (FProtocol <> nil)); +end; + + +procedure TClientThread.ShutdownProtocolTransportStack; +begin + try + FProtocol := nil; + + if FTransport <> nil then begin + FTransport.Close; + FTransport := nil; + end; + + finally + CoUninitialize; + end; +end; + + +{ TThreadConsole } + +constructor TThreadConsole.Create(AThread: TThread); +begin + inherited Create; + FThread := AThread; +end; + +procedure TThreadConsole.Write(const S: string); +var + proc : TThreadProcedure; +begin + proc := procedure + begin + Console.Write( S ); + end; + TThread.Synchronize( FThread, proc); +end; + +procedure TThreadConsole.WriteLine(const S: string); +var + proc : TThreadProcedure; +begin + proc := procedure + begin + Console.WriteLine( S ); + end; + TThread.Synchronize( FThread, proc); +end; + +initialization +begin + TTestClient.FNumIteration := 1; + TTestClient.FNumThread := 1; +end; + +end. diff --git a/src/jaegertracing/thrift/lib/delphi/test/TestConstants.pas b/src/jaegertracing/thrift/lib/delphi/test/TestConstants.pas new file mode 100644 index 000000000..ae3b3e8a3 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/TestConstants.pas @@ -0,0 +1,164 @@ +(* + * 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 + +uses SysUtils; + +type + TKnownProtocol = ( + prot_Binary, // default binary protocol + prot_JSON, // JSON protocol + prot_Compact + ); + + TServerType = ( + srv_Simple, + srv_Nonblocking, + srv_Threadpool, + srv_Threaded + ); + + TEndpointTransport = ( + trns_Sockets, + trns_MsxmlHttp, + trns_WinHttp, + trns_NamedPipes, + trns_AnonPipes, + trns_EvHttp // as listed on http://thrift.apache.org/test + ); + + TLayeredTransport = ( + trns_None, + trns_Buffered, + trns_Framed + ); + + TLayeredTransports = set of TLayeredTransport; + +const + SERVER_TYPES : array[TServerType] of string + = ('Simple', 'Nonblocking', 'Threadpool', 'Threaded'); + + THRIFT_PROTOCOLS : array[TKnownProtocol] of string + = ('Binary', 'JSON', 'Compact'); + + LAYERED_TRANSPORTS : array[TLayeredTransport] of string + = ('None', 'Buffered', 'Framed'); + + ENDPOINT_TRANSPORTS : array[TEndpointTransport] of string + = ('Sockets', 'Http', 'WinHttp', 'Named Pipes','Anon Pipes', 'EvHttp'); + + // defaults are: read=false, write=true + BINARY_STRICT_READ = FALSE; + BINARY_STRICT_WRITE = FALSE; + + HUGE_TEST_STRING = 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. ' + + 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. ' + + 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. ' + + 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. ' + + 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. ' + + 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. ' + + 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. ' + + 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. ' + + 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy ' + + 'eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam ' + + 'voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit ' + + 'amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam ' + + 'nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed ' + + 'diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet ' + + 'clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. '; + + +function BytesToHex( const bytes : TBytes) : string; + + +implementation + + +function BytesToHex( const bytes : TBytes) : string; +var i : Integer; +begin + result := ''; + for i := Low(bytes) to High(bytes) do begin + result := result + IntToHex(bytes[i],2); + end; +end; + + +end. diff --git a/src/jaegertracing/thrift/lib/delphi/test/TestServer.pas b/src/jaegertracing/thrift/lib/delphi/test/TestServer.pas new file mode 100644 index 000000000..2a80d52a7 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/TestServer.pas @@ -0,0 +1,684 @@ +(* + * 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; + +{$I ../src/Thrift.Defines.inc} +{$WARN SYMBOL_PLATFORM OFF} + +{.$DEFINE RunEndless} // activate to interactively stress-test the server stop routines via Ctrl+C + +interface + +uses + Windows, SysUtils, + Generics.Collections, + Thrift.Server, + Thrift.Transport, + Thrift.Transport.Pipes, + Thrift.Protocol, + Thrift.Protocol.JSON, + Thrift.Protocol.Compact, + Thrift.Collections, + Thrift.Utils, + Thrift.Test, + Thrift, + TestConstants, + TestServerEvents, + ConsoleHelper, + Contnrs; + +type + TTestServer = class + public + type + + ITestHandler = interface( TThriftTest.Iface ) + procedure SetServer( const AServer : IServer ); + procedure TestStop; + end; + + TTestHandlerImpl = class( TInterfacedObject, ITestHandler ) + private + FServer : IServer; + protected + procedure testVoid(); + function testBool(thing: Boolean): Boolean; + function testString(const thing: string): string; + function testByte(thing: ShortInt): ShortInt; + function testI32(thing: Integer): Integer; + function testI64(const thing: Int64): Int64; + function testDouble(const thing: Double): Double; + function testBinary(const thing: TBytes): TBytes; + function testStruct(const thing: IXtruct): IXtruct; + function testNest(const thing: IXtruct2): IXtruct2; + function testMap(const thing: IThriftDictionary<Integer, Integer>): IThriftDictionary<Integer, Integer>; + function testStringMap(const thing: IThriftDictionary<string, string>): IThriftDictionary<string, string>; + function testSet(const thing: IHashSet<Integer>): IHashSet<Integer>; + function testList(const thing: IThriftList<Integer>): IThriftList<Integer>; + function testEnum(thing: TNumberz): TNumberz; + function testTypedef(const thing: Int64): Int64; + function testMapMap(hello: Integer): IThriftDictionary<Integer, IThriftDictionary<Integer, Integer>>; + function testInsanity(const argument: IInsanity): IThriftDictionary<Int64, IThriftDictionary<TNumberz, IInsanity>>; + function testMulti(arg0: ShortInt; arg1: Integer; const arg2: Int64; const arg3: IThriftDictionary<SmallInt, string>; arg4: TNumberz; const arg5: Int64): IXtruct; + procedure testException(const arg: string); + function testMultiException(const arg0: string; const arg1: string): IXtruct; + procedure testOneway(secondsToSleep: Integer); + + procedure TestStop; + procedure SetServer( const AServer : IServer ); + end; + + class procedure PrintCmdLineHelp; + class procedure InvalidArgs; + + class procedure LaunchAnonPipeChild( const app : string; const transport : IAnonymousPipeServerTransport); + class procedure Execute( const args: array of string); + end; + +implementation + + +var g_Handler : TTestServer.ITestHandler = nil; + + +function MyConsoleEventHandler( dwCtrlType : DWORD) : BOOL; stdcall; +// Note that this Handler procedure is called from another thread +var handler : TTestServer.ITestHandler; +begin + result := TRUE; + try + case dwCtrlType of + CTRL_C_EVENT : Console.WriteLine( 'Ctrl+C pressed'); + CTRL_BREAK_EVENT : Console.WriteLine( 'Ctrl+Break pressed'); + CTRL_CLOSE_EVENT : Console.WriteLine( 'Received CloseTask signal'); + CTRL_LOGOFF_EVENT : Console.WriteLine( 'Received LogOff signal'); + CTRL_SHUTDOWN_EVENT : Console.WriteLine( 'Received Shutdown signal'); + else + Console.WriteLine( 'Received console event #'+IntToStr(Integer(dwCtrlType))); + end; + + handler := g_Handler; + if handler <> nil then handler.TestStop; + + except + // catch all + end; +end; + + +{ TTestServer.TTestHandlerImpl } + +procedure TTestServer.TTestHandlerImpl.SetServer( const 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( const thing: Double): Double; +begin + Console.WriteLine('testDouble("' + FloatToStr( thing ) + '")'); + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.testBinary(const thing: TBytes): TBytes; +begin + Console.WriteLine('testBinary('+IntToStr(Length(thing)) + ' bytes)'); + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.testEnum(thing: TNumberz): TNumberz; +begin + Console.WriteLine('testEnum(' + EnumUtils<TNumberz>.ToString(Ord(thing)) + ')'); + Result := thing; +end; + +procedure TTestServer.TTestHandlerImpl.testException(const arg: string); +begin + Console.WriteLine('testException(' + arg + ')'); + if ( arg = 'Xception') then + begin + raise TXception.Create( 1001, arg); + end; + + if (arg = 'TException') then + begin + raise TException.Create('TException'); + end; + + // else do not throw anything +end; + +function TTestServer.TTestHandlerImpl.testI32(thing: Integer): Integer; +begin + Console.WriteLine('testI32("' + IntToStr( thing) + '")'); + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.testI64( const thing: Int64): Int64; +begin + Console.WriteLine('testI64("' + IntToStr( thing) + '")'); + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.testInsanity( + const argument: IInsanity): IThriftDictionary<Int64, IThriftDictionary<TNumberz, IInsanity>>; +var + looney : IInsanity; + first_map : IThriftDictionary<TNumberz, IInsanity>; + second_map : IThriftDictionary<TNumberz, IInsanity>; + insane : IThriftDictionary<Int64, IThriftDictionary<TNumberz, IInsanity>>; + +begin + Console.Write('testInsanity('); + if argument <> nil then Console.Write(argument.ToString); + Console.WriteLine(')'); + + + (** + * So you think you've got this all worked, out eh? + * + * Creates a the returned map with these values and prints it out: + * { 1 => { 2 => argument, + * 3 => argument, + * }, + * 2 => { 6 => <empty Insanity struct>, }, + * } + * @return map<UserId, map<Numberz,Insanity>> - a map with the above values + *) + + first_map := TThriftDictionaryImpl<TNumberz, IInsanity>.Create; + second_map := TThriftDictionaryImpl<TNumberz, IInsanity>.Create; + + first_map.AddOrSetValue( TNumberz.TWO, argument); + first_map.AddOrSetValue( TNumberz.THREE, argument); + + looney := TInsanityImpl.Create; + 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( const thing: IThriftList<Integer>): IThriftList<Integer>; +begin + Console.Write('testList('); + if thing <> nil then Console.Write(thing.ToString); + Console.WriteLine(')'); + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.testMap( + const thing: IThriftDictionary<Integer, Integer>): IThriftDictionary<Integer, Integer>; +begin + Console.Write('testMap('); + if thing <> nil then Console.Write(thing.ToString); + 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; + const arg2: Int64; const arg3: IThriftDictionary<SmallInt, string>; + arg4: TNumberz; const 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( const arg0, arg1: string): IXtruct; +var + x2 : TXception2; +begin + Console.WriteLine('testMultiException(' + arg0 + ', ' + arg1 + ')'); + if ( arg0 = 'Xception') then begin + raise TXception.Create( 1001, 'This is an Xception'); // test the new rich CTOR + end; + + if ( arg0 = 'Xception2') then begin + x2 := TXception2.Create; // the old way still works too? + x2.ErrorCode := 2002; + x2.Struct_thing := TXtructImpl.Create; + x2.Struct_thing.String_thing := 'This is an Xception2'; + x2.UpdateMessageProperty; + raise x2; + end; + + Result := TXtructImpl.Create; + Result.String_thing := arg1; +end; + +function TTestServer.TTestHandlerImpl.testNest( const thing: IXtruct2): IXtruct2; +begin + Console.Write('testNest('); + if thing <> nil then Console.Write(thing.ToString); + Console.WriteLine(')'); + + 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( const thing: IHashSet<Integer>):IHashSet<Integer>; +begin + Console.Write('testSet('); + if thing <> nil then Console.Write(thing.ToString); + Console.WriteLine(')');; + + Result := thing; +end; + +procedure TTestServer.TTestHandlerImpl.testStop; +begin + if FServer <> nil then begin + FServer.Stop; + end; +end; + +function TTestServer.TTestHandlerImpl.testBool(thing: Boolean): Boolean; +begin + Console.WriteLine('testBool(' + BoolToStr(thing,true) + ')'); + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.testString( const thing: string): string; +begin + Console.WriteLine('teststring("' + thing + '")'); + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.testStringMap( + const thing: IThriftDictionary<string, string>): IThriftDictionary<string, string>; +begin + Console.Write('testStringMap('); + if thing <> nil then Console.Write(thing.ToString); + Console.WriteLine(')'); + + Result := thing; +end; + +function TTestServer.TTestHandlerImpl.testTypedef( const 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( const thing: IXtruct): IXtruct; +begin + Console.Write('testStruct('); + if thing <> nil then Console.Write(thing.ToString); + Console.WriteLine(')'); + + Result := thing; +end; + + +{ TTestServer } + + +class procedure TTestServer.PrintCmdLineHelp; +const HELPTEXT = ' [options]'#10 + + #10 + + 'Allowed options:'#10 + + ' -h [ --help ] produce help message'#10 + + ' --port arg (=9090) Port number to listen'#10 + + ' --domain-socket arg Unix Domain Socket (e.g. /tmp/ThriftTest.thrift)'#10 + + ' --named-pipe arg Windows Named Pipe (e.g. MyThriftPipe)'#10 + + ' --server-type arg (=simple) type of server, "simple", "thread-pool",'#10 + + ' "threaded", or "nonblocking"'#10 + + ' --transport arg (=socket) transport: buffered, framed, http, anonpipe'#10 + + ' --protocol arg (=binary) protocol: binary, compact, json'#10 + + ' --ssl Encrypted Transport using SSL'#10 + + ' --processor-events processor-events'#10 + + ' -n [ --workers ] arg (=4) Number of thread pools workers. Only valid for'#10 + + ' thread-pool server type'#10 + ; +begin + Console.WriteLine( ChangeFileExt(ExtractFileName(ParamStr(0)),'') + HELPTEXT); +end; + +class procedure TTestServer.InvalidArgs; +begin + Console.WriteLine( 'Invalid args.'); + Console.WriteLine( ChangeFileExt(ExtractFileName(ParamStr(0)),'') + ' -h for more information'); + Abort; +end; + +class procedure TTestServer.LaunchAnonPipeChild( const app : string; const transport : IAnonymousPipeServerTransport); +//Launch child process and pass R/W anonymous pipe handles on cmd line. +//This is a simple example and does not include elevation or other +//advanced features. +var pi : PROCESS_INFORMATION; + si : STARTUPINFO; + sArg, sHandles, sCmdLine : string; + i : Integer; +begin + GetStartupInfo( si); //set startupinfo for the spawned process + + // preformat handles args + sHandles := Format( '%d %d', + [ Integer(transport.ClientAnonRead), + Integer(transport.ClientAnonWrite)]); + + // pass all settings to client + sCmdLine := app; + for i := 1 to ParamCount do begin + sArg := ParamStr(i); + + // add anonymous handles and quote strings where appropriate + if sArg = '-anon' + then sArg := sArg +' '+ sHandles + else begin + if Pos(' ',sArg) > 0 + then sArg := '"'+sArg+'"'; + end;; + + sCmdLine := sCmdLine +' '+ sArg; + end; + + // spawn the child process + Console.WriteLine('Starting client '+sCmdLine); + Win32Check( CreateProcess( nil, PChar(sCmdLine), nil,nil,TRUE,0,nil,nil,si,pi)); + + CloseHandle( pi.hThread); + CloseHandle( pi.hProcess); +end; + + +class procedure TTestServer.Execute( const args: array of string); +var + Port : Integer; + ServerEvents : Boolean; + sPipeName : string; + testHandler : ITestHandler; + testProcessor : IProcessor; + ServerTrans : IServerTransport; + ServerEngine : IServer; + anonymouspipe : IAnonymousPipeServerTransport; + namedpipe : INamedPipeServerTransport; + TransportFactory : ITransportFactory; + ProtocolFactory : IProtocolFactory; + i, numWorker : Integer; + s : string; + protType : TKnownProtocol; + servertype : TServerType; + endpoint : TEndpointTransport; + layered : TLayeredTransports; + UseSSL : Boolean; // include where appropriate (TLayeredTransport?) +begin + try + ServerEvents := FALSE; + protType := prot_Binary; + servertype := srv_Simple; + endpoint := trns_Sockets; + layered := []; + UseSSL := FALSE; + Port := 9090; + sPipeName := ''; + numWorker := 4; + + i := 0; + while ( i < Length(args) ) do begin + s := args[i]; + Inc(i); + + // Allowed options: + if (s = '-h') or (s = '--help') then begin + // -h [ --help ] produce help message + PrintCmdLineHelp; + Exit; + end + else if (s = '--port') then begin + // --port arg (=9090) Port number to listen + s := args[i]; + Inc(i); + Port := StrToIntDef( s, Port); + end + else if (s = '--domain-socket') then begin + // --domain-socket arg Unix Domain Socket (e.g. /tmp/ThriftTest.thrift) + raise Exception.Create('domain-socket not supported'); + end + else if (s = '--named-pipe') then begin + // --named-pipe arg Windows Named Pipe (e.g. MyThriftPipe) + endpoint := trns_NamedPipes; + sPipeName := args[i]; // -pipe <name> + Inc( i ); + end + else if (s = '--server-type') then begin + // --server-type arg (=simple) type of server, + // arg = "simple", "thread-pool", "threaded", or "nonblocking" + s := args[i]; + Inc(i); + + if s = 'simple' then servertype := srv_Simple + else if s = 'thread-pool' then servertype := srv_Threadpool + else if s = 'threaded' then servertype := srv_Threaded + else if s = 'nonblocking' then servertype := srv_Nonblocking + else InvalidArgs; + end + else if (s = '--transport') then begin + // --transport arg (=buffered) transport: buffered, framed, http + s := args[i]; + Inc(i); + + if s = 'buffered' then Include( layered, trns_Buffered) + else if s = 'framed' then Include( layered, trns_Framed) + else if s = 'http' then endpoint := trns_MsxmlHttp + else if s = 'winhttp' then endpoint := trns_WinHttp + else if s = 'anonpipe' then endpoint := trns_AnonPipes + else InvalidArgs; + end + else if (s = '--protocol') then begin + // --protocol arg (=binary) protocol: binary, compact, json + s := args[i]; + Inc(i); + + if s = 'binary' then protType := prot_Binary + else if s = 'compact' then protType := prot_Compact + else if s = 'json' then protType := prot_JSON + else InvalidArgs; + end + else if (s = '--ssl') then begin + // --ssl Encrypted Transport using SSL + UseSSL := TRUE; + end + else if (s = '--processor-events') then begin + // --processor-events processor-events + ServerEvents := TRUE; + end + else if (s = '-n') or (s = '--workers') then begin + // -n [ --workers ] arg (=4) Number of thread pools workers. + // Only valid for thread-pool server type + s := args[i]; + numWorker := StrToIntDef(s,0); + if numWorker > 0 + then Inc(i) + else numWorker := 4; + end + else begin + InvalidArgs; + end; + end; + + + Console.WriteLine('Server configuration: '); + + // create protocol factory, default to BinaryProtocol + case protType of + prot_Binary : ProtocolFactory := TBinaryProtocolImpl.TFactory.Create( BINARY_STRICT_READ, BINARY_STRICT_WRITE); + prot_JSON : ProtocolFactory := TJSONProtocolImpl.TFactory.Create; + prot_Compact : ProtocolFactory := TCompactProtocolImpl.TFactory.Create; + else + raise Exception.Create('Unhandled protocol'); + end; + ASSERT( ProtocolFactory <> nil); + Console.WriteLine('- '+THRIFT_PROTOCOLS[protType]+' protocol'); + + case endpoint of + + trns_Sockets : begin + Console.WriteLine('- sockets (port '+IntToStr(port)+')'); + if (trns_Buffered in layered) then Console.WriteLine('- buffered'); + servertrans := TServerSocketImpl.Create( Port, 0, (trns_Buffered in layered)); + end; + + trns_MsxmlHttp, + trns_WinHttp : begin + raise Exception.Create('HTTP server transport not implemented'); + end; + + trns_NamedPipes : begin + Console.WriteLine('- named pipe ('+sPipeName+')'); + namedpipe := TNamedPipeServerTransportImpl.Create( sPipeName, 4096, PIPE_UNLIMITED_INSTANCES); + servertrans := namedpipe; + end; + + trns_AnonPipes : begin + Console.WriteLine('- anonymous pipes'); + anonymouspipe := TAnonymousPipeServerTransportImpl.Create; + servertrans := anonymouspipe; + end + + else + raise Exception.Create('Unhandled endpoint transport'); + end; + ASSERT( servertrans <> nil); + + if UseSSL then begin + raise Exception.Create('SSL not implemented'); + end; + + if (trns_Framed in layered) then begin + Console.WriteLine('- framed transport'); + TransportFactory := TFramedTransportImpl.TFactory.Create + end + else begin + TransportFactory := TTransportFactoryImpl.Create; + end; + ASSERT( TransportFactory <> nil); + + testHandler := TTestHandlerImpl.Create; + testProcessor := TThriftTest.TProcessorImpl.Create( testHandler ); + + case servertype of + srv_Simple : begin + ServerEngine := TSimpleServer.Create( testProcessor, ServerTrans, TransportFactory, ProtocolFactory); + end; + + srv_Nonblocking : begin + raise Exception.Create(SERVER_TYPES[servertype]+' server not implemented'); + end; + + srv_Threadpool, + srv_Threaded: begin + if numWorker > 1 then {use here}; + raise Exception.Create(SERVER_TYPES[servertype]+' server not implemented'); + end; + + else + raise Exception.Create('Unhandled server type'); + end; + ASSERT( ServerEngine <> nil); + + testHandler.SetServer( ServerEngine); + + // test events? + if ServerEvents then begin + Console.WriteLine('- server events test enabled'); + ServerEngine.ServerEvents := TServerEventsImpl.Create; + end; + + // start the client now when we have the anon handles, but before the server starts + if endpoint = trns_AnonPipes + then LaunchAnonPipeChild( ExtractFilePath(ParamStr(0))+'client.exe', anonymouspipe); + + // install Ctrl+C handler before the server starts + g_Handler := testHandler; + SetConsoleCtrlHandler( @MyConsoleEventHandler, TRUE); + + Console.WriteLine(''); + repeat + Console.WriteLine('Starting the server ...'); + serverEngine.Serve; + until {$IFDEF RunEndless} FALSE {$ELSE} TRUE {$ENDIF}; + + testHandler.SetServer( nil); + g_Handler := nil; + + except + on E: EAbort do raise; + on E: Exception do begin + Console.WriteLine( E.Message + #10 + E.StackTrace ); + end; + end; + Console.WriteLine( 'done.'); +end; + + +end. diff --git a/src/jaegertracing/thrift/lib/delphi/test/TestServerEvents.pas b/src/jaegertracing/thrift/lib/delphi/test/TestServerEvents.pas new file mode 100644 index 000000000..2208cd4ba --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/TestServerEvents.pas @@ -0,0 +1,174 @@ +(* + * 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 TestServerEvents; + +interface + +uses + SysUtils, + Thrift, + Thrift.Protocol, + Thrift.Transport, + Thrift.Server, + ConsoleHelper; + +type + TRequestEventsImpl = class( TInterfacedObject, IRequestEvents) + protected + FStart : TDateTime; + // IRequestProcessingEvents + procedure PreRead; + procedure PostRead; + procedure PreWrite; + procedure PostWrite; + procedure OnewayComplete; + procedure UnhandledError( const e : Exception); + procedure CleanupContext; + public + constructor Create; + end; + + + TProcessorEventsImpl = class( TInterfacedObject, IProcessorEvents) + protected + FReqs : Integer; + // IProcessorEvents + procedure Processing( const transport : ITransport); + function CreateRequestContext( const aFunctionName : string) : IRequestEvents; + procedure CleanupContext; + public + constructor Create; + end; + + + TServerEventsImpl = class( TInterfacedObject, IServerEvents) + protected + // IServerEvents + procedure PreServe; + procedure PreAccept; + function CreateProcessingContext( const input, output : IProtocol) : IProcessorEvents; + end; + + +implementation + +{ TServerEventsImpl } + +procedure TServerEventsImpl.PreServe; +begin + Console.WriteLine('ServerEvents: Server starting to serve requests'); +end; + + +procedure TServerEventsImpl.PreAccept; +begin + Console.WriteLine('ServerEvents: Server transport is ready to accept incoming calls'); +end; + + +function TServerEventsImpl.CreateProcessingContext(const input, output: IProtocol): IProcessorEvents; +begin + result := TProcessorEventsImpl.Create; +end; + + +{ TProcessorEventsImpl } + +constructor TProcessorEventsImpl.Create; +begin + inherited Create; + FReqs := 0; + Console.WriteLine('ProcessorEvents: Client connected, processing begins'); +end; + +procedure TProcessorEventsImpl.Processing(const transport: ITransport); +begin + Console.WriteLine('ProcessorEvents: Processing of incoming request begins'); +end; + + +function TProcessorEventsImpl.CreateRequestContext( const aFunctionName: string): IRequestEvents; +begin + result := TRequestEventsImpl.Create; + Inc( FReqs); +end; + + +procedure TProcessorEventsImpl.CleanupContext; +begin + Console.WriteLine( 'ProcessorEvents: completed after handling '+IntToStr(FReqs)+' requests.'); +end; + + +{ TRequestEventsImpl } + + +constructor TRequestEventsImpl.Create; +begin + inherited Create; + FStart := Now; + Console.WriteLine('RequestEvents: New request'); +end; + + +procedure TRequestEventsImpl.PreRead; +begin + Console.WriteLine('RequestEvents: Reading request message ...'); +end; + + +procedure TRequestEventsImpl.PostRead; +begin + Console.WriteLine('RequestEvents: Reading request message completed'); +end; + +procedure TRequestEventsImpl.PreWrite; +begin + Console.WriteLine('RequestEvents: Writing response message ...'); +end; + + +procedure TRequestEventsImpl.PostWrite; +begin + Console.WriteLine('RequestEvents: Writing response message completed'); +end; + + +procedure TRequestEventsImpl.OnewayComplete; +begin + Console.WriteLine('RequestEvents: Oneway message processed'); +end; + + +procedure TRequestEventsImpl.UnhandledError(const e: Exception); +begin + Console.WriteLine('RequestEvents: Unhandled exception of type '+e.classname); +end; + + +procedure TRequestEventsImpl.CleanupContext; +var millis : Double; +begin + millis := (Now - FStart) * (24*60*60*1000); + Console.WriteLine( 'Request processing completed in '+IntToStr(Round(millis))+' ms'); +end; + + +end. diff --git a/src/jaegertracing/thrift/lib/delphi/test/client.dpr b/src/jaegertracing/thrift/lib/delphi/test/client.dpr new file mode 100644 index 000000000..83727f619 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/client.dpr @@ -0,0 +1,77 @@ +(* + * Licensed to the Apache Software Foundation (ASF) under one + * or more contributor license agreements. See the NOTICE file + * distributed with this work for additional information + * regarding copyright ownership. The ASF licenses this file + * to you under the Apache License, Version 2.0 (the + * "License"); you may not use this file except in compliance + * with the License. You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, + * software distributed under the License is distributed on an + * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY + * KIND, either express or implied. See the License for the + * specific language governing permissions and limitations + * under the License. + *) + + +program client; + +{$APPTYPE CONSOLE} + +uses + SysUtils, + DataFactory in 'Performance\DataFactory.pas', + PerfTests in 'Performance\PerfTests.pas', + TestClient in 'TestClient.pas', + Thrift.Test, // in 'gen-delphi\Thrift.Test.pas', + Thrift in '..\src\Thrift.pas', + Thrift.Transport in '..\src\Thrift.Transport.pas', + Thrift.Socket in '..\src\Thrift.Socket.pas', + Thrift.Exception in '..\src\Thrift.Exception.pas', + Thrift.Transport.Pipes in '..\src\Thrift.Transport.Pipes.pas', + Thrift.Transport.WinHTTP in '..\src\Thrift.Transport.WinHTTP.pas', + Thrift.Transport.MsxmlHTTP in '..\src\Thrift.Transport.MsxmlHTTP.pas', + Thrift.Protocol in '..\src\Thrift.Protocol.pas', + Thrift.Protocol.JSON in '..\src\Thrift.Protocol.JSON.pas', + Thrift.Protocol.Compact in '..\src\Thrift.Protocol.Compact.pas', + Thrift.Protocol.Multiplex in '..\src\Thrift.Protocol.Multiplex.pas', + Thrift.Collections in '..\src\Thrift.Collections.pas', + Thrift.Server in '..\src\Thrift.Server.pas', + Thrift.Stream in '..\src\Thrift.Stream.pas', + Thrift.TypeRegistry in '..\src\Thrift.TypeRegistry.pas', + Thrift.WinHTTP in '..\src\Thrift.WinHTTP.pas', + Thrift.Utils in '..\src\Thrift.Utils.pas'; + +var + nParamCount : Integer; + args : array of string; + i : Integer; + arg : string; + +begin + try + Writeln( 'Delphi TestClient '+Thrift.Version); + nParamCount := ParamCount; + SetLength( args, nParamCount); + for i := 1 to nParamCount do begin + arg := ParamStr( i ); + args[i-1] := arg; + end; + + ExitCode := TTestClient.Execute( args); + + except + on E: EAbort do begin + ExitCode := $FF; + end; + on E: Exception do begin + Writeln(E.ClassName, ': ', E.Message); + ExitCode := $FF; + end; + end; +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/codegen/README.md b/src/jaegertracing/thrift/lib/delphi/test/codegen/README.md new file mode 100644 index 000000000..a0145890f --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/codegen/README.md @@ -0,0 +1,28 @@ +How to use the test case: +---------------------------------------------- +- copy and the template batch file +- open the batch file and adjust configuration as necessary +- run the batch + + +Configuration: +---------------------------------------------- +SVNWORKDIR +should point to the Thrift working copy root + +MY_THRIFT_FILES +can be set to point to a folder with more thrift IDL files. +If you don't have any such files, just leave the setting blank. + +BIN +Local MSYS binary folder. Your THRIFT.EXE is installed here. + +MINGW_BIN +Local MinGW bin folder. Contains DLL files required by THRIFT.EXE + +DCC +Identifies the Delphi Command Line compiler (dcc32.exe) +To be configuired only, if the default is not suitable. + +---------------------------------------------- +*EOF*
\ No newline at end of file diff --git a/src/jaegertracing/thrift/lib/delphi/test/codegen/run-Pascal-Codegen-Tests.bat.tmpl b/src/jaegertracing/thrift/lib/delphi/test/codegen/run-Pascal-Codegen-Tests.bat.tmpl new file mode 100644 index 000000000..dbab0ae7c --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/codegen/run-Pascal-Codegen-Tests.bat.tmpl @@ -0,0 +1,173 @@ +REM /* +REM * Licensed to the Apache Software Foundation (ASF) under one +REM * or more contributor license agreements. See the NOTICE file +REM * distributed with this work for additional information +REM * regarding copyright ownership. The ASF licenses this file +REM * to you under the Apache License, Version 2.0 (the +REM * "License"); you may not use this file except in compliance +REM * with the License. You may obtain a copy of the License at +REM * +REM * http://www.apache.org/licenses/LICENSE-2.0 +REM * +REM * Unless required by applicable law or agreed to in writing, +REM * software distributed under the License is distributed on an +REM * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +REM * KIND, either express or implied. See the License for the +REM * specific language governing permissions and limitations +REM * under the License. +REM */ +@echo off +if ""=="%1" goto CONFIG +goto HANDLEDIR + +REM ----------------------------------------------------- +:CONFIG +REM ----------------------------------------------------- + +rem * CONFIGURATION BEGIN +rem * configuration settings, adjust as necessary to meet your system setup +set SVNWORKDIR= +set MY_THRIFT_FILES= +set BIN=C:\MSys10\local\bin +set MINGW_BIN=C:\MinGW\bin +set DCC= +set SUBDIR=gen-delphi +rem * CONFIGURATION END + + +REM ----------------------------------------------------- +:START +REM ----------------------------------------------------- + +rem * configured? +if "%SVNWORKDIR%"=="" goto CONFIG_ERROR + +rem * try to find dcc32.exe +echo Looking for dcc32.exe ... +if not exist "%DCC%" set DCC=%ProgramFiles%\Embarcadero\RAD Studio\8.0\bin\dcc32.exe +if not exist "%DCC%" set DCC=%ProgramFiles(x86)%\Embarcadero\RAD Studio\8.0\bin\dcc32.exe +if not exist "%DCC%" goto CONFIG_ERROR +echo Found %DCC% +echo. + +rem * some helpers +set PATH=%BIN%;%MINGW_BIN%;%PATH% +set TARGET=%SVNWORKDIR%\..\thrift-testing +set SOURCE=%SVNWORKDIR% +set TESTAPP=TestProject +set UNITSEARCH=%SOURCE%\lib\pas\src;%SOURCE%\lib\delphi\src +set OUTDCU="%TARGET%\dcu" +set LOGFILE=%TARGET%\%SUBDIR%\codegen.log + +rem * create and/or empty target dirs +if not exist "%TARGET%" md "%TARGET%" +if not exist "%TARGET%\%SUBDIR%" md "%TARGET%\%SUBDIR%" +if not exist "%OUTDCU%" md "%OUTDCU%" +if exist "%TARGET%\*.thrift" del "%TARGET%\*.thrift" /Q +if exist "%TARGET%\%SUBDIR%\*.*" del "%TARGET%\%SUBDIR%\*.*" /Q +if exist "%OUTDCU%\*.*" del "%OUTDCU%\*.*" /Q + +rem * recurse through thrift WC and "my thrift files" folder +rem * copies all .thrift files into thrift-testing +call %0 %SOURCE% +if not "%MY_THRIFT_FILES%"=="" call %0 %MY_THRIFT_FILES% + +rem * compile all thrift files, generate PAS and C++ code +echo. +echo Generating code, please wait ... +cd "%TARGET%" +for %%a in (*.thrift) do "%BIN%\thrift.exe" -v --gen delphi:register_types,constprefix,events,xmldoc "%%a" 2>> "%LOGFILE%" +REM * for %%a in (*.thrift) do "%BIN%\thrift.exe" -v --gen cpp "%%a" >> NUL: +cmd /c start notepad "%LOGFILE%" +cd .. + +rem * check for special Delphi testcases being processed +if not exist "%TARGET%\%SUBDIR%\ReservedKeywords.pas" goto TESTCASE_MISSING + + +rem * generate a minimal DPR file that uses all generated pascal units +cd "%TARGET%\%SUBDIR%\" +if exist inherited.* ren inherited.* _inherited.* +echo program %TESTAPP%; > %TESTAPP%.dpr +echo {$APPTYPE CONSOLE} >> %TESTAPP%.dpr +echo. >> %TESTAPP%.dpr +echo uses >> %TESTAPP%.dpr +for %%a in (*.pas) do echo %%~na, >> %TESTAPP%.dpr +echo Windows, Classes, SysUtils; >> %TESTAPP%.dpr +echo. >> %TESTAPP%.dpr +echo begin >> %TESTAPP%.dpr +echo Writeln('Successfully compiled!'); >> %TESTAPP%.dpr +echo Writeln('List of units:'); >> %TESTAPP%.dpr +for %%a in (*.pas) do echo Write('%%~na':30,'':10); >> %TESTAPP%.dpr +echo Writeln; >> %TESTAPP%.dpr +echo end. >> %TESTAPP%.dpr +echo. >> %TESTAPP%.dpr +cd ..\.. + +rem * try to compile the DPR +rem * this should not throw any errors, warnings or hints +"%DCC%" -B "%TARGET%\%SUBDIR%\%TESTAPP%" -U"%UNITSEARCH%" -I"%UNITSEARCH%" -N"%OUTDCU%" -E"%TARGET%\%SUBDIR%" +dir "%TARGET%\%SUBDIR%\%TESTAPP%.exe" +if not exist "%TARGET%\%SUBDIR%\%TESTAPP%.exe" goto CODEGEN_FAILED +echo. +echo ----------------------------------------------------------------- +echo The compiled program is now executed. If it hangs or crashes, we +echo have a serious problem with the generated code. Expected output +echo is "Successfully compiled:" followed by a list of generated units. +echo ----------------------------------------------------------------- +"%TARGET%\%SUBDIR%\%TESTAPP%.exe" +echo ----------------------------------------------------------------- +echo. +pause +GOTO EOF + +REM ----------------------------------------------------- +:DXE_NOT_FOUND +REM ----------------------------------------------------- +echo Delphi Compiler (dcc32.exe) not found. +echo Please check the "DCC" setting in this batch. +echo. +cmd /c start notepad README.MD +cmd /c start notepad %0 +pause +GOTO EOF + + +REM ----------------------------------------------------- +:CONFIG_ERROR +REM ----------------------------------------------------- +echo Missing, incomplete or wrong configuration settings! +cmd /c start notepad README.MD +cmd /c start notepad %0 +pause +GOTO EOF + + +REM ----------------------------------------------------- +:TESTCASE_MISSING +REM ----------------------------------------------------- +echo Missing an expected Delphi testcase! +pause +GOTO EOF + + +REM ----------------------------------------------------- +:CODEGEN_FAILED +REM ----------------------------------------------------- +echo Code generation FAILED! +pause +GOTO EOF + + +REM ----------------------------------------------------- +:HANDLEDIR +REM ----------------------------------------------------- +REM echo %1 +for /D %%a in (%1\*) do call %0 %%a +if exist "%1\*.thrift" copy /b "%1\*.thrift" "%TARGET%\*.*" +GOTO EOF + + +REM ----------------------------------------------------- +:EOF +REM ----------------------------------------------------- diff --git a/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedIncluded.thrift b/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedIncluded.thrift new file mode 100644 index 000000000..8b47a50bc --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedIncluded.thrift @@ -0,0 +1,25 @@ +/* + * 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. + */ + +// make sure generated code does not produce name collisions with predefined keywords +namespace delphi SysUtils + +const i32 integer = 42 + +// EOF diff --git a/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.dpr b/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.dpr new file mode 100644 index 000000000..1fbc8c1d7 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.dpr @@ -0,0 +1,15 @@ +program ReservedKeywords; + +{$APPTYPE CONSOLE} + +uses + SysUtils, System_; + +begin + try + { TODO -oUser -cConsole Main : Code hier einfgen } + except + on E: Exception do + Writeln(E.ClassName, ': ', E.Message); + end; +end. diff --git a/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.dproj b/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.dproj new file mode 100644 index 000000000..6bd9544bc --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.dproj @@ -0,0 +1,112 @@ + <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <PropertyGroup> + <ProjectGuid>{F2E9B6FC-A931-4271-8E30-5A4E402481B4}</ProjectGuid> + <MainSource>ReservedKeywords.dpr</MainSource> + <ProjectVersion>12.3</ProjectVersion> + <Basis>True</Basis> + <Config Condition="'$(Config)'==''">Debug</Config> + <Platform>Win32</Platform> + <AppType>Console</AppType> + <FrameworkType>None</FrameworkType> + <DCC_DCCCompiler>DCC32</DCC_DCCCompiler> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Basis' or '$(Base)'!=''"> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_1)'!=''"> + <Cfg_1>true</Cfg_1> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_2)'!=''"> + <Cfg_2>true</Cfg_2> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Base)'!=''"> + <DCC_ImageBase>00400000</DCC_ImageBase> + <DCC_DcuOutput>.\$(Config)\$(Platform)</DCC_DcuOutput> + <DCC_UnitSearchPath>gen-delphi;..\..\src;$(DCC_UnitSearchPath)</DCC_UnitSearchPath> + <DCC_UnitAlias>WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;$(DCC_UnitAlias)</DCC_UnitAlias> + <DCC_ExeOutput>.\$(Config)\$(Platform)</DCC_ExeOutput> + <DCC_N>false</DCC_N> + <DCC_S>false</DCC_S> + <DCC_K>false</DCC_K> + <DCC_E>false</DCC_E> + <DCC_F>false</DCC_F> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1)'!=''"> + <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> + <DCC_Optimize>false</DCC_Optimize> + <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2)'!=''"> + <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> + <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> + <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> + <DCC_DebugInformation>false</DCC_DebugInformation> + </PropertyGroup> + <ItemGroup> + <DelphiCompile Include="ReservedKeywords.dpr"> + <MainSource>MainSource</MainSource> + </DelphiCompile> + <BuildConfiguration Include="Release"> + <Key>Cfg_2</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + <BuildConfiguration Include="Basis"> + <Key>Base</Key> + </BuildConfiguration> + <BuildConfiguration Include="Debug"> + <Key>Cfg_1</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + </ItemGroup> + <Import Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')" Project="$(BDS)\Bin\CodeGear.Delphi.Targets"/> + <Import Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')" Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj"/> + <PropertyGroup> + <PreBuildEvent><![CDATA[thrift -r -gen delphi ReservedKeywords.thrift]]></PreBuildEvent> + </PropertyGroup> + <ProjectExtensions> + <Borland.Personality>Delphi.Personality.12</Borland.Personality> + <Borland.ProjectType/> + <BorlandProject> + <Delphi.Personality> + <VersionInfo> + <VersionInfo Name="IncludeVerInfo">False</VersionInfo> + <VersionInfo Name="AutoIncBuild">False</VersionInfo> + <VersionInfo Name="MajorVer">1</VersionInfo> + <VersionInfo Name="MinorVer">0</VersionInfo> + <VersionInfo Name="Release">0</VersionInfo> + <VersionInfo Name="Build">0</VersionInfo> + <VersionInfo Name="Debug">False</VersionInfo> + <VersionInfo Name="PreRelease">False</VersionInfo> + <VersionInfo Name="Special">False</VersionInfo> + <VersionInfo Name="Private">False</VersionInfo> + <VersionInfo Name="DLL">False</VersionInfo> + <VersionInfo Name="Locale">1031</VersionInfo> + <VersionInfo Name="CodePage">1252</VersionInfo> + </VersionInfo> + <VersionInfoKeys> + <VersionInfoKeys Name="CompanyName"/> + <VersionInfoKeys Name="FileDescription"/> + <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> + <VersionInfoKeys Name="InternalName"/> + <VersionInfoKeys Name="LegalCopyright"/> + <VersionInfoKeys Name="LegalTrademarks"/> + <VersionInfoKeys Name="OriginalFilename"/> + <VersionInfoKeys Name="ProductName"/> + <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> + <VersionInfoKeys Name="Comments"/> + </VersionInfoKeys> + <Source> + <Source Name="MainSource">ReservedKeywords.dpr</Source> + </Source> + </Delphi.Personality> + <Platforms> + <Platform value="Win32">True</Platform> + </Platforms> + </BorlandProject> + <ProjectFileVersion>12</ProjectFileVersion> + </ProjectExtensions> + </Project> diff --git a/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.thrift b/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.thrift new file mode 100644 index 000000000..2f49d742c --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/keywords/ReservedKeywords.thrift @@ -0,0 +1,138 @@ +/* + * 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. + */ + +// make sure generated code does not produce name collisions with predefined keywords +namespace delphi System + +include "ReservedIncluded.thrift" + + +typedef i32 Cardinal +typedef string message +typedef list< map< Cardinal, message>> program + +struct unit { + 1: Cardinal downto; + 2: program procedure; +} + +typedef set< unit> units + +exception exception1 { + 1: program message; + 2: unit array; +} + +service constructor { + unit Create(1: Cardinal asm; 2: message inherited) throws (1: exception1 label); + units Destroy(); +} + +const Cardinal downto = +1 +const Cardinal published = -1 + +enum keywords { + record = 1, + repeat = 2, + deprecated = 3 +} + + +struct Struct_lists { + 1: list<Struct_simple> init; + 2: list<Struct_simple> struc; + 3: list<Struct_simple> field; + 4: list<Struct_simple> field_; + 5: list<Struct_simple> tracker; + 6: list<Struct_simple> Self; +} + +struct Struct_structs { + 1: Struct_simple init; + 2: Struct_simple struc; + 3: Struct_simple field; + 4: Struct_simple field_; + 5: Struct_simple tracker; + 6: Struct_simple Self; +} + +struct Struct_simple { + 1: bool init; + 2: bool struc; + 3: bool field; + 4: bool field_; + 5: bool tracker; + 6: bool Self; +} + +struct Struct_strings { + 1: string init; + 2: string struc; + 3: string field; + 4: string field_; + 5: string tracker; + 6: string Self; +} + +struct Struct_binary { + 1: binary init; + 2: binary struc; + 3: binary field; + 4: binary field_; + 5: binary tracker; + 6: binary Self; +} + + +typedef i32 IProtocol +typedef i32 ITransport +typedef i32 IFace +typedef i32 IAsync +typedef i32 System +typedef i32 SysUtils +typedef i32 Generics +typedef i32 Thrift + +struct Struct_Thrift_Names { + 1: IProtocol IProtocol + 2: ITransport ITransport + 3: IFace IFace + 4: IAsync IAsync + 5: System System + 6: SysUtils SysUtils + 7: Generics Generics + 8: Thrift Thrift +} + + +enum Thrift4554_Enum { + Foo = 0, + Bar = 1, + Baz = 2, +} + +struct Thrift4554_Struct { + 1 : optional double MinValue + 2 : optional double MaxValue + 3 : optional bool Integer // causes issue + 4 : optional Thrift4554_Enum Foo +} + + +// EOF diff --git a/src/jaegertracing/thrift/lib/delphi/test/maketest.sh b/src/jaegertracing/thrift/lib/delphi/test/maketest.sh new file mode 100755 index 000000000..8f0639c05 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/maketest.sh @@ -0,0 +1,23 @@ +#!/bin/sh + +# +# 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. +# + +../../../compiler/cpp/thrift --gen delphi -o . ../../../test/ThriftTest.thrift + diff --git a/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Client.Main.pas b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Client.Main.pas new file mode 100644 index 000000000..35fdf6f5b --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Client.Main.pas @@ -0,0 +1,131 @@ +(* + * 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 Multiplex.Client.Main; + +{.$DEFINE StressTest} // activate to stress-test the server with frequent connects/disconnects +{.$DEFINE PerfTest} // activate to activate the performance test + +interface + +uses + Windows, SysUtils, Classes, + DateUtils, + Generics.Collections, + Thrift, + Thrift.Protocol, + Thrift.Protocol.Multiplex, + Thrift.Transport.Pipes, + Thrift.Transport, + Thrift.Stream, + Thrift.Collections, + Benchmark, // in gen-delphi folder + Aggr, // in gen-delphi folder + Multiplex.Test.Common; + +type + TTestClient = class + protected + FProtocol : IProtocol; + + procedure ParseArgs( const args: array of string); + procedure Setup; + procedure Run; + public + constructor Create( const args: array of string); + class procedure Execute( const args: array of string); + end; + +implementation + + +type + IServiceClient = interface + ['{7745C1C2-AB20-43BA-B6F0-08BF92DE0BAC}'] + procedure Test; + end; + +//--- TTestClient ------------------------------------- + + +class procedure TTestClient.Execute( const args: array of string); +var client : TTestClient; +begin + client := TTestClient.Create(args); + try + client.Run; + finally + client.Free; + end; +end; + + +constructor TTestClient.Create( const args: array of string); +begin + inherited Create; + ParseArgs(args); + Setup; +end; + + +procedure TTestClient.ParseArgs( const args: array of string); +begin + if Length(args) <> 0 + then raise Exception.Create('No args accepted so far'); +end; + + +procedure TTestClient.Setup; +var trans : ITransport; +begin + trans := TSocketImpl.Create( 'localhost', 9090); + trans := TFramedTransportImpl.Create( trans); + trans.Open; + FProtocol := TBinaryProtocolImpl.Create( trans, TRUE, TRUE); +end; + + +procedure TTestClient.Run; +var bench : TBenchmarkService.Iface; + aggr : TAggr.Iface; + multiplex : IProtocol; + i : Integer; +begin + try + multiplex := TMultiplexedProtocol.Create( FProtocol, NAME_BENCHMARKSERVICE); + bench := TBenchmarkService.TClient.Create( multiplex); + + multiplex := TMultiplexedProtocol.Create( FProtocol, NAME_AGGR); + aggr := TAggr.TClient.Create( multiplex); + + for i := 1 to 10 + do aggr.addValue( bench.fibonacci(i)); + + for i in aggr.getValues + do Write(IntToStr(i)+' '); + WriteLn; + except + on e:Exception do Writeln(#10+e.Message); + end; +end; + + +end. + + diff --git a/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Server.Main.pas b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Server.Main.pas new file mode 100644 index 000000000..3860f5ace --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Server.Main.pas @@ -0,0 +1,201 @@ +(* + * 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 Multiplex.Server.Main; + +{$WARN SYMBOL_PLATFORM OFF} + +{.$DEFINE RunEndless} // activate to interactively stress-test the server stop routines via Ctrl+C + +interface + +uses + Windows, SysUtils, + Generics.Collections, + Thrift.Server, + Thrift.Transport, + Thrift.Transport.Pipes, + Thrift.Protocol, + Thrift.Protocol.Multiplex, + Thrift.Processor.Multiplex, + Thrift.Collections, + Thrift.Utils, + Thrift, + Benchmark, // in gen-delphi folder + Aggr, // in gen-delphi folder + Multiplex.Test.Common, + ConsoleHelper, + Contnrs; + +type + TTestServer = class + public type + ITestHandler = interface + ['{CAE09AAB-80FB-48E9-B3A8-7F9B96F5419A}'] + procedure SetServer( const AServer : IServer ); + end; + + protected type + TTestHandlerImpl = class( TInterfacedObject, ITestHandler) + private + FServer : IServer; + protected + // ITestHandler + procedure SetServer( const AServer : IServer ); + + property Server : IServer read FServer write SetServer; + end; + + TBenchmarkServiceImpl = class( TTestHandlerImpl, TBenchmarkService.Iface) + protected + // TBenchmarkService.Iface + function fibonacci(n: ShortInt): Integer; + end; + + + TAggrImpl = class( TTestHandlerImpl, TAggr.Iface) + protected + FList : IThriftList<Integer>; + + // TAggr.Iface + procedure addValue(value: Integer); + function getValues(): IThriftList<Integer>; + public + constructor Create; + destructor Destroy; override; + end; + + public + class procedure Execute( const args: array of string); + end; + + +implementation + + +{ TTestServer.TTestHandlerImpl } + +procedure TTestServer.TTestHandlerImpl.SetServer( const AServer: IServer); +begin + FServer := AServer; +end; + + +{ TTestServer.TBenchmarkServiceImpl } + +function TTestServer.TBenchmarkServiceImpl.fibonacci(n: ShortInt): Integer; +var prev, next : Integer; +begin + prev := 0; + result := 1; + while n > 0 do begin + next := result + prev; + prev := result; + result := next; + Dec(n); + end; +end; + +{ TTestServer.TAggrImpl } + +constructor TTestServer.TAggrImpl.Create; +begin + inherited Create; + FList := TThriftListImpl<Integer>.Create; +end; + + +destructor TTestServer.TAggrImpl.Destroy; +begin + try + FreeAndNil( FList); + finally + inherited Destroy; + end; +end; + + +procedure TTestServer.TAggrImpl.addValue(value: Integer); +begin + FList.Add( value); +end; + + +function TTestServer.TAggrImpl.getValues(): IThriftList<Integer>; +begin + result := FList; +end; + + +{ TTestServer } + +class procedure TTestServer.Execute( const args: array of string); +var + TransportFactory : ITransportFactory; + ProtocolFactory : IProtocolFactory; + ServerTrans : IServerTransport; + benchHandler : TBenchmarkService.Iface; + aggrHandler : TAggr.Iface; + benchProcessor : IProcessor; + aggrProcessor : IProcessor; + multiplex : IMultiplexedProcessor; + ServerEngine : IServer; +begin + try + // create protocol factory, default to BinaryProtocol + ProtocolFactory := TBinaryProtocolImpl.TFactory.Create( TRUE, TRUE); + servertrans := TServerSocketImpl.Create( 9090, 0, FALSE); + TransportFactory := TFramedTransportImpl.TFactory.Create; + + benchHandler := TBenchmarkServiceImpl.Create; + benchProcessor := TBenchmarkService.TProcessorImpl.Create( benchHandler); + + aggrHandler := TAggrImpl.Create; + aggrProcessor := TAggr.TProcessorImpl.Create( aggrHandler); + + multiplex := TMultiplexedProcessorImpl.Create; + multiplex.RegisterProcessor( NAME_BENCHMARKSERVICE, benchProcessor); + multiplex.RegisterProcessor( NAME_AGGR, aggrProcessor); + + ServerEngine := TSimpleServer.Create( multiplex, + ServerTrans, + TransportFactory, + ProtocolFactory); + + (benchHandler as ITestHandler).SetServer( ServerEngine); + (aggrHandler as ITestHandler).SetServer( ServerEngine); + + Console.WriteLine('Starting the server ...'); + ServerEngine.serve(); + + (benchHandler as ITestHandler).SetServer( nil); + (aggrHandler as ITestHandler).SetServer( nil); + + except + on E: Exception do + begin + Console.Write( E.Message); + end; + end; + Console.WriteLine( 'done.'); +end; + + +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Client.dpr b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Client.dpr new file mode 100644 index 000000000..a57e93a2e --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Client.dpr @@ -0,0 +1,68 @@ +(* + * 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 Multiplex.Test.Client; + +{$APPTYPE CONSOLE} + +uses + SysUtils, + Multiplex.Client.Main in 'Multiplex.Client.Main.pas', + Thrift in '..\..\src\Thrift.pas', + Thrift.Socket in '..\..\src\Thrift.Socket.pas', + Thrift.Exception in '..\..\src\Thrift.Exception.pas', + Thrift.Transport in '..\..\src\Thrift.Transport.pas', + Thrift.Transport.Pipes in '..\..\src\Thrift.Transport.Pipes.pas', + Thrift.Protocol in '..\..\src\Thrift.Protocol.pas', + Thrift.Protocol.Multiplex in '..\..\src\Thrift.Protocol.Multiplex.pas', + Thrift.Collections in '..\..\src\Thrift.Collections.pas', + Thrift.Server in '..\..\src\Thrift.Server.pas', + Thrift.Stream in '..\..\src\Thrift.Stream.pas', + Thrift.TypeRegistry in '..\..\src\Thrift.TypeRegistry.pas', + Thrift.WinHTTP in '..\..\src\Thrift.WinHTTP.pas', + Thrift.Utils in '..\..\src\Thrift.Utils.pas'; + +var + nParamCount : Integer; + args : array of string; + i : Integer; + arg : string; + s : string; + +begin + try + Writeln( 'Multiplex TestClient '+Thrift.Version); + nParamCount := ParamCount; + SetLength( args, nParamCount); + for i := 1 to nParamCount do + begin + arg := ParamStr( i ); + args[i-1] := arg; + end; + TTestClient.Execute( args ); + Readln; + except + on E: Exception do begin + Writeln(E.ClassName, ': ', E.Message); + ExitCode := $FFFF; + end; + end; +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Common.pas b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Common.pas new file mode 100644 index 000000000..2caf08108 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Common.pas @@ -0,0 +1,35 @@ +(* + * 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 Multiplex.Test.Common; + +interface + +const + NAME_BENCHMARKSERVICE = 'BenchmarkService'; + NAME_AGGR = 'Aggr'; + + +implementation + +// nix + +end. + + diff --git a/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Server.dpr b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Server.dpr new file mode 100644 index 000000000..81ed3ddc4 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/multiplexed/Multiplex.Test.Server.dpr @@ -0,0 +1,69 @@ +(* + * 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 Multiplex.Test.Server; + +{$APPTYPE CONSOLE} + +uses + SysUtils, + Multiplex.Server.Main in 'Multiplex.Server.Main.pas', + ConsoleHelper in '..\ConsoleHelper.pas', + Thrift in '..\..\src\Thrift.pas', + Thrift.Exception in '..\..\src\Thrift.Exception.pas', + Thrift.Socket in '..\..\src\Thrift.Socket.pas', + Thrift.Transport in '..\..\src\Thrift.Transport.pas', + Thrift.Transport.Pipes in '..\..\src\Thrift.Transport.Pipes.pas', + Thrift.Protocol in '..\..\src\Thrift.Protocol.pas', + Thrift.Protocol.Multiplex in '..\..\src\Thrift.Protocol.Multiplex.pas', + Thrift.Processor.Multiplex in '..\..\src\Thrift.Processor.Multiplex.pas', + Thrift.Collections in '..\..\src\Thrift.Collections.pas', + Thrift.Server in '..\..\src\Thrift.Server.pas', + Thrift.Utils in '..\..\src\Thrift.Utils.pas', + Thrift.WinHTTP in '..\..\src\Thrift.WinHTTP.pas', + Thrift.TypeRegistry in '..\..\src\Thrift.TypeRegistry.pas', + Thrift.Stream in '..\..\src\Thrift.Stream.pas'; + +var + nParamCount : Integer; + args : array of string; + i : Integer; + arg : string; + s : string; + +begin + try + Writeln( 'Multiplex 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 ); + Writeln('Press ENTER to close ... '); Readln; + except + on E: Exception do + Writeln(E.ClassName, ': ', E.Message); + end; +end. + + + diff --git a/src/jaegertracing/thrift/lib/delphi/test/serializer/TestSerializer.Data.pas b/src/jaegertracing/thrift/lib/delphi/test/serializer/TestSerializer.Data.pas new file mode 100644 index 000000000..2420e9a2f --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/serializer/TestSerializer.Data.pas @@ -0,0 +1,354 @@ +(* + * 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 TestSerializer.Data; + +interface + +uses + SysUtils, + Thrift.Collections, + DebugProtoTest; + + +type + Fixtures = class + public + class function CreateOneOfEach : IOneOfEach; + class function CreateNesting : INesting; + class function CreateHolyMoley : IHolyMoley; + class function CreateCompactProtoTestStruct : ICompactProtoTestStruct; + + // These byte arrays are serialized versions of the above structs. + // They were serialized in binary protocol using thrift 0.6.x and are used to + // test backwards compatibility with respect to the standard scheme. + (* + all data copied from JAVA version, + to be used later + + public static final byte[] persistentBytesOneOfEach = new byte[] { + $02, $00, $01, $01, $02, $00, $02, $00, $03, $00, + $03, $D6, $06, $00, $04, $69, $78, $08, $00, $05, + $01, $00, $00, $00, $0A, $00, $06, $00, $00, $00, + $01, $65, $A0, $BC, $00, $04, $00, $07, $40, $09, + $21, $FB, $54, $44, $2D, $18, $0B, $00, $08, $00, + $00, $00, $0D, $4A, $53, $4F, $4E, $20, $54, $48, + $49, $53, $21, $20, $22, $01, $0B, $00, $09, $00, + $00, $00, $2E, $D3, $80, $E2, $85, $AE, $CE, $9D, + $20, $D0, $9D, $CE, $BF, $E2, $85, $BF, $D0, $BE, + $C9, $A1, $D0, $B3, $D0, $B0, $CF, $81, $E2, $84, + $8E, $20, $CE, $91, $74, $74, $CE, $B1, $E2, $85, + $BD, $CE, $BA, $EF, $BF, $BD, $E2, $80, $BC, $02, + $00, $0A, $00, $0B, $00, $0B, $00, $00, $00, $06, + $62, $61, $73, $65, $36, $34, $0F, $00, $0C, $03, + $00, $00, $00, $03, $01, $02, $03, $0F, $00, $0D, + $06, $00, $00, $00, $03, $00, $01, $00, $02, $00, + $03, $0F, $00, $0E, $0A, $00, $00, $00, $03, $00, + $00, $00, $00, $00, $00, $00, $01, $00, $00, $00, + $00, $00, $00, $00, $02, $00, $00, $00, $00, $00, + $00, $00, $03, $00 }; + + + public static final byte[] persistentBytesNesting = new byte[] { + $0C, $00, $01, $08, $00, $01, $00, $00, $7A, $69, + $0B, $00, $02, $00, $00, $00, $13, $49, $20, $61, + $6D, $20, $61, $20, $62, $6F, $6E, $6B, $2E, $2E, + $2E, $20, $78, $6F, $72, $21, $00, $0C, $00, $02, + $02, $00, $01, $01, $02, $00, $02, $00, $03, $00, + $03, $D6, $06, $00, $04, $69, $78, $08, $00, $05, + $01, $00, $00, $00, $0A, $00, $06, $00, $00, $00, + $01, $65, $A0, $BC, $00, $04, $00, $07, $40, $09, + $21, $FB, $54, $44, $2D, $18, $0B, $00, $08, $00, + $00, $00, $0D, $4A, $53, $4F, $4E, $20, $54, $48, + $49, $53, $21, $20, $22, $01, $0B, $00, $09, $00, + $00, $00, $2E, $D3, $80, $E2, $85, $AE, $CE, $9D, + $20, $D0, $9D, $CE, $BF, $E2, $85, $BF, $D0, $BE, + $C9, $A1, $D0, $B3, $D0, $B0, $CF, $81, $E2, $84, + $8E, $20, $CE, $91, $74, $74, $CE, $B1, $E2, $85, + $BD, $CE, $BA, $EF, $BF, $BD, $E2, $80, $BC, $02, + $00, $0A, $00, $0B, $00, $0B, $00, $00, $00, $06, + $62, $61, $73, $65, $36, $34, $0F, $00, $0C, $03, + $00, $00, $00, $03, $01, $02, $03, $0F, $00, $0D, + $06, $00, $00, $00, $03, $00, $01, $00, $02, $00, + $03, $0F, $00, $0E, $0A, $00, $00, $00, $03, $00, + $00, $00, $00, $00, $00, $00, $01, $00, $00, $00, + $00, $00, $00, $00, $02, $00, $00, $00, $00, $00, + $00, $00, $03, $00, $00 }; + + public static final byte[] persistentBytesHolyMoley = new byte[] { + $0F, $00, $01, $0C, $00, $00, $00, $02, $02, $00, + $01, $01, $02, $00, $02, $00, $03, $00, $03, $23, + $06, $00, $04, $69, $78, $08, $00, $05, $01, $00, + $00, $00, $0A, $00, $06, $00, $00, $00, $01, $65, + $A0, $BC, $00, $04, $00, $07, $40, $09, $21, $FB, + $54, $44, $2D, $18, $0B, $00, $08, $00, $00, $00, + $0D, $4A, $53, $4F, $4E, $20, $54, $48, $49, $53, + $21, $20, $22, $01, $0B, $00, $09, $00, $00, $00, + $2E, $D3, $80, $E2, $85, $AE, $CE, $9D, $20, $D0, + $9D, $CE, $BF, $E2, $85, $BF, $D0, $BE, $C9, $A1, + $D0, $B3, $D0, $B0, $CF, $81, $E2, $84, $8E, $20, + $CE, $91, $74, $74, $CE, $B1, $E2, $85, $BD, $CE, + $BA, $EF, $BF, $BD, $E2, $80, $BC, $02, $00, $0A, + $00, $0B, $00, $0B, $00, $00, $00, $06, $62, $61, + $73, $65, $36, $34, $0F, $00, $0C, $03, $00, $00, + $00, $03, $01, $02, $03, $0F, $00, $0D, $06, $00, + $00, $00, $03, $00, $01, $00, $02, $00, $03, $0F, + $00, $0E, $0A, $00, $00, $00, $03, $00, $00, $00, + $00, $00, $00, $00, $01, $00, $00, $00, $00, $00, + $00, $00, $02, $00, $00, $00, $00, $00, $00, $00, + $03, $00, $02, $00, $01, $01, $02, $00, $02, $00, + $03, $00, $03, $D6, $06, $00, $04, $69, $78, $08, + $00, $05, $01, $00, $00, $00, $0A, $00, $06, $00, + $00, $00, $01, $65, $A0, $BC, $00, $04, $00, $07, + $40, $09, $21, $FB, $54, $44, $2D, $18, $0B, $00, + $08, $00, $00, $00, $0D, $4A, $53, $4F, $4E, $20, + $54, $48, $49, $53, $21, $20, $22, $01, $0B, $00, + $09, $00, $00, $00, $2E, $D3, $80, $E2, $85, $AE, + $CE, $9D, $20, $D0, $9D, $CE, $BF, $E2, $85, $BF, + $D0, $BE, $C9, $A1, $D0, $B3, $D0, $B0, $CF, $81, + $E2, $84, $8E, $20, $CE, $91, $74, $74, $CE, $B1, + $E2, $85, $BD, $CE, $BA, $EF, $BF, $BD, $E2, $80, + $BC, $02, $00, $0A, $00, $0B, $00, $0B, $00, $00, + $00, $06, $62, $61, $73, $65, $36, $34, $0F, $00, + $0C, $03, $00, $00, $00, $03, $01, $02, $03, $0F, + $00, $0D, $06, $00, $00, $00, $03, $00, $01, $00, + $02, $00, $03, $0F, $00, $0E, $0A, $00, $00, $00, + $03, $00, $00, $00, $00, $00, $00, $00, $01, $00, + $00, $00, $00, $00, $00, $00, $02, $00, $00, $00, + $00, $00, $00, $00, $03, $00, $0E, $00, $02, $0F, + $00, $00, $00, $03, $0B, $00, $00, $00, $00, $0B, + $00, $00, $00, $03, $00, $00, $00, $0F, $74, $68, + $65, $6E, $20, $61, $20, $6F, $6E, $65, $2C, $20, + $74, $77, $6F, $00, $00, $00, $06, $74, $68, $72, + $65, $65, $21, $00, $00, $00, $06, $46, $4F, $55, + $52, $21, $21, $0B, $00, $00, $00, $02, $00, $00, + $00, $09, $61, $6E, $64, $20, $61, $20, $6F, $6E, + $65, $00, $00, $00, $09, $61, $6E, $64, $20, $61, + $20, $74, $77, $6F, $0D, $00, $03, $0B, $0F, $00, + $00, $00, $03, $00, $00, $00, $03, $74, $77, $6F, + $0C, $00, $00, $00, $02, $08, $00, $01, $00, $00, + $00, $01, $0B, $00, $02, $00, $00, $00, $05, $57, + $61, $69, $74, $2E, $00, $08, $00, $01, $00, $00, + $00, $02, $0B, $00, $02, $00, $00, $00, $05, $57, + $68, $61, $74, $3F, $00, $00, $00, $00, $05, $74, + $68, $72, $65, $65, $0C, $00, $00, $00, $00, $00, + $00, $00, $04, $7A, $65, $72, $6F, $0C, $00, $00, + $00, $00, $00 }; + + +*) + + private + const + kUnicodeBytes : packed array[0..43] of Byte + = ( $d3, $80, $e2, $85, $ae, $ce, $9d, $20, $d0, $9d, + $ce, $bf, $e2, $85, $bf, $d0, $be, $c9, $a1, $d0, + $b3, $d0, $b0, $cf, $81, $e2, $84, $8e, $20, $ce, + $91, $74, $74, $ce, $b1, $e2, $85, $bd, $ce, $ba, + $83, $e2, $80, $bc); + + end; + + +implementation + + +class function Fixtures.CreateOneOfEach : IOneOfEach; +var db : Double; + us : Utf8String; +begin + result := TOneOfEachImpl.Create; + result.setIm_true( TRUE); + result.setIm_false( FALSE); + result.setA_bite( ShortInt($D6)); + result.setInteger16( 27000); + result.setInteger32( 1 shl 24); + result.setInteger64( Int64(6000) * Int64(1000) * Int64(1000)); + db := Pi; + result.setDouble_precision( db); + result.setSome_characters( 'JSON THIS! \"\1'); + + // ?? + SetLength( us, Length(kUnicodeBytes)); + Move( kUnicodeBytes[0], us[1], Length(kUnicodeBytes)); + // ?? + SetString( us, PChar(@kUnicodeBytes[0]), Length(kUnicodeBytes)); + // !! + result.setZomg_unicode( UnicodeString( us)); + + {$IF cDebugProtoTest_Option_AnsiStr_Binary} + result.SetBase64('base64'); + {$ELSE} + result.SetBase64( TEncoding.UTF8.GetBytes('base64')); + {$IFEND} + + // byte, i16, and i64 lists are populated by default constructor +end; + + +class function Fixtures.CreateNesting : INesting; +var bonk : IBonk; +begin + bonk := TBonkImpl.Create; + bonk.Type_ := 31337; + bonk.Message := 'I am a bonk... xor!'; + + result := TNestingImpl.Create; + result.My_bonk := bonk; + result.My_ooe := CreateOneOfEach; +end; + + +class function Fixtures.CreateHolyMoley : IHolyMoley; +var big : IThriftList<IOneOfEach>; + stage1 : IThriftList<String>; + stage2 : IThriftList<IBonk>; + b : IBonk; +begin + result := THolyMoleyImpl.Create; + + big := TThriftListImpl<IOneOfEach>.Create; + big.add( CreateOneOfEach); + big.add( CreateNesting.my_ooe); + result.Big := big; + result.Big[0].setA_bite( $22); + result.Big[0].setA_bite( $23); + + result.Contain := THashSetImpl< IThriftList<string>>.Create; + stage1 := TThriftListImpl<String>.Create; + stage1.add( 'and a one'); + stage1.add( 'and a two'); + result.Contain.add( stage1); + + stage1 := TThriftListImpl<String>.Create; + stage1.add( 'then a one, two'); + stage1.add( 'three!'); + stage1.add( 'FOUR!!'); + result.Contain.add( stage1); + + stage1 := TThriftListImpl<String>.Create; + result.Contain.add( stage1); + + stage2 := TThriftListImpl<IBonk>.Create; + result.Bonks := TThriftDictionaryImpl< String, IThriftList< IBonk>>.Create; + // one empty + result.Bonks.Add( 'zero', stage2); + + // one with two + stage2 := TThriftListImpl<IBonk>.Create; + b := TBonkImpl.Create; + b.type_ := 1; + b.message := 'Wait.'; + stage2.Add( b); + b := TBonkImpl.Create; + b.type_ := 2; + b.message := 'What?'; + stage2.Add( b); + result.Bonks.Add( 'two', stage2); + + // one with three + stage2 := TThriftListImpl<IBonk>.Create; + b := TBonkImpl.Create; + b.type_ := 3; + b.message := 'quoth'; + stage2.Add( b); + b := TBonkImpl.Create; + b.type_ := 4; + b.message := 'the raven'; + stage2.Add( b); + b := TBonkImpl.Create; + b.type_ := 5; + b.message := 'nevermore'; + stage2.Add( b); + result.bonks.Add( 'three', stage2); +end; + + +class function Fixtures.CreateCompactProtoTestStruct : ICompactProtoTestStruct; +// superhuge compact proto test struct +begin + result := TCompactProtoTestStructImpl.Create; + result.A_byte := TDebugProtoTestConstants.COMPACT_TEST.A_byte; + result.A_i16 := TDebugProtoTestConstants.COMPACT_TEST.A_i16; + result.A_i32 := TDebugProtoTestConstants.COMPACT_TEST.A_i32; + result.A_i64 := TDebugProtoTestConstants.COMPACT_TEST.A_i64; + result.A_double := TDebugProtoTestConstants.COMPACT_TEST.A_double; + result.A_string := TDebugProtoTestConstants.COMPACT_TEST.A_string; + result.A_binary := TDebugProtoTestConstants.COMPACT_TEST.A_binary; + result.True_field := TDebugProtoTestConstants.COMPACT_TEST.True_field; + result.False_field := TDebugProtoTestConstants.COMPACT_TEST.False_field; + result.Empty_struct_field := TDebugProtoTestConstants.COMPACT_TEST.Empty_struct_field; + result.Byte_list := TDebugProtoTestConstants.COMPACT_TEST.Byte_list; + result.I16_list := TDebugProtoTestConstants.COMPACT_TEST.I16_list; + result.I32_list := TDebugProtoTestConstants.COMPACT_TEST.I32_list; + result.I64_list := TDebugProtoTestConstants.COMPACT_TEST.I64_list; + result.Double_list := TDebugProtoTestConstants.COMPACT_TEST.Double_list; + result.String_list := TDebugProtoTestConstants.COMPACT_TEST.String_list; + result.Binary_list := TDebugProtoTestConstants.COMPACT_TEST.Binary_list; + result.Boolean_list := TDebugProtoTestConstants.COMPACT_TEST.Boolean_list; + result.Struct_list := TDebugProtoTestConstants.COMPACT_TEST.Struct_list; + result.Byte_set := TDebugProtoTestConstants.COMPACT_TEST.Byte_set; + result.I16_set := TDebugProtoTestConstants.COMPACT_TEST.I16_set; + result.I32_set := TDebugProtoTestConstants.COMPACT_TEST.I32_set; + result.I64_set := TDebugProtoTestConstants.COMPACT_TEST.I64_set; + result.Double_set := TDebugProtoTestConstants.COMPACT_TEST.Double_set; + result.String_set := TDebugProtoTestConstants.COMPACT_TEST.String_set; + result.String_set := TDebugProtoTestConstants.COMPACT_TEST.String_set; + result.String_set := TDebugProtoTestConstants.COMPACT_TEST.String_set; + result.Binary_set := TDebugProtoTestConstants.COMPACT_TEST.Binary_set; + result.Boolean_set := TDebugProtoTestConstants.COMPACT_TEST.Boolean_set; + result.Struct_set := TDebugProtoTestConstants.COMPACT_TEST.Struct_set; + result.Byte_byte_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_byte_map; + result.I16_byte_map := TDebugProtoTestConstants.COMPACT_TEST.I16_byte_map; + result.I32_byte_map := TDebugProtoTestConstants.COMPACT_TEST.I32_byte_map; + result.I64_byte_map := TDebugProtoTestConstants.COMPACT_TEST.I64_byte_map; + result.Double_byte_map := TDebugProtoTestConstants.COMPACT_TEST.Double_byte_map; + result.String_byte_map := TDebugProtoTestConstants.COMPACT_TEST.String_byte_map; + result.Binary_byte_map := TDebugProtoTestConstants.COMPACT_TEST.Binary_byte_map; + result.Boolean_byte_map := TDebugProtoTestConstants.COMPACT_TEST.Boolean_byte_map; + result.Byte_i16_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_i16_map; + result.Byte_i32_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_i32_map; + result.Byte_i64_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_i64_map; + result.Byte_double_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_double_map; + result.Byte_string_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_string_map; + result.Byte_binary_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_binary_map; + result.Byte_boolean_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_boolean_map; + result.List_byte_map := TDebugProtoTestConstants.COMPACT_TEST.List_byte_map; + result.Set_byte_map := TDebugProtoTestConstants.COMPACT_TEST.Set_byte_map; + result.Map_byte_map := TDebugProtoTestConstants.COMPACT_TEST.Map_byte_map; + result.Byte_map_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_map_map; + result.Byte_set_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_set_map; + result.Byte_list_map := TDebugProtoTestConstants.COMPACT_TEST.Byte_list_map; + + result.Field500 := 500; + result.Field5000 := 5000; + result.Field20000 := 20000; + + {$IF cDebugProtoTest_Option_AnsiStr_Binary} + result.A_binary := AnsiString( #0#1#2#3#4#5#6#7#8); + {$ELSE} + result.A_binary := TEncoding.UTF8.GetBytes( #0#1#2#3#4#5#6#7#8); + {$IFEND} +end; + + + + +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/serializer/TestSerializer.dpr b/src/jaegertracing/thrift/lib/delphi/test/serializer/TestSerializer.dpr new file mode 100644 index 000000000..56d0d15d4 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/serializer/TestSerializer.dpr @@ -0,0 +1,283 @@ +(* + * 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 TestSerializer; + +{$APPTYPE CONSOLE} + +uses + Classes, Windows, SysUtils, Generics.Collections, + Thrift in '..\..\src\Thrift.pas', + Thrift.Exception in '..\..\src\Thrift.Exception.pas', + Thrift.Socket in '..\..\src\Thrift.Socket.pas', + Thrift.Transport in '..\..\src\Thrift.Transport.pas', + Thrift.Protocol in '..\..\src\Thrift.Protocol.pas', + Thrift.Protocol.JSON in '..\..\src\Thrift.Protocol.JSON.pas', + Thrift.Protocol.Compact in '..\..\src\Thrift.Protocol.Compact.pas', + Thrift.Collections in '..\..\src\Thrift.Collections.pas', + Thrift.Server in '..\..\src\Thrift.Server.pas', + Thrift.Utils in '..\..\src\Thrift.Utils.pas', + Thrift.Serializer in '..\..\src\Thrift.Serializer.pas', + Thrift.Stream in '..\..\src\Thrift.Stream.pas', + Thrift.WinHTTP in '..\..\src\Thrift.WinHTTP.pas', + Thrift.TypeRegistry in '..\..\src\Thrift.TypeRegistry.pas', + System_, + DebugProtoTest, + TestSerializer.Data; + + + +type + TTestSerializer = class //extends TestCase { + private type + TMethod = ( + mt_Bytes, + mt_Stream + ); + + private + FProtocols : TList< IProtocolFactory>; + + class function Serialize(const input : IBase; const factory : IProtocolFactory) : TBytes; overload; + class procedure Serialize(const input : IBase; const factory : IProtocolFactory; const aStream : TStream); overload; + class procedure Deserialize( const input : TBytes; const target : IBase; const factory : IProtocolFactory); overload; + class procedure Deserialize( const input : TStream; const target : IBase; const factory : IProtocolFactory); overload; + + procedure Test_Serializer_Deserializer; + procedure Test_OneOfEach( const method : TMethod; const factory : IProtocolFactory; const stream : TFileStream); + procedure Test_CompactStruct( const method : TMethod; const factory : IProtocolFactory; const stream : TFileStream); + + public + constructor Create; + destructor Destroy; override; + + procedure RunTests; + end; + + + +{ TTestSerializer } + +constructor TTestSerializer.Create; +begin + inherited Create; + FProtocols := TList< IProtocolFactory>.Create; + FProtocols.Add( TBinaryProtocolImpl.TFactory.Create); + FProtocols.Add( TCompactProtocolImpl.TFactory.Create); + FProtocols.Add( TJSONProtocolImpl.TFactory.Create); +end; + + +destructor TTestSerializer.Destroy; +begin + try + FreeAndNil( FProtocols); + finally + inherited Destroy; + end; +end; + + +procedure TTestSerializer.Test_OneOfEach( const method : TMethod; const factory : IProtocolFactory; const stream : TFileStream); +var tested, correct : IOneOfEach; + bytes : TBytes; + i : Integer; +begin + // write + tested := Fixtures.CreateOneOfEach; + case method of + mt_Bytes: bytes := Serialize( tested, factory); + mt_Stream: begin + stream.Size := 0; + Serialize( tested, factory, stream); + end + else + ASSERT( FALSE); + end; + + // init + read + tested := TOneOfEachImpl.Create; + case method of + mt_Bytes: Deserialize( bytes, tested, factory); + mt_Stream: begin + stream.Position := 0; + Deserialize( stream, tested, factory); + end + else + ASSERT( FALSE); + end; + + // check + correct := Fixtures.CreateOneOfEach; + ASSERT( tested.Im_true = correct.Im_true); + ASSERT( tested.Im_false = correct.Im_false); + ASSERT( tested.A_bite = correct.A_bite); + ASSERT( tested.Integer16 = correct.Integer16); + ASSERT( tested.Integer32 = correct.Integer32); + ASSERT( tested.Integer64 = correct.Integer64); + ASSERT( Abs( tested.Double_precision - correct.Double_precision) < 1E-12); + ASSERT( tested.Some_characters = correct.Some_characters); + ASSERT( tested.Zomg_unicode = correct.Zomg_unicode); + ASSERT( tested.What_who = correct.What_who); + + ASSERT( Length(tested.Base64) = Length(correct.Base64)); + ASSERT( CompareMem( @tested.Base64[0], @correct.Base64[0], Length(correct.Base64))); + + ASSERT( tested.Byte_list.Count = correct.Byte_list.Count); + for i := 0 to tested.Byte_list.Count-1 + do ASSERT( tested.Byte_list[i] = correct.Byte_list[i]); + + ASSERT( tested.I16_list.Count = correct.I16_list.Count); + for i := 0 to tested.I16_list.Count-1 + do ASSERT( tested.I16_list[i] = correct.I16_list[i]); + + ASSERT( tested.I64_list.Count = correct.I64_list.Count); + for i := 0 to tested.I64_list.Count-1 + do ASSERT( tested.I64_list[i] = correct.I64_list[i]); +end; + + +procedure TTestSerializer.Test_CompactStruct( const method : TMethod; const factory : IProtocolFactory; const stream : TFileStream); +var tested, correct : ICompactProtoTestStruct; + bytes : TBytes; +begin + // write + tested := Fixtures.CreateCompactProtoTestStruct; + case method of + mt_Bytes: bytes := Serialize( tested, factory); + mt_Stream: begin + stream.Size := 0; + Serialize( tested, factory, stream); + end + else + ASSERT( FALSE); + end; + + // init + read + correct := TCompactProtoTestStructImpl.Create; + case method of + mt_Bytes: Deserialize( bytes, tested, factory); + mt_Stream: begin + stream.Position := 0; + Deserialize( stream, tested, factory); + end + else + ASSERT( FALSE); + end; + + // check + correct := Fixtures.CreateCompactProtoTestStruct; + ASSERT( correct.Field500 = tested.Field500); + ASSERT( correct.Field5000 = tested.Field5000); + ASSERT( correct.Field20000 = tested.Field20000); +end; + + +procedure TTestSerializer.Test_Serializer_Deserializer; +var factory : IProtocolFactory; + stream : TFileStream; + method : TMethod; +begin + stream := TFileStream.Create( 'TestSerializer.dat', fmCreate); + try + + for method in [Low(TMethod)..High(TMethod)] do begin + for factory in FProtocols do begin + + Test_OneOfEach( method, factory, stream); + Test_CompactStruct( method, factory, stream); + end; + end; + + finally + stream.Free; + end; +end; + + +procedure TTestSerializer.RunTests; +begin + try + Test_Serializer_Deserializer; + except + on e:Exception do begin + Writeln( e.Message); + Write('Hit ENTER to close ... '); Readln; + end; + end; +end; + + +class function TTestSerializer.Serialize(const input : IBase; const factory : IProtocolFactory) : TBytes; +var serial : TSerializer; +begin + serial := TSerializer.Create( factory); + try + result := serial.Serialize( input); + finally + serial.Free; + end; +end; + + +class procedure TTestSerializer.Serialize(const input : IBase; const factory : IProtocolFactory; const aStream : TStream); +var serial : TSerializer; +begin + serial := TSerializer.Create( factory); + try + serial.Serialize( input, aStream); + finally + serial.Free; + end; +end; + + +class procedure TTestSerializer.Deserialize( const input : TBytes; const target : IBase; const factory : IProtocolFactory); +var serial : TDeserializer; +begin + serial := TDeserializer.Create( factory); + try + serial.Deserialize( input, target); + finally + serial.Free; + end; +end; + +class procedure TTestSerializer.Deserialize( const input : TStream; const target : IBase; const factory : IProtocolFactory); +var serial : TDeserializer; +begin + serial := TDeserializer.Create( factory); + try + serial.Deserialize( input, target); + finally + serial.Free; + end; +end; + + +var test : TTestSerializer; +begin + test := TTestSerializer.Create; + try + test.RunTests; + finally + test.Free; + end; +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/server.dpr b/src/jaegertracing/thrift/lib/delphi/test/server.dpr new file mode 100644 index 000000000..9731dd4fa --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/server.dpr @@ -0,0 +1,74 @@ +(* + * 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', + TestServerEvents in 'TestServerEvents.pas', + Thrift.Test, // in gen-delphi folder + Thrift in '..\src\Thrift.pas', + Thrift.Exception in '..\src\Thrift.Exception.pas', + Thrift.Transport in '..\src\Thrift.Transport.pas', + Thrift.Socket in '..\src\Thrift.Socket.pas', + Thrift.Transport.Pipes in '..\src\Thrift.Transport.Pipes.pas', + Thrift.Protocol in '..\src\Thrift.Protocol.pas', + Thrift.Protocol.JSON in '..\src\Thrift.Protocol.JSON.pas', + Thrift.Protocol.Compact in '..\src\Thrift.Protocol.Compact.pas', + Thrift.Protocol.Multiplex in '..\src\Thrift.Protocol.Multiplex.pas', + Thrift.Processor.Multiplex in '..\src\Thrift.Processor.Multiplex.pas', + Thrift.Collections in '..\src\Thrift.Collections.pas', + Thrift.Server in '..\src\Thrift.Server.pas', + Thrift.TypeRegistry in '..\src\Thrift.TypeRegistry.pas', + Thrift.Utils in '..\src\Thrift.Utils.pas', + Thrift.WinHTTP in '..\src\Thrift.WinHTTP.pas', + Thrift.Stream in '..\src\Thrift.Stream.pas'; + +var + nParamCount : Integer; + args : array of string; + i : Integer; + arg : 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 ); + + except + on E: EAbort do begin + ExitCode := $FF; + end; + on E: Exception do begin + Writeln(E.ClassName, ': ', E.Message); + ExitCode := $FF; + end; + end; +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/skip/README.md b/src/jaegertracing/thrift/lib/delphi/test/skip/README.md new file mode 100644 index 000000000..f34936834 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/skip/README.md @@ -0,0 +1,11 @@ +These two projects belong together. Both programs +simulate server and client for different versions +of the same protocol. + +The intention of this test is to ensure fully +working compatibility features of the Delphi Thrift +implementation. + +The expected test result is, that no errors occur +with both programs, regardless in which order they +might be started. diff --git a/src/jaegertracing/thrift/lib/delphi/test/skip/idl/skiptest_version_1.thrift b/src/jaegertracing/thrift/lib/delphi/test/skip/idl/skiptest_version_1.thrift new file mode 100644 index 000000000..8353c5e12 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/skip/idl/skiptest_version_1.thrift @@ -0,0 +1,45 @@ +/* + * 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. + */ + + +// version 1 of the interface + +namespace * Skiptest.One + +const i32 SKIPTESTSERVICE_VERSION = 1 + +struct Pong { + 1 : optional i32 version1 +} + +struct Ping { + 1 : optional i32 version1 +} + +exception PongFailed { + 222 : optional i32 pongErrorCode +} + + +service SkipTestService { + void PingPong( 1: Ping pong) throws (444: PongFailed pof); +} + + +// EOF
\ No newline at end of file diff --git a/src/jaegertracing/thrift/lib/delphi/test/skip/idl/skiptest_version_2.thrift b/src/jaegertracing/thrift/lib/delphi/test/skip/idl/skiptest_version_2.thrift new file mode 100644 index 000000000..f3352d327 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/skip/idl/skiptest_version_2.thrift @@ -0,0 +1,69 @@ +/* + * 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. + */ + + +// version 2 of the interface + +namespace * Skiptest.Two + +const i32 SKIPTESTSERVICE_VERSION = 2 + +struct Pong { + 1 : optional i32 version1 + 2 : optional i16 version2 +} + +struct Ping { + 1 : optional i32 version1 + 10 : optional bool boolVal + 11 : optional byte byteVal + 12 : optional double dbVal + 13 : optional i16 i16Val + 14 : optional i32 i32Val + 15 : optional i64 i64Val + 16 : optional string strVal + 17 : optional Pong structVal + 18 : optional map< list< Pong>, set< string>> mapVal +} + +exception PingFailed { + 1 : optional i32 pingErrorCode +} + +exception PongFailed { + 222 : optional i32 pongErrorCode + 10 : optional bool boolVal + 11 : optional byte byteVal + 12 : optional double dbVal + 13 : optional i16 i16Val + 14 : optional i32 i32Val + 15 : optional i64 i64Val + 16 : optional string strVal + 17 : optional Pong structVal + 18 : optional map< list< Pong>, set< string>> mapVal +} + + +service SkipTestService { + Ping PingPong( 1: Ping ping, 3: Pong pong) throws (1: PingFailed pif, 444: PongFailed pof); +} + + +// EOF + diff --git a/src/jaegertracing/thrift/lib/delphi/test/skip/skiptest_version1.dpr b/src/jaegertracing/thrift/lib/delphi/test/skip/skiptest_version1.dpr new file mode 100644 index 000000000..0bfe96fef --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/skip/skiptest_version1.dpr @@ -0,0 +1,202 @@ +(* + * 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 skiptest_version1; + +{$APPTYPE CONSOLE} + +uses + Classes, Windows, SysUtils, + Skiptest.One, + Thrift in '..\..\src\Thrift.pas', + Thrift.Exception in '..\..\src\Thrift.Exception.pas', + Thrift.Socket in '..\..\src\Thrift.Socket.pas', + Thrift.Transport in '..\..\src\Thrift.Transport.pas', + Thrift.Protocol in '..\..\src\Thrift.Protocol.pas', + Thrift.Protocol.JSON in '..\..\src\Thrift.Protocol.JSON.pas', + Thrift.Collections in '..\..\src\Thrift.Collections.pas', + Thrift.Server in '..\..\src\Thrift.Server.pas', + Thrift.Utils in '..\..\src\Thrift.Utils.pas', + Thrift.WinHTTP in '..\..\src\Thrift.WinHTTP.pas', + Thrift.TypeRegistry in '..\..\src\Thrift.TypeRegistry.pas', + Thrift.Stream in '..\..\src\Thrift.Stream.pas'; + +const + REQUEST_EXT = '.request'; + RESPONSE_EXT = '.response'; + + +function CreatePing : IPing; +begin + result := TPingImpl.Create; + result.Version1 := Tskiptest_version_1Constants.SKIPTESTSERVICE_VERSION; +end; + + +type + TDummyServer = class( TInterfacedObject, TSkipTestService.Iface) + protected + // TSkipTestService.Iface + procedure PingPong(const ping: IPing); + end; + + +procedure TDummyServer.PingPong(const ping: IPing); +// TSkipTestService.Iface +begin + Writeln('- performing request from version '+IntToStr(ping.Version1)+' client'); +end; + + +function CreateProtocol( protfact : IProtocolFactory; stm : TStream; aForInput : Boolean) : IProtocol; +var adapt : IThriftStream; + trans : ITransport; +begin + adapt := TThriftStreamAdapterDelphi.Create( stm, FALSE); + if aForInput + then trans := TStreamTransportImpl.Create( adapt, nil) + else trans := TStreamTransportImpl.Create( nil, adapt); + result := protfact.GetProtocol( trans); +end; + + +procedure CreateRequest( protfact : IProtocolFactory; fname : string); +var stm : TFileStream; + ping : IPing; + proto : IProtocol; + client : TSkipTestService.TClient; // we need access to send/recv_pingpong() + cliRef : IUnknown; // holds the refcount +begin + Writeln('- creating new request'); + stm := TFileStream.Create( fname+REQUEST_EXT+'.tmp', fmCreate); + try + ping := CreatePing; + + // save request data + proto := CreateProtocol( protfact, stm, FALSE); + client := TSkipTestService.TClient.Create( nil, proto); + cliRef := client as IUnknown; + client.send_PingPong( ping); + + finally + client := nil; // not Free! + cliRef := nil; + stm.Free; + if client = nil then {warning suppressed}; + end; + + DeleteFile( fname+REQUEST_EXT); + RenameFile( fname+REQUEST_EXT+'.tmp', fname+REQUEST_EXT); +end; + + +procedure ReadResponse( protfact : IProtocolFactory; fname : string); +var stm : TFileStream; + proto : IProtocol; + client : TSkipTestService.TClient; // we need access to send/recv_pingpong() + cliRef : IUnknown; // holds the refcount +begin + Writeln('- reading response'); + stm := TFileStream.Create( fname+RESPONSE_EXT, fmOpenRead); + try + // save request data + proto := CreateProtocol( protfact, stm, TRUE); + client := TSkipTestService.TClient.Create( proto, nil); + cliRef := client as IUnknown; + client.recv_PingPong; + + finally + client := nil; // not Free! + cliRef := nil; + stm.Free; + if client = nil then {warning suppressed}; + end; +end; + + +procedure ProcessFile( protfact : IProtocolFactory; fname : string); +var stmIn, stmOut : TFileStream; + protIn, protOut : IProtocol; + server : IProcessor; +begin + Writeln('- processing request'); + stmOut := nil; + stmIn := TFileStream.Create( fname+REQUEST_EXT, fmOpenRead); + try + stmOut := TFileStream.Create( fname+RESPONSE_EXT+'.tmp', fmCreate); + + // process request and write response data + protIn := CreateProtocol( protfact, stmIn, TRUE); + protOut := CreateProtocol( protfact, stmOut, FALSE); + + server := TSkipTestService.TProcessorImpl.Create( TDummyServer.Create); + server.Process( protIn, protOut); + + finally + server := nil; // not Free! + stmIn.Free; + stmOut.Free; + if server = nil then {warning suppressed}; + end; + + DeleteFile( fname+RESPONSE_EXT); + RenameFile( fname+RESPONSE_EXT+'.tmp', fname+RESPONSE_EXT); +end; + + +procedure Test( protfact : IProtocolFactory; fname : string); +begin + // try to read an existing request + if FileExists( fname + REQUEST_EXT) then begin + ProcessFile( protfact, fname); + ReadResponse( protfact, fname); + end; + + // create a new request and try to process + CreateRequest( protfact, fname); + ProcessFile( protfact, fname); + ReadResponse( protfact, fname); +end; + + +const + FILE_BINARY = 'pingpong.bin'; + FILE_JSON = 'pingpong.json'; +begin + try + Writeln( 'Delphi SkipTest '+IntToStr(Tskiptest_version_1Constants.SKIPTESTSERVICE_VERSION)+' using '+Thrift.Version); + + Writeln; + Writeln('Binary protocol'); + Test( TBinaryProtocolImpl.TFactory.Create, FILE_BINARY); + + Writeln; + Writeln('JSON protocol'); + Test( TJSONProtocolImpl.TFactory.Create, FILE_JSON); + + Writeln; + Writeln('Test completed without errors.'); + Writeln; + Write('Press ENTER to close ...'); Readln; + except + on E: Exception do + Writeln(E.ClassName, ': ', E.Message); + end; +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/skip/skiptest_version2.dpr b/src/jaegertracing/thrift/lib/delphi/test/skip/skiptest_version2.dpr new file mode 100644 index 000000000..7893748a0 --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/skip/skiptest_version2.dpr @@ -0,0 +1,229 @@ +(* + * 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 skiptest_version2; + +{$APPTYPE CONSOLE} + +uses + Classes, Windows, SysUtils, + Skiptest.Two, + Thrift in '..\..\src\Thrift.pas', + Thrift.Exception in '..\..\src\Thrift.Exception.pas', + Thrift.Socket in '..\..\src\Thrift.Socket.pas', + Thrift.Transport in '..\..\src\Thrift.Transport.pas', + Thrift.Protocol in '..\..\src\Thrift.Protocol.pas', + Thrift.Protocol.JSON in '..\..\src\Thrift.Protocol.JSON.pas', + Thrift.Collections in '..\..\src\Thrift.Collections.pas', + Thrift.Server in '..\..\src\Thrift.Server.pas', + Thrift.Utils in '..\..\src\Thrift.Utils.pas', + Thrift.WinHTTP in '..\..\src\Thrift.WinHTTP.pas', + Thrift.TypeRegistry in '..\..\src\Thrift.TypeRegistry.pas', + Thrift.Stream in '..\..\src\Thrift.Stream.pas'; + +const + REQUEST_EXT = '.request'; + RESPONSE_EXT = '.response'; + +function CreatePing : IPing; +var list : IThriftList<IPong>; + set_ : IHashSet<string>; +begin + result := TPingImpl.Create; + result.Version1 := Tskiptest_version_2Constants.SKIPTESTSERVICE_VERSION; + result.BoolVal := TRUE; + result.ByteVal := 2; + result.DbVal := 3; + result.I16Val := 4; + result.I32Val := 5; + result.I64Val := 6; + result.StrVal := 'seven'; + + result.StructVal := TPongImpl.Create; + result.StructVal.Version1 := -1; + result.StructVal.Version2 := -2; + + list := TThriftListImpl<IPong>.Create; + list.Add( result.StructVal); + list.Add( result.StructVal); + + set_ := THashSetImpl<string>.Create; + set_.Add( 'one'); + set_.Add( 'uno'); + set_.Add( 'eins'); + set_.Add( 'een'); + + result.MapVal := TThriftDictionaryImpl< IThriftList<IPong>, IHashSet<string>>.Create; + result.MapVal.Add( list, set_); +end; + + +type + TDummyServer = class( TInterfacedObject, TSkipTestService.Iface) + protected + // TSkipTestService.Iface + function PingPong(const ping: IPing; const pong: IPong): IPing; + end; + + +function TDummyServer.PingPong(const ping: IPing; const pong: IPong): IPing; +// TSkipTestService.Iface +begin + Writeln('- performing request from version '+IntToStr(ping.Version1)+' client'); + result := CreatePing; +end; + + +function CreateProtocol( protfact : IProtocolFactory; stm : TStream; aForInput : Boolean) : IProtocol; +var adapt : IThriftStream; + trans : ITransport; +begin + adapt := TThriftStreamAdapterDelphi.Create( stm, FALSE); + if aForInput + then trans := TStreamTransportImpl.Create( adapt, nil) + else trans := TStreamTransportImpl.Create( nil, adapt); + result := protfact.GetProtocol( trans); +end; + + +procedure CreateRequest( protfact : IProtocolFactory; fname : string); +var stm : TFileStream; + ping : IPing; + proto : IProtocol; + client : TSkipTestService.TClient; // we need access to send/recv_pingpong() + cliRef : IUnknown; // holds the refcount +begin + Writeln('- creating new request'); + stm := TFileStream.Create( fname+REQUEST_EXT+'.tmp', fmCreate); + try + ping := CreatePing; + + // save request data + proto := CreateProtocol( protfact, stm, FALSE); + client := TSkipTestService.TClient.Create( nil, proto); + cliRef := client as IUnknown; + client.send_PingPong( ping, ping.StructVal); + + finally + client := nil; // not Free! + cliRef := nil; + stm.Free; + if client = nil then {warning suppressed}; + end; + + DeleteFile( fname+REQUEST_EXT); + RenameFile( fname+REQUEST_EXT+'.tmp', fname+REQUEST_EXT); +end; + + +procedure ReadResponse( protfact : IProtocolFactory; fname : string); +var stm : TFileStream; + ping : IPing; + proto : IProtocol; + client : TSkipTestService.TClient; // we need access to send/recv_pingpong() + cliRef : IUnknown; // holds the refcount +begin + Writeln('- reading response'); + stm := TFileStream.Create( fname+RESPONSE_EXT, fmOpenRead); + try + // save request data + proto := CreateProtocol( protfact, stm, TRUE); + client := TSkipTestService.TClient.Create( proto, nil); + cliRef := client as IUnknown; + ping := client.recv_PingPong; + + finally + client := nil; // not Free! + cliRef := nil; + stm.Free; + if client = nil then {warning suppressed}; + end; +end; + + +procedure ProcessFile( protfact : IProtocolFactory; fname : string); +var stmIn, stmOut : TFileStream; + protIn, protOut : IProtocol; + server : IProcessor; +begin + Writeln('- processing request'); + stmOut := nil; + stmIn := TFileStream.Create( fname+REQUEST_EXT, fmOpenRead); + try + stmOut := TFileStream.Create( fname+RESPONSE_EXT+'.tmp', fmCreate); + + // process request and write response data + protIn := CreateProtocol( protfact, stmIn, TRUE); + protOut := CreateProtocol( protfact, stmOut, FALSE); + + server := TSkipTestService.TProcessorImpl.Create( TDummyServer.Create); + server.Process( protIn, protOut); + + finally + server := nil; // not Free! + stmIn.Free; + stmOut.Free; + if server = nil then {warning suppressed}; + end; + + DeleteFile( fname+RESPONSE_EXT); + RenameFile( fname+RESPONSE_EXT+'.tmp', fname+RESPONSE_EXT); +end; + + +procedure Test( protfact : IProtocolFactory; fname : string); +begin + // try to read an existing request + if FileExists( fname + REQUEST_EXT) then begin + ProcessFile( protfact, fname); + ReadResponse( protfact, fname); + end; + + // create a new request and try to process + CreateRequest( protfact, fname); + ProcessFile( protfact, fname); + ReadResponse( protfact, fname); +end; + + +const + FILE_BINARY = 'pingpong.bin'; + FILE_JSON = 'pingpong.json'; +begin + try + Writeln( 'Delphi SkipTest '+IntToStr(Tskiptest_version_2Constants.SKIPTESTSERVICE_VERSION)+' using '+Thrift.Version); + + Writeln; + Writeln('Binary protocol'); + Test( TBinaryProtocolImpl.TFactory.Create, FILE_BINARY); + + Writeln; + Writeln('JSON protocol'); + Test( TJSONProtocolImpl.TFactory.Create, FILE_JSON); + + Writeln; + Writeln('Test completed without errors.'); + Writeln; + Write('Press ENTER to close ...'); Readln; + except + on E: Exception do + Writeln(E.ClassName, ': ', E.Message); + end; +end. + diff --git a/src/jaegertracing/thrift/lib/delphi/test/typeregistry/TestTypeRegistry.dpr b/src/jaegertracing/thrift/lib/delphi/test/typeregistry/TestTypeRegistry.dpr new file mode 100644 index 000000000..fd5e3dd4e --- /dev/null +++ b/src/jaegertracing/thrift/lib/delphi/test/typeregistry/TestTypeRegistry.dpr @@ -0,0 +1,91 @@ +(* + * 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 TestTypeRegistry; + +{$APPTYPE CONSOLE} + +uses + Classes, Windows, SysUtils, Generics.Collections, TypInfo, + Thrift in '..\..\src\Thrift.pas', + Thrift.Transport in '..\..\src\Thrift.Transport.pas', + Thrift.Exception in '..\..\src\Thrift.Exception.pas', + Thrift.Socket in '..\..\src\Thrift.Socket.pas', + Thrift.Protocol in '..\..\src\Thrift.Protocol.pas', + Thrift.Protocol.JSON in '..\..\src\Thrift.Protocol.JSON.pas', + Thrift.Collections in '..\..\src\Thrift.Collections.pas', + Thrift.Server in '..\..\src\Thrift.Server.pas', + Thrift.Utils in '..\..\src\Thrift.Utils.pas', + Thrift.Serializer in '..\..\src\Thrift.Serializer.pas', + Thrift.Stream in '..\..\src\Thrift.Stream.pas', + Thrift.WinHTTP in '..\..\src\Thrift.WinHTTP.pas', + Thrift.TypeRegistry in '..\..\src\Thrift.TypeRegistry.pas', + DebugProtoTest; + +type + Tester<T : IInterface> = class + public + class procedure Test; + end; + +class procedure Tester<T>.Test; +var instance : T; + name : string; +begin + instance := TypeRegistry.Construct<T>; + name := GetTypeName(TypeInfo(T)); + if instance <> nil + then Writeln( name, ' = ok') + else begin + Writeln( name, ' = failed'); + raise Exception.Create( 'Test with '+name+' failed!'); + end; +end; + +begin + Writeln('Testing ...'); + Tester<IDoubles>.Test; + Tester<IOneOfEach>.Test; + Tester<IBonk>.Test; + Tester<INesting>.Test; + Tester<IHolyMoley>.Test; + Tester<IBackwards>.Test; + Tester<IEmpty>.Test; + Tester<IWrapper>.Test; + Tester<IRandomStuff>.Test; + Tester<IBase64>.Test; + Tester<ICompactProtoTestStruct>.Test; + Tester<ISingleMapTestStruct>.Test; + Tester<IBlowUp>.Test; + Tester<IReverseOrderStruct>.Test; + Tester<IStructWithSomeEnum>.Test; + Tester<ITestUnion>.Test; + Tester<ITestUnionMinusStringField>.Test; + Tester<IComparableUnion>.Test; + Tester<IStructWithAUnion>.Test; + Tester<IPrimitiveThenStruct>.Test; + Tester<IStructWithASomemap>.Test; + Tester<IBigFieldIdStruct>.Test; + Tester<IBreaksRubyCompactProtocol>.Test; + Tester<ITupleProtocolTestStruct>.Test; + Writeln('Completed.'); + + +end. + |