diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000..412eeda --- /dev/null +++ b/.gitattributes @@ -0,0 +1,22 @@ +# Auto detect text files and perform LF normalization +* text=auto + +# Custom for Visual Studio +*.cs diff=csharp +*.sln merge=union +*.csproj merge=union +*.vbproj merge=union +*.fsproj merge=union +*.dbproj merge=union + +# Standard to msysgit +*.doc diff=astextplain +*.DOC diff=astextplain +*.docx diff=astextplain +*.DOCX diff=astextplain +*.dot diff=astextplain +*.DOT diff=astextplain +*.pdf diff=astextplain +*.PDF diff=astextplain +*.rtf diff=astextplain +*.RTF diff=astextplain diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..6042832 --- /dev/null +++ b/.gitignore @@ -0,0 +1,220 @@ +################# +## Eclipse +################# + +*.pydevproject +.project +.metadata +bin/ +tmp/ +*.tmp +*.bak +*.swp +*~.nib +local.properties +.classpath +.settings/ +.loadpath + +dcu/ +*.dproj +*.local +*.skincfg + +# External tool builders +.externalToolBuilders/ + +# Locally stored "Eclipse launch configurations" +*.launch + +# CDT-specific +.cproject + +# PDT-specific +.buildpath + + +################# +## Visual Studio +################# + +## Ignore Visual Studio temporary files, build results, and +## files generated by popular Visual Studio add-ons. + +# User-specific files +*.suo +*.user +*.sln.docstates + +# Build results + +[Dd]ebug/ +[Rr]elease/ +x64/ +build/ +[Bb]in/ +[Oo]bj/ + +# MSTest test Results +[Tt]est[Rr]esult*/ +[Bb]uild[Ll]og.* + +*_i.c +*_p.c +*.ilk +*.meta +*.obj +*.pch +*.pdb +*.pgc +*.pgd +*.rsp +*.sbr +*.tlb +*.tli +*.tlh +*.tmp +*.tmp_proj +*.log +*.vspscc +*.vssscc +.builds +*.pidb +*.log +*.scc + +# Visual C++ cache files +ipch/ +*.aps +*.ncb +*.opensdf +*.sdf +*.cachefile + +# Visual Studio profiler +*.psess +*.vsp +*.vspx + +# Guidance Automation Toolkit +*.gpState + +# ReSharper is a .NET coding add-in +_ReSharper*/ +*.[Rr]e[Ss]harper + +# TeamCity is a build add-in +_TeamCity* + +# DotCover is a Code Coverage Tool +*.dotCover + +# NCrunch +*.ncrunch* +.*crunch*.local.xml + +# Installshield output folder +[Ee]xpress/ + +# DocProject is a documentation generator add-in +DocProject/buildhelp/ +DocProject/Help/*.HxT +DocProject/Help/*.HxC +DocProject/Help/*.hhc +DocProject/Help/*.hhk +DocProject/Help/*.hhp +DocProject/Help/Html2 +DocProject/Help/html + +# Click-Once directory +publish/ + +# Publish Web Output +*.Publish.xml +*.pubxml + +# NuGet Packages Directory +## TODO: If you have NuGet Package Restore enabled, uncomment the next line +#packages/ + +# Windows Azure Build Output +csx +*.build.csdef + +# Windows Store app package directory +AppPackages/ + +# Others +sql/ +*.Cache +ClientBin/ +[Ss]tyle[Cc]op.* +~$* +*~ +*.dbmdl +*.[Pp]ublish.xml +*.pfx +*.publishsettings + +# RIA/Silverlight projects +Generated_Code/ + +# Backup & report files from converting an old project file to a newer +# Visual Studio version. Backup files are not needed, because we have git ;-) +_UpgradeReport_Files/ +Backup*/ +UpgradeLog*.XML +UpgradeLog*.htm + +# SQL Server files +App_Data/*.mdf +App_Data/*.ldf + +############# +## Windows detritus +############# + +# Windows image file caches +Thumbs.db +ehthumbs.db + +# Folder config file +Desktop.ini + +# Recycle Bin used on file shares +$RECYCLE.BIN/ + +# Mac crap +.DS_Store + + +############# +## Python +############# + +*.py[co] + +# Packages +*.egg +*.egg-info +dist/ +build/ +eggs/ +parts/ +var/ +sdist/ +develop-eggs/ +.installed.cfg + +# Installer logs +pip-log.txt + +# Unit test / coverage reports +.coverage +.tox + +#Translations +*.mo + +#Mr Developer +.mr.developer.cfg diff --git a/DUnit/NewLibrary_Intf.pas b/DUnit/NewLibrary_Intf.pas new file mode 100644 index 0000000..f1f9b40 --- /dev/null +++ b/DUnit/NewLibrary_Intf.pas @@ -0,0 +1,135 @@ +unit NewLibrary_Intf; + +{----------------------------------------------------------------------------} +{ This unit was automatically generated by the RemObjects SDK after reading } +{ the RODL file associated with this project . } +{ } +{ Do not modify this unit manually, or your changes will be lost when this } +{ unit is regenerated the next time you compile the project. } +{----------------------------------------------------------------------------} + +{$I RemObjects.inc} + +interface + +uses + {vcl:} Classes, TypInfo, + {RemObjects:} uROXMLIntf, uROClasses, uROClient, uROTypes, uROClientIntf; + +const + //RBK modification: storing timestamp of generation, to be able to check version mismatch between client and server + //RBK modification, done in: "\Lib\Componenten\RemObjects SDK for Delphi\Source\CodeGen\uRODLToPascalIntf.pas" + C_GenerateDateTime = '18-09-2013 15:29:06:712 by amussche'; + +const + { Library ID } + LibraryUID = '{37BBB078-915E-4B4D-B5CB-FD43C7359A58}'; + TargetNamespace = ''; + + { Service Interface ID's } + INewService_IID : TGUID = '{5C59475D-E65E-4634-998F-B2DE324E381B}'; + +type + TSeekOrigin = Classes.TSeekOrigin; // fake declaration + { Forward declarations } + INewService = interface; + + + { INewService } + INewService = interface + ['{5C59475D-E65E-4634-998F-B2DE324E381B}'] + function Sum(const a: Integer; const b: Integer): Integer; + function LongDurationIntermediateSocketIOResults(const aDuration_ms: Integer; const aSleep_ms: Integer): Integer; + end; + + { CoNewService } + CoNewService = class + class function Create(const aMessage: IROMessage; aTransportChannel: IROTransportChannel): INewService; + end; + + { TNewService_Proxy } + TNewService_Proxy = class(TROProxy, INewService) + protected + function __GetInterfaceName:string; override; + + function Sum(const a: Integer; const b: Integer): Integer; + function LongDurationIntermediateSocketIOResults(const aDuration_ms: Integer; const aSleep_ms: Integer): Integer; + end; + +implementation + +uses + {vcl:} SysUtils, + {RemObjects:} uROEventRepository, uROSerializer, uRORes; + +{ CoNewService } + +class function CoNewService.Create(const aMessage: IROMessage; aTransportChannel: IROTransportChannel): INewService; +begin + Result := TNewService_Proxy.Create(aMessage, aTransportChannel); +end; + +{ TNewService_Proxy } + +function TNewService_Proxy.__GetInterfaceName:string; +begin + Result := 'NewService'; +end; + +function TNewService_Proxy.Sum(const a: Integer; const b: Integer): Integer; +var + lMessage: IROMessage; + lTransportChannel: IROTransportChannel; +begin + lMessage := __GetMessage; + lTransportChannel := __TransportChannel; + try + lMessage.InitializeRequestMessage(lTransportChannel, 'NewLibrary', __InterfaceName, 'Sum'); + lMessage.Write('a', TypeInfo(Integer), a, []); + lMessage.Write('b', TypeInfo(Integer), b, []); + lMessage.Finalize; + + lTransportChannel.Dispatch(lMessage); + + lMessage.Read('Result', TypeInfo(Integer), Result, []); + finally + lMessage.UnsetAttributes(lTransportChannel); + lMessage.FreeStream; + lMessage := nil; + lTransportChannel := nil; + end; +end; + +function TNewService_Proxy.LongDurationIntermediateSocketIOResults(const aDuration_ms: Integer; const aSleep_ms: Integer): Integer; +var + lMessage: IROMessage; + lTransportChannel: IROTransportChannel; +begin + lMessage := __GetMessage; + lTransportChannel := __TransportChannel; + try + lMessage.InitializeRequestMessage(lTransportChannel, 'NewLibrary', __InterfaceName, 'LongDurationIntermediateSocketIOResults'); + lMessage.Write('aDuration_ms', TypeInfo(Integer), aDuration_ms, []); + lMessage.Write('aSleep_ms', TypeInfo(Integer), aSleep_ms, []); + lMessage.Finalize; + + lTransportChannel.Dispatch(lMessage); + + lMessage.Read('Result', TypeInfo(Integer), Result, []); + finally + lMessage.UnsetAttributes(lTransportChannel); + lMessage.FreeStream; + lMessage := nil; + lTransportChannel := nil; + end; +end; + +initialization + RegisterProxyClass(INewService_IID, TNewService_Proxy); + + +finalization + UnregisterProxyClass(INewService_IID); + + +end. diff --git a/DUnit/NewLibrary_Invk.pas b/DUnit/NewLibrary_Invk.pas new file mode 100644 index 0000000..52f6a09 --- /dev/null +++ b/DUnit/NewLibrary_Invk.pas @@ -0,0 +1,90 @@ +unit NewLibrary_Invk; + +{----------------------------------------------------------------------------} +{ This unit was automatically generated by the RemObjects SDK after reading } +{ the RODL file associated with this project . } +{ } +{ Do not modify this unit manually, or your changes will be lost when this } +{ unit is regenerated the next time you compile the project. } +{----------------------------------------------------------------------------} + +{$I RemObjects.inc} + +interface + +uses + {vcl:} Classes, + {RemObjects:} uROXMLIntf, uROServer, uROServerIntf, uROTypes, uROClientIntf, + {Generated:} NewLibrary_Intf; + +type + TSeekOrigin = Classes.TSeekOrigin; // fake declaration + TNewService_Invoker = class(TROInvoker) + private + protected + public + constructor Create; override; + published + procedure Invoke_Sum(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions); + procedure Invoke_LongDurationIntermediateSocketIOResults(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions); + end; + +implementation + +uses + {RemObjects:} uRORes, uROClient; + +{ TNewService_Invoker } + +constructor TNewService_Invoker.Create; +begin + inherited Create; + FAbstract := False; +end; + +procedure TNewService_Invoker.Invoke_Sum(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions); +{ function Sum(const a: Integer; const b: Integer): Integer; } +var + a: Integer; + b: Integer; + lResult: Integer; +begin + try + __Message.Read('a', TypeInfo(Integer), a, []); + __Message.Read('b', TypeInfo(Integer), b, []); + + lResult := (__Instance as INewService).Sum(a, b); + + __Message.InitializeResponseMessage(__Transport, 'NewLibrary', 'NewService', 'SumResponse'); + __Message.Write('Result', TypeInfo(Integer), lResult, []); + __Message.Finalize; + __Message.UnsetAttributes(__Transport); + + finally + end; +end; + +procedure TNewService_Invoker.Invoke_LongDurationIntermediateSocketIOResults(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions); +{ function LongDurationIntermediateSocketIOResults(const aDuration_ms: Integer; const aSleep_ms: Integer): Integer; } +var + aDuration_ms: Integer; + aSleep_ms: Integer; + lResult: Integer; +begin + try + __Message.Read('aDuration_ms', TypeInfo(Integer), aDuration_ms, []); + __Message.Read('aSleep_ms', TypeInfo(Integer), aSleep_ms, []); + + lResult := (__Instance as INewService).LongDurationIntermediateSocketIOResults(aDuration_ms, aSleep_ms); + + __Message.InitializeResponseMessage(__Transport, 'NewLibrary', 'NewService', 'LongDurationIntermediateSocketIOResultsResponse'); + __Message.Write('Result', TypeInfo(Integer), lResult, []); + __Message.Finalize; + __Message.UnsetAttributes(__Transport); + + finally + end; +end; + +initialization +end. diff --git a/DUnit/NewService_Impl.pas b/DUnit/NewService_Impl.pas new file mode 100644 index 0000000..1fcd535 --- /dev/null +++ b/DUnit/NewService_Impl.pas @@ -0,0 +1,92 @@ +unit NewService_Impl; + +{----------------------------------------------------------------------------} +{ This unit was automatically generated by the RemObjects SDK after reading } +{ the RODL file associated with this project . } +{ } +{ This is where you are supposed to code the implementation of your objects. } +{----------------------------------------------------------------------------} + +{$I RemObjects.inc} + +interface + +uses + {vcl:} Classes, SysUtils, + {RemObjects:} uROXMLIntf, uROClientIntf, uROTypes, uROServer, uROServerIntf, uROSessions, + {Required:} uRORemoteDataModule, + {Generated:} NewLibrary_Intf; + +type + { TNewService } + TNewService = class(TRORemoteDataModule, + INewService) + private + protected + { INewService methods } + function Sum(const a: Integer; const b: Integer): Integer; + function LongDurationIntermediateSocketIOResults(const aDuration_ms: Integer; const aSleep_ms: Integer): Integer; + end; + +implementation + +{$IFDEF DELPHIXE2UP} +{%CLASSGROUP 'System.Classes.TPersistent'} +{$ENDIF} + +{$IFNDEF FPC} + {$R *.dfm} +{$ELSE} + {$R *.lfm} +{$ENDIF} +uses + {Generated:} NewLibrary_Invk, DateUtils, uROHTTPWebsocketServer, + IdServerSocketIOHandling; + +procedure Create_NewService(out anInstance : IUnknown); +begin + anInstance := TNewService.Create(nil); +end; + +var + fClassFactory: IROClassFactory; +{ TNewService } + +function TNewService.LongDurationIntermediateSocketIOResults(const aDuration_ms, + aSleep_ms: Integer): Integer; +var + tstart: TDateTime; + ctx: TROTransportContext; + iCounter: Integer; +begin + tstart := Now; + iCounter := 0; + while MilliSecondsBetween(Now, tstart) < aDuration_ms do + begin + //send intermediate (!) response to client back (for progress etc) + Assert(Transport is TROTransportContext); + ctx := Transport as TROTransportContext; + Inc(iCounter); + if ctx.Context.IsSocketIO then + ctx.Context.SocketIO.SendTo(ctx.Context, IntToStr(iCounter)); + + Sleep(aSleep_ms); + end; + + Result := iCounter; +end; + +function TNewService.Sum(const a, b: Integer): Integer; +begin + Result := a + b; +end; + +initialization + fClassFactory := TROClassFactory.Create('NewService', {$IFDEF FPC}@{$ENDIF}Create_NewService, TNewService_Invoker); + // RegisterForZeroConf(fClassFactory,'_NewService_rosdk._tcp.'); + +finalization + UnRegisterClassFactory(fClassFactory); + fClassFactory := nil; + +end. diff --git a/DUnit/UnitTestWebsockets.dpr b/DUnit/UnitTestWebsockets.dpr new file mode 100644 index 0000000..dec8666 --- /dev/null +++ b/DUnit/UnitTestWebsockets.dpr @@ -0,0 +1,31 @@ +program UnitTestWebsockets; +{ + + Delphi DUnit Test Project + ------------------------- + This project contains the DUnit test framework and the GUI/Console test runners. + Add "CONSOLE_TESTRUNNER" to the conditional defines entry in the project options + to use the console test runner. Otherwise the GUI test runner will be used by + default. + +} + +{$IFDEF CONSOLE_TESTRUNNER} +{$APPTYPE CONSOLE} +{$ENDIF} + +{$R *.RES} + +uses + DUnitTestRunner, + TestFramework, + mtTestWebSockets in 'mtTestWebSockets.pas', + IdHTTPWebsocketClient in '..\IdHTTPWebsocketClient.pas', + superobject in '..\superobject\superobject.pas'; + +begin + RegisterTest(TTestWebSockets.Suite); + + DUnitTestRunner.RunRegisteredTests; +end. + diff --git a/DUnit/UnitTestWebsockets.res b/DUnit/UnitTestWebsockets.res new file mode 100644 index 0000000..7435995 Binary files /dev/null and b/DUnit/UnitTestWebsockets.res differ diff --git a/DUnit/mtTestROWebSockets.pas b/DUnit/mtTestROWebSockets.pas new file mode 100644 index 0000000..2b782bf --- /dev/null +++ b/DUnit/mtTestROWebSockets.pas @@ -0,0 +1,292 @@ +unit mtTestROWebSockets; + +interface + +uses + TestFramework, NewLibrary_Intf, + uROIndyHTTPWebsocketChannel, uROHTTPWebsocketServer, + uROJSONMessage, uRORemoteService, IdHTTPWebsocketClient, + IdServerWebsocketContext; + +type + TTextCallback = reference to procedure(aText: string); + + TTestROWebSockets = class(TTestCase) + private + class var ROIndyHTTPWebsocketServer1: TROIndyHTTPWebsocketServer; + class var ROIndyHTTPWebsocketChannel1: TROIndyHTTPWebsocketChannel; + class var ROJSONMessage1: TROJSONMessage; + class var RORemoteService1: TRORemoteService; + protected + FLastSocketIOMsg: string; + public + procedure SetUp; override; + procedure TearDown; override; + published + procedure CreateObjects; + + procedure StartRO; + procedure TestSum; + procedure TestIntermediateProgress; + + procedure DestroyObjects; + end; + +implementation + +uses + NewService_Impl, SysUtils, IdSocketIOHandling, superobject; + +{ TTestROWebSockets } + +procedure TTestROWebSockets.SetUp; +begin + inherited; +end; + +//procedure TTestROWebSockets.SocketIOMsgClient( +// const AClient: TIdHTTPWebsocketClient; const aText: string; aMsgNr: Integer); +//begin +// FLastSocketIOMsg := aText; +// if Assigned(FOnSocketIOMsg) then +// FOnSocketIOMsg(aText); +//end; + +//procedure TTestROWebSockets.SocketIOMsgServer( +// const AContext: TIdServerWSContext; const aText: string; aMsgNr: Integer; +// aHasCallback: Boolean); +//begin +// FLastSocketIOMsg := aText; +// if aHasCallback then +// AContext.IOHandler.WriteSocketIOResult(aMsgNr, '', aText); +//end; + +procedure TTestROWebSockets.TearDown; +begin + inherited; +end; + +procedure TTestROWebSockets.CreateObjects; +begin + ROIndyHTTPWebsocketServer1 := TROIndyHTTPWebsocketServer.Create(nil); + ROIndyHTTPWebsocketServer1.Port := 8099; + ROIndyHTTPWebsocketServer1.KeepAlive := True; + ROIndyHTTPWebsocketServer1.DisableNagle := True; + //SendClientAccessPolicyXml = captAllowAll + //SendCrossOriginHeader = True + + ROIndyHTTPWebsocketChannel1 := TROIndyHTTPWebsocketChannel.Create(nil); + ROIndyHTTPWebsocketChannel1.Port := 8099; + ROIndyHTTPWebsocketChannel1.Host := '127.0.0.1'; + ROIndyHTTPWebsocketChannel1.IndyClient.SocketIOCompatible := True; + + ROJSONMessage1 := TROJSONMessage.Create(nil); + + ROIndyHTTPWebsocketServer1.Dispatchers.Add; + ROIndyHTTPWebsocketServer1.Dispatchers[0].Message := ROJSONMessage1; + ROIndyHTTPWebsocketServer1.Dispatchers[0].Enabled := True; + + RORemoteService1 := TRORemoteService.Create(nil); + RORemoteService1.Channel := ROIndyHTTPWebsocketChannel1; + RORemoteService1.Message := ROJSONMessage1; +end; + +procedure TTestROWebSockets.DestroyObjects; +begin + ROIndyHTTPWebsocketServer1.Free; + + RORemoteService1.Free; + ROIndyHTTPWebsocketChannel1.Free; + ROJSONMessage1.Free; +end; + +procedure TTestROWebSockets.StartRO; +begin + ROIndyHTTPWebsocketServer1.Active := True; + ROIndyHTTPWebsocketChannel1.IndyClient.Connect; +end; + +procedure TTestROWebSockets.TestIntermediateProgress; +var + iresult: Integer; + iprevious: Integer; +begin +// ROIndyHTTPWebsocketChannel1.IndyClient.OnSocketIOMsg := SocketIOMsgClient; + ROIndyHTTPWebsocketChannel1.IndyClient.SocketIO.OnSocketIOMsg := + procedure(const ASocket: ISocketIOContext; const aText: string; const aCallback: TSocketIOCallbackObj) + var icount: Integer; + begin + FLastSocketIOMsg := aText; + + icount := StrToInt(aText); + //elke keer moet counter met 1 opgehoogd worden! + //see NewService_Impl + CheckEquals(iprevious+1, icount); + iprevious := icount; + end; + + FLastSocketIOMsg := ''; + iprevious := 0; +// FOnSocketIOMsg := +// procedure(aText: string) +// var icount: Integer; +// begin +// icount := StrToInt(aText); +// elke keer moet counter met 1 opgehoogd worden! +// see NewService_Impl +// CheckEquals(iprevious+1, icount); +// iprevious := icount; +// end; + + iresult := (RORemoteService1 as INewService).LongDurationIntermediateSocketIOResults( + 2*1000, 100); + //result = counter, dus moet overeenkomen met laatste callback + CheckEquals(iprevious, iresult); +end; + +procedure TTestROWebSockets.TestSocketIOCallback; +var + received: string; +begin + //* client to server */ + received := ''; + ROIndyHTTPWebsocketServer1.SocketIO.OnEvent('TEST_EVENT', + procedure(const ASocket: ISocketIOContext; const aArgument: TSuperArray; const aCallbackObj: TSocketIOCallbackObj) + begin + received := aArgument.ToJson; + end); + + if not ROIndyHTTPWebsocketChannel1.IndyClient.Connected then + begin + ROIndyHTTPWebsocketChannel1.IndyClient.Connect; + ROIndyHTTPWebsocketChannel1.IndyClient.UpgradeToWebsocket; + end; + ROIndyHTTPWebsocketChannel1.IndyClient.SocketIO.Emit('TEST_EVENT', + SO('test event'), nil); + + MaxWait( + function: Boolean + begin + Result := received <> ''; + end, 10 * 1000); + received := StringReplace(received, #13#10, '', [rfReplaceAll]); + CheckEqualsString('["test event"]', received); + + //* server to client */ + received := ''; + ROIndyHTTPWebsocketChannel1.IndyClient.SocketIO.OnEvent('TEST_EVENT', + procedure(const ASocket: ISocketIOContext; const aArgument: TSuperArray; const aCallbackObj: TSocketIOCallbackObj) + begin + received := aArgument.ToJson; + end); + ROIndyHTTPWebsocketServer1.SocketIO.EmitEventToAll('TEST_EVENT', + SO('test event'), nil); + MaxWait( + function: Boolean + begin + Result := received <> ''; + end, 10 * 1000); + received := StringReplace(received, #13#10, '', [rfReplaceAll]); + CheckEqualsString('["test event"]', received); +end; + +procedure TTestROWebSockets.TestSocketIOError; +begin + //disconnect: mag geen AV's daarna geven! + ROIndyHTTPWebsocketChannel1.IndyClient.Disconnect(False); + ROIndyHTTPWebsocketChannel1.IndyClient.Connect; + ROIndyHTTPWebsocketChannel1.IndyClient.UpgradeToWebsocket; + + //* client to server */ + FLastSocketIOMsg := ''; + ROIndyHTTPWebsocketServer1.SocketIO.OnSocketIOMsg := + procedure(const ASocket: ISocketIOContext; const aText: string; const aCallback: TSocketIOCallbackObj) + begin + Abort; + end; + ROIndyHTTPWebsocketChannel1.IndyClient.SocketIO.Send('test message', + procedure(const ASocket: ISocketIOContext; const aJSON: ISuperObject; const aCallback: TSocketIOCallbackObj) + begin + FLastSocketIOMsg := aJSON.AsString; + end); + MaxWait( + function: Boolean + begin + Result := FLastSocketIOMsg <> ''; + end, 10 * 1000); + CheckEquals('[{"Error":{"Message":"Operation aborted","Type":"EAbort"}}]', FLastSocketIOMsg); + + FLastSocketIOMsg := ''; + ROIndyHTTPWebsocketChannel1.IndyClient.SocketIO.Send('test message', + procedure(const ASocket: ISocketIOContext; const aJSON: ISuperObject; const aCallback: TSocketIOCallbackObj) + begin + Assert(False, 'should go to error handling callback'); + FLastSocketIOMsg := 'error'; + end, + procedure(const ASocket: ISocketIOContext; const aErrorClass, aErrorMessage: string) + begin + FLastSocketIOMsg := aErrorMessage; + end); + MaxWait( + function: Boolean + begin + Result := FLastSocketIOMsg <> ''; + end, 10 * 1000); + CheckEquals('Operation aborted', FLastSocketIOMsg); +end; + +procedure TTestROWebSockets.TestSocketIOMsg; +begin + //disconnect: mag geen AV's daarna geven! + ROIndyHTTPWebsocketChannel1.IndyClient.Disconnect(False); + ROIndyHTTPWebsocketChannel1.IndyClient.Connect; + ROIndyHTTPWebsocketChannel1.IndyClient.UpgradeToWebsocket; + + //* client to server */ + FLastSocketIOMsg := ''; + ROIndyHTTPWebsocketServer1.SocketIO.OnSocketIOMsg := + procedure(const ASocket: ISocketIOContext; const aText: string; const aCallback: TSocketIOCallbackObj) + begin + FLastSocketIOMsg := aText; + end; + ROIndyHTTPWebsocketChannel1.IndyClient.SocketIO.Send('test message'); + MaxWait( + function: Boolean + begin + Result := FLastSocketIOMsg <> ''; + end, 10 * 1000); + CheckEquals('test message', FLastSocketIOMsg); + + //* server to client */ + FLastSocketIOMsg := ''; + ROIndyHTTPWebsocketChannel1.IndyClient.SocketIO.OnSocketIOMsg := + procedure(const ASocket: ISocketIOContext; const aText: string; const aCallback: TSocketIOCallbackObj) + begin + FLastSocketIOMsg := aText; + end; + if ROIndyHTTPWebsocketServer1.SocketIO.SendToAll('test message') = 0 then + Check(False, 'nothing send'); + MaxWait( + function: Boolean + begin + Result := FLastSocketIOMsg <> ''; + end, 10 * 1000); + CheckEquals('test message', FLastSocketIOMsg); + + //disconnect: mag geen AV's daarna geven! + ROIndyHTTPWebsocketChannel1.IndyClient.Disconnect(False); + ROIndyHTTPWebsocketChannel1.IndyClient.Connect; + ROIndyHTTPWebsocketChannel1.IndyClient.UpgradeToWebsocket; + ROIndyHTTPWebsocketChannel1.IndyClient.SocketIO.Send('test message'); +end; + +procedure TTestROWebSockets.TestSum; +var + iresult: Integer; +begin + iresult := (RORemoteService1 as INewService).Sum(1,2); + CheckEquals(1+2, iresult); +end; + +end. + diff --git a/DUnit/mtTestWebSockets.pas b/DUnit/mtTestWebSockets.pas new file mode 100644 index 0000000..57d5ebe --- /dev/null +++ b/DUnit/mtTestWebSockets.pas @@ -0,0 +1,234 @@ +unit mtTestWebSockets; + +interface + +uses + TestFramework, + IdHTTPWebsocketClient, IdServerWebsocketContext, IdWebsocketServer; + +type + TTextCallback = reference to procedure(aText: string); + + TTestWebSockets = class(TTestCase) + private + class var IndyHTTPWebsocketServer1: TIdWebsocketServer; + class var IndyHTTPWebsocketClient1: TIdHTTPWebsocketClient; + protected + FLastSocketIOMsg: string; + public + procedure SetUp; override; + procedure TearDown; override; + published + procedure CreateObjects; + + procedure StartServer; + + procedure TestSocketIOMsg; + procedure TestSocketIOCallback; + procedure TestSocketIOError; + + procedure DestroyObjects; + end; + + TBooleanFunction = reference to function: Boolean; + function MaxWait(aProc: TBooleanFunction; aMaxWait_msec: Integer): Boolean; + +implementation + +uses + Windows, Forms, DateUtils, SysUtils, Classes, + IdSocketIOHandling, superobject; + +function MaxWait(aProc: TBooleanFunction; aMaxWait_msec: Integer): Boolean; +var + tStart: TDateTime; +begin + tStart := Now; + + Result := aProc; + while not Result and + (MilliSecondsBetween(Now, tStart) <= aMaxWait_msec) do + begin + Sleep(10); + if GetCurrentThreadId = MainThreadID then + CheckSynchronize(10); + Result := aProc; + end; +end; + +{ TTestWebSockets } + +procedure TTestWebSockets.SetUp; +begin + inherited; +end; + +procedure TTestWebSockets.TearDown; +begin + inherited; +end; + +procedure TTestWebSockets.CreateObjects; +begin + IndyHTTPWebsocketServer1 := TIdWebsocketServer.Create(nil); + IndyHTTPWebsocketServer1.DefaultPort := 8099; + IndyHTTPWebsocketServer1.KeepAlive := True; + //IndyHTTPWebsocketServer1.DisableNagle := True; + //SendClientAccessPolicyXml = captAllowAll + //SendCrossOriginHeader = True + + IndyHTTPWebsocketClient1 := TIdHTTPWebsocketClient.Create(nil); + IndyHTTPWebsocketClient1.Host := 'localhost'; + IndyHTTPWebsocketClient1.Port := 8099; + IndyHTTPWebsocketClient1.SocketIOCompatible := True; +end; + +procedure TTestWebSockets.DestroyObjects; +begin + IndyHTTPWebsocketClient1.Free; + IndyHTTPWebsocketServer1.Free; +end; + +procedure TTestWebSockets.StartServer; +begin + IndyHTTPWebsocketServer1.Active := True; +end; + +procedure TTestWebSockets.TestSocketIOCallback; +var + received: string; +begin + //* client to server */ + received := ''; + IndyHTTPWebsocketServer1.SocketIO.OnEvent('TEST_EVENT', + procedure(const ASocket: ISocketIOContext; const aArgument: TSuperArray; const aCallbackObj: TSocketIOCallbackObj) + begin + received := aArgument.ToJson; + end); + + if not IndyHTTPWebsocketClient1.Connected then + begin + IndyHTTPWebsocketClient1.Connect; + IndyHTTPWebsocketClient1.UpgradeToWebsocket; + end; + IndyHTTPWebsocketClient1.SocketIO.Emit('TEST_EVENT', + SO('test event'), nil); + + MaxWait( + function: Boolean + begin + Result := received <> ''; + end, 10 * 1000); + received := StringReplace(received, #13#10, '', [rfReplaceAll]); + CheckEqualsString('["test event"]', received); + + //* server to client */ + received := ''; + IndyHTTPWebsocketClient1.SocketIO.OnEvent('TEST_EVENT', + procedure(const ASocket: ISocketIOContext; const aArgument: TSuperArray; const aCallbackObj: TSocketIOCallbackObj) + begin + received := aArgument.ToJson; + end); + IndyHTTPWebsocketServer1.SocketIO.EmitEventToAll('TEST_EVENT', + SO('test event'), nil); + MaxWait( + function: Boolean + begin + Result := received <> ''; + end, 10 * 1000); + received := StringReplace(received, #13#10, '', [rfReplaceAll]); + CheckEqualsString('["test event"]', received); +end; + +procedure TTestWebSockets.TestSocketIOError; +begin + //disconnect: mag geen AV's daarna geven! + IndyHTTPWebsocketClient1.Disconnect(False); + IndyHTTPWebsocketClient1.Connect; + IndyHTTPWebsocketClient1.UpgradeToWebsocket; + + //* client to server */ + FLastSocketIOMsg := ''; + IndyHTTPWebsocketServer1.SocketIO.OnSocketIOMsg := + procedure(const ASocket: ISocketIOContext; const aText: string; const aCallback: TSocketIOCallbackObj) + begin + Abort; + end; + IndyHTTPWebsocketClient1.SocketIO.Send('test message', + procedure(const ASocket: ISocketIOContext; const aJSON: ISuperObject; const aCallback: TSocketIOCallbackObj) + begin + FLastSocketIOMsg := aJSON.AsString; + end); + MaxWait( + function: Boolean + begin + Result := FLastSocketIOMsg <> ''; + end, 10 * 1000); + CheckEquals('[{"Error":{"Message":"Operation aborted","Type":"EAbort"}}]', FLastSocketIOMsg); + + FLastSocketIOMsg := ''; + IndyHTTPWebsocketClient1.SocketIO.Send('test message', + procedure(const ASocket: ISocketIOContext; const aJSON: ISuperObject; const aCallback: TSocketIOCallbackObj) + begin + Assert(False, 'should go to error handling callback'); + FLastSocketIOMsg := 'error'; + end, + procedure(const ASocket: ISocketIOContext; const aErrorClass, aErrorMessage: string) + begin + FLastSocketIOMsg := aErrorMessage; + end); + MaxWait( + function: Boolean + begin + Result := FLastSocketIOMsg <> ''; + end, 10 * 1000); + CheckEquals('Operation aborted', FLastSocketIOMsg); +end; + +procedure TTestWebSockets.TestSocketIOMsg; +begin + //disconnect: mag geen AV's daarna geven! + IndyHTTPWebsocketClient1.Disconnect(False); + IndyHTTPWebsocketClient1.Connect; + IndyHTTPWebsocketClient1.UpgradeToWebsocket; + + //* client to server */ + FLastSocketIOMsg := ''; + IndyHTTPWebsocketServer1.SocketIO.OnSocketIOMsg := + procedure(const ASocket: ISocketIOContext; const aText: string; const aCallback: TSocketIOCallbackObj) + begin + FLastSocketIOMsg := aText; + end; + IndyHTTPWebsocketClient1.SocketIO.Send('test message'); + MaxWait( + function: Boolean + begin + Result := FLastSocketIOMsg <> ''; + end, 10 * 1000); + CheckEquals('test message', FLastSocketIOMsg); + + //* server to client */ + FLastSocketIOMsg := ''; + IndyHTTPWebsocketClient1.SocketIO.OnSocketIOMsg := + procedure(const ASocket: ISocketIOContext; const aText: string; const aCallback: TSocketIOCallbackObj) + begin + FLastSocketIOMsg := aText; + end; + if IndyHTTPWebsocketServer1.SocketIO.SendToAll('test message') = 0 then + Check(False, 'nothing send'); + MaxWait( + function: Boolean + begin + Result := FLastSocketIOMsg <> ''; + end, 10 * 1000); + CheckEquals('test message', FLastSocketIOMsg); + + //disconnect: mag geen AV's daarna geven! + IndyHTTPWebsocketClient1.Disconnect(False); + IndyHTTPWebsocketClient1.Connect; + IndyHTTPWebsocketClient1.UpgradeToWebsocket; + IndyHTTPWebsocketClient1.SocketIO.Send('test message'); +end; + +end. + diff --git a/IdHTTPWebsocketClient.pas b/IdHTTPWebsocketClient.pas index efb0c5e..c706132 100644 --- a/IdHTTPWebsocketClient.pas +++ b/IdHTTPWebsocketClient.pas @@ -4,7 +4,13 @@ interface uses Classes, - IdHTTP, IdHashSHA1, IdIOHandler, + IdHTTP, + {$IF CompilerVersion <= 21.0} //D2010 + IdHashSHA1, + {$else} + IdHashSHA, //XE3 etc + {$IFEND} + IdIOHandler, IdIOHandlerWebsocket, ExtCtrls, IdWinsock2, Generics.Collections, SyncObjs, IdSocketIOHandling; @@ -147,8 +153,7 @@ implementation uses IdCoderMIME, SysUtils, Math, IdException, IdStackConsts, IdStack, - IdStackBSDBase, IdGlobal, Windows, StrUtils, mcBaseNamedThread, - mcFinalizationHelper; + IdStackBSDBase, IdGlobal, Windows, StrUtils; //type // TAnonymousThread = class(TThread) @@ -187,6 +192,7 @@ begin FHash := TIdHashSHA1.Create; IOHandler := TIdIOHandlerWebsocket.Create(nil); + IOHandler.UseNagle := False; ManagedIOHandler := True; FSocketIO := TIdSocketIOHandling_Ext.Create; @@ -216,19 +222,16 @@ end; procedure TIdHTTPWebsocketClient.AsyncDispatchEvent(const aEvent: string); begin - if FSocketIOCompatible then - FSocketIO.ProcessSocketIORequest(FSocketIOContext as TSocketIOContext, aEvent) - else - begin - if not Assigned(OnTextData) then Exit; - //events during dispatch? channel is busy so offload event dispatching to different thread! - TIdWebsocketDispatchThread.Instance.QueueEvent( - procedure - begin - if Assigned(OnTextData) then - OnTextData(aEvent); - end); - end; + //if not Assigned(OnTextData) then Exit; + //events during dispatch? channel is busy so offload event dispatching to different thread! + TIdWebsocketDispatchThread.Instance.QueueEvent( + procedure + begin + if FSocketIOCompatible then + FSocketIO.ProcessSocketIORequest(FSocketIOContext as TSocketIOContext, aEvent) + else if Assigned(OnTextData) then + OnTextData(aEvent); + end); end; destructor TIdHTTPWebsocketClient.Destroy; @@ -467,6 +470,10 @@ begin CheckForGracefulDisconnect(True); CheckConnected; Assert(Self.Connected); + + if Response.ResponseCode = 0 then + Response.ResponseText := Response.ResponseText; + if Response.ResponseCode <> 200{ok} then begin aFailedReason := Format('Error while upgrading: "%d: %s"',[ResponseCode, ResponseText]); @@ -872,7 +879,7 @@ begin try //already exists? if l.IndexOf(aChannel) >= 0 then Exit; - + Assert(l.Count < 64, 'Max 64 connections can be handled by one read thread!'); //due to restrictions of the "select" API l.Add(aChannel); @@ -895,9 +902,11 @@ end; procedure TIdWebsocketMultiReadThread.BreakSelectWait; var - iResult: Integer; + //iResult: Integer; LAddr: TSockAddrIn6; begin + if FTempHandle = 0 then Exit; + FillChar(LAddr, SizeOf(LAddr), 0); //Id_IPv4 with PSOCKADDR(@LAddr)^ do @@ -915,17 +924,19 @@ begin //The only(?) other possibility is to make a "socket pair" and send a byte to it, //but this requires a dynamic server socket (which can trigger a firewall //exception/question popup in WindowsXP+) - iResult := IdWinsock2.connect(FTempHandle, PSOCKADDR(@LAddr), SIZE_TSOCKADDRIN); + //iResult := + IdWinsock2.connect(FTempHandle, PSOCKADDR(@LAddr), SIZE_TSOCKADDRIN); //non blocking socket, so will always result in "would block"! - if (iResult <> Id_SOCKET_ERROR) or - ( (GStack <> nil) and (GStack.WSGetLastError <> WSAEWOULDBLOCK) ) - then - GStack.CheckForSocketError(iResult); +// if (iResult <> Id_SOCKET_ERROR) or +// ( (GStack <> nil) and (GStack.WSGetLastError <> WSAEWOULDBLOCK) ) +// then +// GStack.CheckForSocketError(iResult); end; destructor TIdWebsocketMultiReadThread.Destroy; begin IdWinsock2.closesocket(FTempHandle); + FTempHandle := 0; FChannels.Free; inherited; end; @@ -951,7 +962,7 @@ var iResult: Integer; begin if GStack = nil then Exit; //finalized? - + //alloc socket FTempHandle := GStack.NewSocketHandle(Id_SOCK_STREAM, Id_IPPROTO_IP, Id_IPv4, False); Assert(FTempHandle <> Id_INVALID_SOCKET); @@ -963,8 +974,7 @@ end; class function TIdWebsocketMultiReadThread.Instance: TIdWebsocketMultiReadThread; begin - if (FInstance = nil) and - not TFinalizationHelper.ApplicationIsTerminating then + if (FInstance = nil) then begin FInstance := TIdWebsocketMultiReadThread.Create(True); FInstance.Start; @@ -1033,7 +1043,7 @@ begin //ignore error during wait: socket disconnected etc Exit; - if Terminated then Exit; + if Terminated then Exit; //some data? if (iResult > 0) then @@ -1126,6 +1136,7 @@ begin FPendingBreak := False; IdWinsock2.closesocket(FTempHandle); + FTempHandle := 0; InitSpecialEventSocket; end; @@ -1203,8 +1214,16 @@ class function TIdWebsocketDispatchThread.Instance: TIdWebsocketDispatchThread; begin if FInstance = nil then begin - FInstance := TIdWebsocketDispatchThread.Create(True); - FInstance.Start; + GlobalNameSpace.BeginWrite; + try + if FInstance = nil then + begin + FInstance := TIdWebsocketDispatchThread.Create(True); + FInstance.Start; + end; + finally + GlobalNameSpace.EndWrite; + end; end; Result := FInstance; end; @@ -1231,7 +1250,8 @@ finalization if TIdWebsocketMultiReadThread.FInstance <> nil then begin TIdWebsocketMultiReadThread.Instance.Terminate; - TBaseNamedThread.WaitForThread(TIdWebsocketMultiReadThread.Instance, 5 * 1000); + TIdWebsocketMultiReadThread.Instance.WaitFor; +// TBaseNamedThread.WaitForThread(TIdWebsocketMultiReadThread.Instance, 5 * 1000); TIdWebsocketMultiReadThread.RemoveInstance; end; diff --git a/IdIOHandlerWebsocket.pas b/IdIOHandlerWebsocket.pas index 300a24c..da82348 100644 --- a/IdIOHandlerWebsocket.pas +++ b/IdIOHandlerWebsocket.pas @@ -1,398 +1,404 @@ -unit IdIOHandlerWebsocket; - -//The WebSocket Protocol, RFC 6455 -//http://datatracker.ietf.org/doc/rfc6455/?include_text=1 - -interface - -uses - Classes, - IdIOHandlerStack, IdGlobal, IdException, IdBuffer, SyncObjs, - Generics.Collections; - -type - TWSDataType = (wdtText, wdtBinary); - TWSDataCode = (wdcNone, wdcContinuation, wdcText, wdcBinary, wdcClose, wdcPing, wdcPong); - TWSExtensionBit = (webBit1, webBit2, webBit3); - TWSExtensionBits = set of TWSExtensionBit; - - TIdIOHandlerWebsocket = class; - EIdWebSocketHandleError = class(EIdSocketHandleError); - - TIdIOHandlerWebsocket = class(TIdIOHandlerStack) - private - FIsServerSide: Boolean; - FBusyUpgrading: Boolean; - FIsWebsocket: Boolean; - FWSInputBuffer: TIdBuffer; - FExtensionBits: TWSExtensionBits; - FLock: TCriticalSection; - FCloseReason: string; - FCloseCode: Integer; - FClosing: Boolean; - protected - FMessageStream: TMemoryStream; - FWriteTextToTarget: Boolean; - FCloseCodeSend: Boolean; - - function InternalReadDataFromSource(var VBuffer: TIdBytes): Integer; - function ReadDataFromSource(var VBuffer: TIdBytes): Integer; override; - function WriteDataToTarget (const ABuffer: TIdBytes; const AOffset, ALength: Integer): Integer; override; - - function ReadFrame(out aFIN, aRSV1, aRSV2, aRSV3: boolean; out aDataCode: TWSDataCode; out aData: TIdBytes): Integer; - function ReadMessage(var aBuffer: TIdBytes; out aDataCode: TWSDataCode): Integer; - public - function WriteData(aData: TIdBytes; aType: TWSDataCode; - aFIN: boolean = true; aRSV1: boolean = false; aRSV2: boolean = false; aRSV3: boolean = false): integer; - property BusyUpgrading : Boolean read FBusyUpgrading write FBusyUpgrading; - property IsWebsocket : Boolean read FIsWebsocket write FIsWebsocket; - property IsServerSide : Boolean read FIsServerSide write FIsServerSide; - property ClientExtensionBits : TWSExtensionBits read FExtensionBits write FExtensionBits; - public - procedure AfterConstruction;override; - destructor Destroy; override; - - procedure Lock; - procedure Unlock; - function TryLock: Boolean; - - procedure Close; override; - property Closing : Boolean read FClosing; - property CloseCode : Integer read FCloseCode write FCloseCode; - property CloseReason: string read FCloseReason write FCloseReason; - - //text/string writes - procedure Write(const AOut: string; AEncoding: TIdTextEncoding = nil); overload; override; - procedure WriteLn(const AOut: string; AEncoding: TIdTextEncoding = nil); overload; override; - procedure WriteLnRFC(const AOut: string = ''; AEncoding: TIdTextEncoding = nil); override; - procedure Write(AValue: TStrings; AWriteLinesCount: Boolean = False; AEncoding: TIdTextEncoding = nil); overload; override; - procedure Write(AStream: TStream; aType: TWSDataType); overload; - end; - -//close frame codes -const - C_FrameClose_Normal = 1000; //1000 indicates a normal closure, meaning that the purpose for - //which the connection was established has been fulfilled. - C_FrameClose_GoingAway = 1001; //1001 indicates that an endpoint is "going away", such as a server - //going down or a browser having navigated away from a page. - C_FrameClose_ProtocolError = 1002; //1002 indicates that an endpoint is terminating the connection due - //to a protocol error. - C_FrameClose_UnhandledDataType = 1003; //1003 indicates that an endpoint is terminating the connection - //because it has received a type of data it cannot accept (e.g., an - //endpoint that understands only text data MAY send this if it - //receives a binary message). - C_FrameClose_Reserved = 1004; //Reserved. The specific meaning might be defined in the future. - C_FrameClose_ReservedNoStatus = 1005; //1005 is a reserved value and MUST NOT be set as a status code in a - //Close control frame by an endpoint. It is designated for use in - //applications expecting a status code to indicate that no status - //code was actually present. - C_FrameClose_ReservedAbnormal = 1006; //1006 is a reserved value and MUST NOT be set as a status code in a - //Close control frame by an endpoint. It is designated for use in - //applications expecting a status code to indicate that the - //connection was closed abnormally, e.g., without sending or - //receiving a Close control frame. - C_FrameClose_InconsistentData = 1007; //1007 indicates that an endpoint is terminating the connection - //because it has received data within a message that was not - //consistent with the type of the message (e.g., non-UTF-8 [RFC3629] - //data within a text message). - C_FrameClose_PolicyError = 1008; //1008 indicates that an endpoint is terminating the connection - //because it has received a message that violates its policy. This - //is a generic status code that can be returned when there is no - //other more suitable status code (e.g., 1003 or 1009) or if there - //is a need to hide specific details about the policy. - C_FrameClose_ToBigMessage = 1009; //1009 indicates that an endpoint is terminating the connection - //because it has received a message that is too big for it to process. - C_FrameClose_MissingExtenstion = 1010; //1010 indicates that an endpoint (client) is terminating the - //connection because it has expected the server to negotiate one or - //more extension, but the server didn't return them in the response - //message of the WebSocket handshake. The list of extensions that - //are needed SHOULD appear in the /reason/ part of the Close frame. - //Note that this status code is not used by the server, because it - //can fail the WebSocket handshake instead. - C_FrameClose_UnExpectedError = 1011; //1011 indicates that a server is terminating the connection because - //it encountered an unexpected condition that prevented it from - //fulfilling the request. - C_FrameClose_ReservedTLSError = 1015; //1015 is a reserved value and MUST NOT be set as a status code in a - //Close control frame by an endpoint. It is designated for use in - //applications expecting a status code to indicate that the - //connection was closed due to a failure to perform a TLS handshake - //(e.g., the server certificate can't be verified). - -implementation - -uses - SysUtils, Math, IdStream, IdStack, IdWinsock2, IdExceptionCore, - IdResourceStrings, IdResourceStringsCore; - -//frame codes -const +unit IdIOHandlerWebsocket; + +//The WebSocket Protocol, RFC 6455 +//http://datatracker.ietf.org/doc/rfc6455/?include_text=1 + +interface + +uses + Classes, + IdIOHandlerStack, IdGlobal, IdException, IdBuffer, SyncObjs, + Generics.Collections; + +type + TWSDataType = (wdtText, wdtBinary); + TWSDataCode = (wdcNone, wdcContinuation, wdcText, wdcBinary, wdcClose, wdcPing, wdcPong); + TWSExtensionBit = (webBit1, webBit2, webBit3); + TWSExtensionBits = set of TWSExtensionBit; + + TIdIOHandlerWebsocket = class; + EIdWebSocketHandleError = class(EIdSocketHandleError); + + TIdIOHandlerWebsocket = class(TIdIOHandlerStack) + private + FIsServerSide: Boolean; + FBusyUpgrading: Boolean; + FIsWebsocket: Boolean; + FWSInputBuffer: TIdBuffer; + FExtensionBits: TWSExtensionBits; + FLock: TCriticalSection; + FCloseReason: string; + FCloseCode: Integer; + FClosing: Boolean; + protected + FMessageStream: TMemoryStream; + FWriteTextToTarget: Boolean; + FCloseCodeSend: Boolean; + + function InternalReadDataFromSource(var VBuffer: TIdBytes; ARaiseExceptionOnTimeout: Boolean): Integer; + function ReadDataFromSource(var VBuffer: TIdBytes): Integer; override; + function WriteDataToTarget (const ABuffer: TIdBytes; const AOffset, ALength: Integer): Integer; override; + + function ReadFrame(out aFIN, aRSV1, aRSV2, aRSV3: boolean; out aDataCode: TWSDataCode; out aData: TIdBytes): Integer; + function ReadMessage(var aBuffer: TIdBytes; out aDataCode: TWSDataCode): Integer; + public + function WriteData(aData: TIdBytes; aType: TWSDataCode; + aFIN: boolean = true; aRSV1: boolean = false; aRSV2: boolean = false; aRSV3: boolean = false): integer; + property BusyUpgrading : Boolean read FBusyUpgrading write FBusyUpgrading; + property IsWebsocket : Boolean read FIsWebsocket write FIsWebsocket; + property IsServerSide : Boolean read FIsServerSide write FIsServerSide; + property ClientExtensionBits : TWSExtensionBits read FExtensionBits write FExtensionBits; + public + procedure AfterConstruction;override; + destructor Destroy; override; + + procedure Lock; + procedure Unlock; + function TryLock: Boolean; + + procedure Close; override; + property Closing : Boolean read FClosing; + property CloseCode : Integer read FCloseCode write FCloseCode; + property CloseReason: string read FCloseReason write FCloseReason; + + //text/string writes + procedure Write(const AOut: string; AEncoding: TIdTextEncoding = nil); overload; override; + procedure WriteLn(const AOut: string; AEncoding: TIdTextEncoding = nil); overload; override; + procedure WriteLnRFC(const AOut: string = ''; AEncoding: TIdTextEncoding = nil); override; + procedure Write(AValue: TStrings; AWriteLinesCount: Boolean = False; AEncoding: TIdTextEncoding = nil); overload; override; + procedure Write(AStream: TStream; aType: TWSDataType); overload; + end; + +//close frame codes +const + C_FrameClose_Normal = 1000; //1000 indicates a normal closure, meaning that the purpose for + //which the connection was established has been fulfilled. + C_FrameClose_GoingAway = 1001; //1001 indicates that an endpoint is "going away", such as a server + //going down or a browser having navigated away from a page. + C_FrameClose_ProtocolError = 1002; //1002 indicates that an endpoint is terminating the connection due + //to a protocol error. + C_FrameClose_UnhandledDataType = 1003; //1003 indicates that an endpoint is terminating the connection + //because it has received a type of data it cannot accept (e.g., an + //endpoint that understands only text data MAY send this if it + //receives a binary message). + C_FrameClose_Reserved = 1004; //Reserved. The specific meaning might be defined in the future. + C_FrameClose_ReservedNoStatus = 1005; //1005 is a reserved value and MUST NOT be set as a status code in a + //Close control frame by an endpoint. It is designated for use in + //applications expecting a status code to indicate that no status + //code was actually present. + C_FrameClose_ReservedAbnormal = 1006; //1006 is a reserved value and MUST NOT be set as a status code in a + //Close control frame by an endpoint. It is designated for use in + //applications expecting a status code to indicate that the + //connection was closed abnormally, e.g., without sending or + //receiving a Close control frame. + C_FrameClose_InconsistentData = 1007; //1007 indicates that an endpoint is terminating the connection + //because it has received data within a message that was not + //consistent with the type of the message (e.g., non-UTF-8 [RFC3629] + //data within a text message). + C_FrameClose_PolicyError = 1008; //1008 indicates that an endpoint is terminating the connection + //because it has received a message that violates its policy. This + //is a generic status code that can be returned when there is no + //other more suitable status code (e.g., 1003 or 1009) or if there + //is a need to hide specific details about the policy. + C_FrameClose_ToBigMessage = 1009; //1009 indicates that an endpoint is terminating the connection + //because it has received a message that is too big for it to process. + C_FrameClose_MissingExtenstion = 1010; //1010 indicates that an endpoint (client) is terminating the + //connection because it has expected the server to negotiate one or + //more extension, but the server didn't return them in the response + //message of the WebSocket handshake. The list of extensions that + //are needed SHOULD appear in the /reason/ part of the Close frame. + //Note that this status code is not used by the server, because it + //can fail the WebSocket handshake instead. + C_FrameClose_UnExpectedError = 1011; //1011 indicates that a server is terminating the connection because + //it encountered an unexpected condition that prevented it from + //fulfilling the request. + C_FrameClose_ReservedTLSError = 1015; //1015 is a reserved value and MUST NOT be set as a status code in a + //Close control frame by an endpoint. It is designated for use in + //applications expecting a status code to indicate that the + //connection was closed due to a failure to perform a TLS handshake + //(e.g., the server certificate can't be verified). + +implementation + +uses + SysUtils, Math, IdStream, IdStack, IdWinsock2, IdExceptionCore, + IdResourceStrings, IdResourceStringsCore; + +//frame codes +const C_FrameCode_Continuation = 0; C_FrameCode_Text = 1; - C_FrameCode_Binary = 2; - //3-7 are reserved for further non-control frames - C_FrameCode_Close = 8; - C_FrameCode_Ping = 9; - C_FrameCode_Pong = 10 {A}; - //B-F are reserved for further control frames - -{ TIdIOHandlerStack_Websocket } - -procedure TIdIOHandlerWebsocket.AfterConstruction; -begin - inherited; - FMessageStream := TMemoryStream.Create; - FWSInputBuffer := TIdBuffer.Create; - FLock := TCriticalSection.Create; -end; - -procedure TIdIOHandlerWebsocket.Close; -var - iaWriteBuffer: TIdBytes; - sReason: UTF8String; - iOptVal, iOptLen: Integer; - bConnected: Boolean; -begin - try - //valid connection? - bConnected := Opened and - SourceIsAvailable and - not ClosedGracefully; - - //no socket error? connection closed by software abort, connection reset by peer, etc - iOptLen := SIZE_INTEGER; - bConnected := bConnected and - (IdWinsock2.getsockopt(Self.Binding.Handle, SOL_SOCKET, SO_ERROR, PAnsiChar(@iOptVal), iOptLen) = 0) and - (iOptVal = 0); - - if bConnected and IsWebsocket then - begin - //close message must be responded with a close message back - //or initiated with a close message - if not FCloseCodeSend then - begin - FCloseCodeSend := True; - - //we initiate the close? then write reason etc - if not Closing then - begin - SetLength(iaWriteBuffer, 2); - if CloseCode < C_FrameClose_Normal then - CloseCode := C_FrameClose_Normal; - iaWriteBuffer[0] := Byte(CloseCode shr 8); - iaWriteBuffer[1] := Byte(CloseCode); - if CloseReason <> '' then - begin - sReason := utf8string(CloseReason); - SetLength(iaWriteBuffer, Length(iaWriteBuffer) + Length(sReason)); - Move(sReason[1], iaWriteBuffer[2], Length(sReason)); - end; - end - else - begin - //just send normal close response back - SetLength(iaWriteBuffer, 2); - iaWriteBuffer[0] := Byte(C_FrameClose_Normal shr 8); - iaWriteBuffer[1] := Byte(C_FrameClose_Normal); - end; - - WriteData(iaWriteBuffer, wdcClose); //send close + code back - end; - - //we did initiate the close? then wait (a little) for close response - if not Closing then - begin - FClosing := True; - CheckForDisconnect(); - //wait till client respond with close message back - //but a pending message can be in the buffer, so process this too - while ReadFromSource(False{no disconnect error}, 1 * 1000, False) > 0 do ; //response within 1s? - end; - end; - except - //ignore, it's possible that the client is disconnected already (crashed etc) - end; - - IsWebsocket := False; - BusyUpgrading := False; - inherited Close; -end; - -destructor TIdIOHandlerWebsocket.Destroy; -begin - FLock.Enter; - FLock.Free; - - FWSInputBuffer.Free; - FMessageStream.Free; - inherited; -end; - -function TIdIOHandlerWebsocket.InternalReadDataFromSource( - var VBuffer: TIdBytes): Integer; -begin - CheckForDisconnect; - if not Readable(ReadTimeout) or - not Opened or - not SourceIsAvailable then - begin - CheckForDisconnect; //disconnected during wait in "Readable()"? - if not Opened then - EIdNotConnected.Toss(RSNotConnected) - else if not SourceIsAvailable then - EIdClosedSocket.Toss(RSStatusDisconnected); - GStack.CheckForSocketError(GStack.WSGetLastError); //check for socket error - EIdReadTimeout.Toss(RSIdNoDataToRead); //exit, no data can be received - end; - - SetLength(VBuffer, RecvBufferSize); - Result := inherited ReadDataFromSource(VBuffer); - if Result = 0 then - begin - CheckForDisconnect; //disconnected in the mean time? - GStack.CheckForSocketError(GStack.WSGetLastError); //check for socket error - EIdNoDataToRead.Toss(RSIdNoDataToRead); //nothing read? then connection is probably closed -> exit - end; - SetLength(VBuffer, Result); -end; - -procedure TIdIOHandlerWebsocket.WriteLn(const AOut: string; - AEncoding: TIdTextEncoding); -begin - FWriteTextToTarget := True; - try - inherited WriteLn(AOut, TIdTextEncoding.UTF8); //must be UTF8! - finally - FWriteTextToTarget := False; - end; -end; - -procedure TIdIOHandlerWebsocket.WriteLnRFC(const AOut: string; - AEncoding: TIdTextEncoding); -begin - FWriteTextToTarget := True; - try - inherited WriteLnRFC(AOut, TIdTextEncoding.UTF8); //must be UTF8! - finally - FWriteTextToTarget := False; - end; -end; + C_FrameCode_Binary = 2; + //3-7 are reserved for further non-control frames + C_FrameCode_Close = 8; + C_FrameCode_Ping = 9; + C_FrameCode_Pong = 10 {A}; + //B-F are reserved for further control frames + +{ TIdIOHandlerStack_Websocket } + +procedure TIdIOHandlerWebsocket.AfterConstruction; +begin + inherited; + FMessageStream := TMemoryStream.Create; + FWSInputBuffer := TIdBuffer.Create; + FLock := TCriticalSection.Create; +end; + +procedure TIdIOHandlerWebsocket.Close; +var + iaWriteBuffer: TIdBytes; + sReason: UTF8String; + iOptVal, iOptLen: Integer; + bConnected: Boolean; +begin + try + //valid connection? + bConnected := Opened and + SourceIsAvailable and + not ClosedGracefully; + + //no socket error? connection closed by software abort, connection reset by peer, etc + iOptLen := SIZE_INTEGER; + bConnected := bConnected and + (IdWinsock2.getsockopt(Self.Binding.Handle, SOL_SOCKET, SO_ERROR, PAnsiChar(@iOptVal), iOptLen) = 0) and + (iOptVal = 0); + + if bConnected and IsWebsocket then + begin + //close message must be responded with a close message back + //or initiated with a close message + if not FCloseCodeSend then + begin + FCloseCodeSend := True; + + //we initiate the close? then write reason etc + if not Closing then + begin + SetLength(iaWriteBuffer, 2); + if CloseCode < C_FrameClose_Normal then + CloseCode := C_FrameClose_Normal; + iaWriteBuffer[0] := Byte(CloseCode shr 8); + iaWriteBuffer[1] := Byte(CloseCode); + if CloseReason <> '' then + begin + sReason := utf8string(CloseReason); + SetLength(iaWriteBuffer, Length(iaWriteBuffer) + Length(sReason)); + Move(sReason[1], iaWriteBuffer[2], Length(sReason)); + end; + end + else + begin + //just send normal close response back + SetLength(iaWriteBuffer, 2); + iaWriteBuffer[0] := Byte(C_FrameClose_Normal shr 8); + iaWriteBuffer[1] := Byte(C_FrameClose_Normal); + end; + + WriteData(iaWriteBuffer, wdcClose); //send close + code back + end; + + //we did initiate the close? then wait (a little) for close response + if not Closing then + begin + FClosing := True; + CheckForDisconnect(); + //wait till client respond with close message back + //but a pending message can be in the buffer, so process this too + while ReadFromSource(False{no disconnect error}, 1 * 1000, False) > 0 do ; //response within 1s? + end; + end; + except + //ignore, it's possible that the client is disconnected already (crashed etc) + end; + + IsWebsocket := False; + BusyUpgrading := False; + inherited Close; +end; + +destructor TIdIOHandlerWebsocket.Destroy; +begin + FLock.Enter; + FLock.Free; + + FWSInputBuffer.Free; + FMessageStream.Free; + inherited; +end; + +function TIdIOHandlerWebsocket.InternalReadDataFromSource( + var VBuffer: TIdBytes; ARaiseExceptionOnTimeout: Boolean): Integer; +begin + SetLength(VBuffer, 0); + + CheckForDisconnect; + if not Readable(ReadTimeout) or + not Opened or + not SourceIsAvailable then + begin + CheckForDisconnect; //disconnected during wait in "Readable()"? + if not Opened then + EIdNotConnected.Toss(RSNotConnected) + else if not SourceIsAvailable then + EIdClosedSocket.Toss(RSStatusDisconnected); + GStack.CheckForSocketError(GStack.WSGetLastError); //check for socket error + if ARaiseExceptionOnTimeout then + EIdReadTimeout.Toss(RSIdNoDataToRead) //exit, no data can be received + else + Exit; + end; + + SetLength(VBuffer, RecvBufferSize); + Result := inherited ReadDataFromSource(VBuffer); + if Result = 0 then + begin + CheckForDisconnect; //disconnected in the mean time? + GStack.CheckForSocketError(GStack.WSGetLastError); //check for socket error + EIdNoDataToRead.Toss(RSIdNoDataToRead); //nothing read? then connection is probably closed -> exit + end; + SetLength(VBuffer, Result); +end; + +procedure TIdIOHandlerWebsocket.WriteLn(const AOut: string; + AEncoding: TIdTextEncoding); +begin + FWriteTextToTarget := True; + try + inherited WriteLn(AOut, TIdTextEncoding.UTF8); //must be UTF8! + finally + FWriteTextToTarget := False; + end; +end; + +procedure TIdIOHandlerWebsocket.WriteLnRFC(const AOut: string; + AEncoding: TIdTextEncoding); +begin + FWriteTextToTarget := True; + try + inherited WriteLnRFC(AOut, TIdTextEncoding.UTF8); //must be UTF8! + finally + FWriteTextToTarget := False; + end; +end; procedure TIdIOHandlerWebsocket.Write(const AOut: string; - AEncoding: TIdTextEncoding); -begin - FWriteTextToTarget := True; - try - inherited Write(AOut, TIdTextEncoding.UTF8); //must be UTF8! - finally - FWriteTextToTarget := False; - end; -end; - -procedure TIdIOHandlerWebsocket.Write(AValue: TStrings; - AWriteLinesCount: Boolean; AEncoding: TIdTextEncoding); -begin - FWriteTextToTarget := True; - try - inherited Write(AValue, AWriteLinesCount, TIdTextEncoding.UTF8); //must be UTF8! - finally - FWriteTextToTarget := False; - end; -end; - -procedure TIdIOHandlerWebsocket.Write(AStream: TStream; - aType: TWSDataType); -begin - FWriteTextToTarget := (aType = wdtText); - try - inherited Write(AStream); - finally - FWriteTextToTarget := False; - end; -end; - -function TIdIOHandlerWebsocket.WriteDataToTarget(const ABuffer: TIdBytes; - const AOffset, ALength: Integer): Integer; -begin - if not IsWebsocket then - Result := inherited WriteDataToTarget(ABuffer, AOffset, ALength) - else - begin - Lock; - try - if FWriteTextToTarget then - Result := WriteData(ABuffer, wdcText, True{send all at once}, - webBit1 in ClientExtensionBits, webBit2 in ClientExtensionBits, webBit3 in ClientExtensionBits) - else - Result := WriteData(ABuffer, wdcBinary, True{send all at once}, - webBit1 in ClientExtensionBits, webBit2 in ClientExtensionBits, webBit3 in ClientExtensionBits); - except - Unlock; //always unlock when socket exception - FClosedGracefully := True; - Raise; - end; - Unlock; //normal unlock (no double try finally) - end; -end; - -function TIdIOHandlerWebsocket.ReadDataFromSource( - var VBuffer: TIdBytes): Integer; -var - wscode: TWSDataCode; -begin - //the first time something is read AFTER upgrading, we switch to WS - //(so partial writes can be done, till a read is done) - if BusyUpgrading then - begin - BusyUpgrading := False; - IsWebsocket := True; - end; - - if not IsWebsocket then - Result := inherited ReadDataFromSource(VBuffer) - else - begin - Lock; - try - //we wait till we have a full message here (can be fragmented in several frames) - Result := ReadMessage(VBuffer, wscode); - - //first write the data code (text or binary, ping, pong) - FInputBuffer.Write(LongWord(Ord(wscode))); - //we write message size here, vbuffer is written after this. This way we can use ReadStream to get 1 single message (in case multiple messages in FInputBuffer) - if LargeStream then - FInputBuffer.Write(Int64(Result)) - else - FInputBuffer.Write(LongWord(Result)) - except - Unlock; //always unlock when socket exception - FClosedGracefully := True; //closed (but not gracefully?) - Raise; - end; - Unlock; //normal unlock (no double try finally) - end; -end; - -function TIdIOHandlerWebsocket.ReadMessage(var aBuffer: TIdBytes; out aDataCode: TWSDataCode): Integer; -var - iReadCount: Integer; - iaReadBuffer: TIdBytes; - bFIN, bRSV1, bRSV2, bRSV3: boolean; - lDataCode: TWSDataCode; - lFirstDataCode: TWSDataCode; -// closeCode: integer; -// closeResult: string; -begin - Result := 0; - (* ...all fragments of a message are of - the same type, as set by the first fragment's opcode. Since - control frames cannot be fragmented, the type for all fragments in - a message MUST be either text, binary, or one of the reserved - opcodes. *) - lFirstDataCode := wdcNone; + AEncoding: TIdTextEncoding); +begin + FWriteTextToTarget := True; + try + inherited Write(AOut, TIdTextEncoding.UTF8); //must be UTF8! + finally + FWriteTextToTarget := False; + end; +end; + +procedure TIdIOHandlerWebsocket.Write(AValue: TStrings; + AWriteLinesCount: Boolean; AEncoding: TIdTextEncoding); +begin + FWriteTextToTarget := True; + try + inherited Write(AValue, AWriteLinesCount, TIdTextEncoding.UTF8); //must be UTF8! + finally + FWriteTextToTarget := False; + end; +end; + +procedure TIdIOHandlerWebsocket.Write(AStream: TStream; + aType: TWSDataType); +begin + FWriteTextToTarget := (aType = wdtText); + try + inherited Write(AStream); + finally + FWriteTextToTarget := False; + end; +end; + +function TIdIOHandlerWebsocket.WriteDataToTarget(const ABuffer: TIdBytes; + const AOffset, ALength: Integer): Integer; +begin + if not IsWebsocket then + Result := inherited WriteDataToTarget(ABuffer, AOffset, ALength) + else + begin + Lock; + try + if FWriteTextToTarget then + Result := WriteData(ABuffer, wdcText, True{send all at once}, + webBit1 in ClientExtensionBits, webBit2 in ClientExtensionBits, webBit3 in ClientExtensionBits) + else + Result := WriteData(ABuffer, wdcBinary, True{send all at once}, + webBit1 in ClientExtensionBits, webBit2 in ClientExtensionBits, webBit3 in ClientExtensionBits); + except + Unlock; //always unlock when socket exception + FClosedGracefully := True; + Raise; + end; + Unlock; //normal unlock (no double try finally) + end; +end; + +function TIdIOHandlerWebsocket.ReadDataFromSource( + var VBuffer: TIdBytes): Integer; +var + wscode: TWSDataCode; +begin + //the first time something is read AFTER upgrading, we switch to WS + //(so partial writes can be done, till a read is done) + if BusyUpgrading then + begin + BusyUpgrading := False; + IsWebsocket := True; + end; + + if not IsWebsocket then + Result := inherited ReadDataFromSource(VBuffer) + else + begin + Lock; + try + //we wait till we have a full message here (can be fragmented in several frames) + Result := ReadMessage(VBuffer, wscode); + + //first write the data code (text or binary, ping, pong) + FInputBuffer.Write(LongWord(Ord(wscode))); + //we write message size here, vbuffer is written after this. This way we can use ReadStream to get 1 single message (in case multiple messages in FInputBuffer) + if LargeStream then + FInputBuffer.Write(Int64(Result)) + else + FInputBuffer.Write(LongWord(Result)) + except + Unlock; //always unlock when socket exception + FClosedGracefully := True; //closed (but not gracefully?) + Raise; + end; + Unlock; //normal unlock (no double try finally) + end; +end; + +function TIdIOHandlerWebsocket.ReadMessage(var aBuffer: TIdBytes; out aDataCode: TWSDataCode): Integer; +var + iReadCount: Integer; + iaReadBuffer: TIdBytes; + bFIN, bRSV1, bRSV2, bRSV3: boolean; + lDataCode: TWSDataCode; + lFirstDataCode: TWSDataCode; +// closeCode: integer; +// closeResult: string; +begin + Result := 0; + (* ...all fragments of a message are of + the same type, as set by the first fragment's opcode. Since + control frames cannot be fragmented, the type for all fragments in + a message MUST be either text, binary, or one of the reserved + opcodes. *) + lFirstDataCode := wdcNone; FMessageStream.Clear; - repeat - //read a single frame - iReadCount := ReadFrame(bFIN, bRSV1, bRSV2, bRSV3, lDataCode, iaReadBuffer); + + repeat + //read a single frame + iReadCount := ReadFrame(bFIN, bRSV1, bRSV2, bRSV3, lDataCode, iaReadBuffer); if (iReadCount > 0) or (lDataCode <> wdcNone) then begin @@ -402,57 +408,57 @@ begin if Self.IsServerSide then begin ClientExtensionBits := []; - if bRSV1 then ClientExtensionBits := ClientExtensionBits + [webBit1]; - if bRSV2 then ClientExtensionBits := ClientExtensionBits + [webBit2]; - if bRSV3 then ClientExtensionBits := ClientExtensionBits + [webBit3]; - end; + if bRSV1 then ClientExtensionBits := ClientExtensionBits + [webBit1]; + if bRSV2 then ClientExtensionBits := ClientExtensionBits + [webBit2]; + if bRSV3 then ClientExtensionBits := ClientExtensionBits + [webBit3]; + end; //process frame case lDataCode of - wdcText, wdcBinary: - begin - if lFirstDataCode <> wdcNone then + wdcText, wdcBinary: + begin + if lFirstDataCode <> wdcNone then raise EIdWebSocketHandleError.Create('Invalid frame: specified data code only allowed for the first frame'); lFirstDataCode := lDataCode; FMessageStream.Clear; TIdStreamHelper.Write(FMessageStream, iaReadBuffer); end; - wdcContinuation: - begin - if not (lFirstDataCode in [wdcText, wdcBinary]) then - raise EIdWebSocketHandleError.Create('Invalid frame continuation'); - TIdStreamHelper.Write(FMessageStream, iaReadBuffer); - end; - wdcClose: - begin - FCloseCode := C_FrameClose_Normal; - //"If there is a body, the first two bytes of the body MUST be a 2-byte - // unsigned integer (in network byte order) representing a status code" - if Length(iaReadBuffer) > 1 then - begin - FCloseCode := (iaReadBuffer[0] shl 8) + - iaReadBuffer[1]; - if Length(iaReadBuffer) > 2 then - FCloseReason := BytesToString(iaReadBuffer, 2, Length(iaReadBuffer), TEncoding.UTF8); - end; - - FClosing := True; - Self.Close; - end; - //Note: control frames can be send between fragmented frames - wdcPing: - begin - WriteData(iaReadBuffer, wdcPong); //send pong + same data back - lFirstDataCode := lDataCode; - //bFIN := False; //ignore ping when we wait for data? - end; - wdcPong: - begin - //pong received, ignore; - lFirstDataCode := lDataCode; - end; - end; + wdcContinuation: + begin + if not (lFirstDataCode in [wdcText, wdcBinary]) then + raise EIdWebSocketHandleError.Create('Invalid frame continuation'); + TIdStreamHelper.Write(FMessageStream, iaReadBuffer); + end; + wdcClose: + begin + FCloseCode := C_FrameClose_Normal; + //"If there is a body, the first two bytes of the body MUST be a 2-byte + // unsigned integer (in network byte order) representing a status code" + if Length(iaReadBuffer) > 1 then + begin + FCloseCode := (iaReadBuffer[0] shl 8) + + iaReadBuffer[1]; + if Length(iaReadBuffer) > 2 then + FCloseReason := BytesToString(iaReadBuffer, 2, Length(iaReadBuffer), TEncoding.UTF8); + end; + + FClosing := True; + Self.Close; + end; + //Note: control frames can be send between fragmented frames + wdcPing: + begin + WriteData(iaReadBuffer, wdcPong); //send pong + same data back + lFirstDataCode := lDataCode; + //bFIN := False; //ignore ping when we wait for data? + end; + wdcPong: + begin + //pong received, ignore; + lFirstDataCode := lDataCode; + end; + end; end else Break; @@ -464,308 +470,312 @@ begin if (lFirstDataCode in [wdcText, wdcBinary]) then begin //result - FMessageStream.Position := 0; - TIdStreamHelper.ReadBytes(FMessageStream, aBuffer); - Result := FMessageStream.Size; - aDataCode := lFirstDataCode - end - else if (lFirstDataCode in [wdcPing, wdcPong]) then - begin - //result - FMessageStream.Position := 0; - TIdStreamHelper.ReadBytes(FMessageStream, aBuffer); - SetLength(aBuffer, FMessageStream.Size); - //dummy data: there *must* be some data read otherwise connection is closed by Indy! - if Length(aBuffer) <= 0 then - begin - SetLength(aBuffer, 1); - aBuffer[0] := Ord(lFirstDataCode); - end; - - Result := Length(aBuffer); - aDataCode := lFirstDataCode - end; - end; -end; - -procedure TIdIOHandlerWebsocket.Lock; -begin - FLock.Enter; -end; + FMessageStream.Position := 0; + TIdStreamHelper.ReadBytes(FMessageStream, aBuffer); + Result := FMessageStream.Size; + aDataCode := lFirstDataCode + end + else if (lFirstDataCode in [wdcPing, wdcPong]) then + begin + //result + FMessageStream.Position := 0; + TIdStreamHelper.ReadBytes(FMessageStream, aBuffer); + SetLength(aBuffer, FMessageStream.Size); + //dummy data: there *must* be some data read otherwise connection is closed by Indy! + if Length(aBuffer) <= 0 then + begin + SetLength(aBuffer, 1); + aBuffer[0] := Ord(lFirstDataCode); + end; -function TIdIOHandlerWebsocket.TryLock: Boolean; -begin - Result := FLock.TryEnter; -end; - -procedure TIdIOHandlerWebsocket.Unlock; -begin - FLock.Leave; -end; - -function TIdIOHandlerWebsocket.ReadFrame(out aFIN, aRSV1, aRSV2, aRSV3: boolean; - out aDataCode: TWSDataCode; out aData: TIdBytes): Integer; -var - iInputPos: NativeInt; - - function _GetByte: Byte; - var - temp: TIdBytes; - begin - while FWSInputBuffer.Size <= iInputPos do - begin - //FWSInputBuffer.AsString; - InternalReadDataFromSource(temp); - FWSInputBuffer.Write(temp); - end; - - //Self.ReadByte copies all data everytime (because the first byte must be removed) so we use index (much more efficient) - Result := FWSInputBuffer.PeekByte(iInputPos); - //FWSInputBuffer.AsString - inc(iInputPos); - end; - - function _GetBytes(aCount: Integer): TIdBytes; - var - temp: TIdBytes; - begin - while FWSInputBuffer.Size < aCount do - begin - InternalReadDataFromSource(temp); - FWSInputBuffer.Write(temp); - end; - - FWSInputBuffer.ExtractToBytes(Result, aCount); - end; - -var - iByte: Byte; - i, iCode: NativeInt; - bHasMask: boolean; - iDataLength, iPos: Int64; - rMask: record - case Boolean of - True : (MaskAsBytes: array[0..3] of Byte); - False: (MaskAsInt : Int32); - end; -begin - iInputPos := 0; - SetLength(aData, 0); - aDataCode := wdcNone; - - //wait + process data - iByte := _GetByte; - (* 0 1 2 3 - 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 (nr) - 7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0 (bit) - +-+-+-+-+-------+-+-------------+-------------------------------+ - |F|R|R|R| opcode|M| Payload len | Extended payload length | - |I|S|S|S| (4) |A| (7) | (16/64) | - |N|V|V|V| |S| | (if payload len==126/127) | - | |1|2|3| |K| | | - +-+-+-+-+-------+-+-------------+ - - - - - - - - - - - - - - - + *) - //FIN, RSV1, RSV2, RSV3: 1 bit each - aFIN := (iByte and (1 shl 7)) > 0; - aRSV1 := (iByte and (1 shl 6)) > 0; - aRSV2 := (iByte and (1 shl 5)) > 0; - aRSV3 := (iByte and (1 shl 4)) > 0; - //Opcode: 4 bits - iCode := (iByte and $0F); //clear 4 MSB's - case iCode of - C_FrameCode_Continuation: aDataCode := wdcContinuation; - C_FrameCode_Text: aDataCode := wdcText; - C_FrameCode_Binary: aDataCode := wdcBinary; - C_FrameCode_Close: aDataCode := wdcClose; - C_FrameCode_Ping: aDataCode := wdcPing; - C_FrameCode_Pong: aDataCode := wdcPong; - else - raise EIdException.CreateFmt('Unsupported data code: %d', [iCode]); - end; - - //Mask: 1 bit - iByte := _GetByte; - bHasMask := (iByte and (1 shl 7)) > 0; - //Length (7 bits or 7+16 bits or 7+64 bits) - iDataLength := (iByte and $7F); //clear 1 MSB - //Extended payload length? - //If 126, the following 2 bytes interpreted as a 16-bit unsigned integer are the payload length - if (iDataLength = 126) then - begin - iByte := _GetByte; - iDataLength := (iByte shl 8); //8 MSB - iByte := _GetByte; - iDataLength := iDataLength + iByte; - end - //If 127, the following 8 bytes interpreted as a 64-bit unsigned integer (the most significant bit MUST be 0) are the payload length - else if (iDataLength = 127) then - begin - iDataLength := 0; - for i := 7 downto 0 do //read 8 bytes in reverse order - begin - iByte := _GetByte; - iDataLength := iDataLength + - (Int64(iByte) shl (8 * i)); //shift bits to left to recreate 64bit integer - end; - Assert(iDataLength > 0); - end; - - //"All frames sent from client to server must have this bit set to 1" - if IsServerSide and not bHasMask then - raise EIdWebSocketHandleError.Create('No mask supplied: mask is required for clients when sending data to server') - else if not IsServerSide and bHasMask then - raise EIdWebSocketHandleError.Create('Mask supplied but mask is not allowed for servers when sending data to clients'); - - //Masking-key: 0 or 4 bytes - if bHasMask then - begin - rMask.MaskAsBytes[0] := _GetByte; - rMask.MaskAsBytes[1] := _GetByte; - rMask.MaskAsBytes[2] := _GetByte; - rMask.MaskAsBytes[3] := _GetByte; - end; - //Payload data: (x+y) bytes - FWSInputBuffer.Remove(iInputPos); //remove first couple of processed bytes (header) - //simple read? - if not bHasMask then - aData := _GetBytes(iDataLength) - else - //reverse mask - begin - aData := _GetBytes(iDataLength); - iPos := 0; - while iPos < iDataLength do - begin - aData[iPos] := aData[iPos] xor - rMask.MaskAsBytes[iPos mod 4]; //apply mask - inc(iPos); - end; - end; - - Result := Length(aData); -end; - -function TIdIOHandlerWebsocket.WriteData(aData: TIdBytes; - aType: TWSDataCode; aFIN, aRSV1, aRSV2, aRSV3: boolean): integer; -var - iByte: Byte; - i: NativeInt; - iDataLength, iPos: Int64; - rLength: Int64Rec; - rMask: record - case Boolean of - True : (MaskAsBytes: array[0..3] of Byte); - False: (MaskAsInt : Int32); - end; - strmData: TMemoryStream; - bData: TBytes; -begin - Result := 0; - Assert(Binding <> nil); - - strmData := TMemoryStream.Create; - try - (* 0 1 2 3 - 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 (nr) - 7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0 (bit) - +-+-+-+-+-------+-+-------------+-------------------------------+ - |F|R|R|R| opcode|M| Payload len | Extended payload length | - |I|S|S|S| (4) |A| (7) | (16/64) | - |N|V|V|V| |S| | (if payload len==126/127) | - | |1|2|3| |K| | | - +-+-+-+-+-------+-+-------------+ - - - - - - - - - - - - - - - + *) - //FIN, RSV1, RSV2, RSV3: 1 bit each - if aFIN then iByte := (1 shl 7); - if aRSV1 then iByte := iByte + (1 shl 6); - if aRSV2 then iByte := iByte + (1 shl 5); - if aRSV3 then iByte := iByte + (1 shl 4); - //Opcode: 4 bits - case aType of - wdcContinuation : iByte := iByte + C_FrameCode_Continuation; - wdcText : iByte := iByte + C_FrameCode_Text; - wdcBinary : iByte := iByte + C_FrameCode_Binary; - wdcClose : iByte := iByte + C_FrameCode_Close; - wdcPing : iByte := iByte + C_FrameCode_Ping; - wdcPong : iByte := iByte + C_FrameCode_Pong; - else - raise EIdException.CreateFmt('Unsupported data code: %d', [Ord(aType)]); - end; - strmData.Write(iByte, SizeOf(iByte)); - - iByte := 0; - //Mask: 1 bit; Note: Clients must apply a mask - if not IsServerSide then iByte := (1 shl 7); - - //Length: 7 bits or 7+16 bits or 7+64 bits - if Length(aData) < 126 then //7 bit, 128 - iByte := iByte + Length(aData) - else if Length(aData) < 1 shl 16 then //16 bit, 65536 - iByte := iByte + 126 - else - iByte := iByte + 127; - strmData.Write(iByte, SizeOf(iByte)); - - //Extended payload length? - if Length(aData) >= 126 then - begin - //If 126, the following 2 bytes interpreted as a 16-bit unsigned integer are the payload length - if Length(aData) < 1 shl 16 then //16 bit, 65536 - begin - rLength.Lo := Length(aData); - iByte := rLength.Bytes[1]; - strmData.Write(iByte, SizeOf(iByte)); - iByte := rLength.Bytes[0]; - strmData.Write(iByte, SizeOf(iByte)); - end - else - //If 127, the following 8 bytes interpreted as a 64-bit unsigned integer (the most significant bit MUST be 0) are the payload length - begin - rLength := Int64Rec(Int64(Length(aData))); - for i := 7 downto 0 do - begin - iByte := rLength.Bytes[i]; - strmData.Write(iByte, SizeOf(iByte)); - end; - end - end; - - //Masking-key: 0 or 4 bytes; Note: Clients must apply a mask - if not IsServerSide then - begin - rMask.MaskAsInt := Random(MaxInt); - strmData.Write(rMask.MaskAsBytes[0], SizeOf(Byte)); - strmData.Write(rMask.MaskAsBytes[1], SizeOf(Byte)); - strmData.Write(rMask.MaskAsBytes[2], SizeOf(Byte)); - strmData.Write(rMask.MaskAsBytes[3], SizeOf(Byte)); - end; - - //write header - strmData.Position := 0; - TIdStreamHelper.ReadBytes(strmData, bData); - Result := Binding.Send(bData); - - //Mask? Note: Only clients must apply a mask - if IsServerSide then - begin - Result := Binding.Send(aData); - end - else - begin - iPos := 0; - iDataLength := Length(aData); - //in place masking - while iPos < iDataLength do - begin - iByte := aData[iPos] xor rMask.MaskAsBytes[iPos mod 4]; //apply mask - aData[iPos] := iByte; - inc(iPos); - end; - - //send masked data - Result := Binding.Send(aData); - end; - finally - strmData.Free; - end; -end; - -end. + Result := Length(aBuffer); + aDataCode := lFirstDataCode + end; + end; +end; + +procedure TIdIOHandlerWebsocket.Lock; +begin + FLock.Enter; +end; + +function TIdIOHandlerWebsocket.TryLock: Boolean; +begin + Result := FLock.TryEnter; +end; + +procedure TIdIOHandlerWebsocket.Unlock; +begin + FLock.Leave; +end; + +function TIdIOHandlerWebsocket.ReadFrame(out aFIN, aRSV1, aRSV2, aRSV3: boolean; + out aDataCode: TWSDataCode; out aData: TIdBytes): Integer; +var + iInputPos: NativeInt; + + function _GetByte: Byte; + var + temp: TIdBytes; + begin + while FWSInputBuffer.Size <= iInputPos do + begin + //FWSInputBuffer.AsString; + InternalReadDataFromSource(temp, True); + FWSInputBuffer.Write(temp); + if FWSInputBuffer.Size <= iInputPos then + Sleep(1); + end; + + //Self.ReadByte copies all data everytime (because the first byte must be removed) so we use index (much more efficient) + Result := FWSInputBuffer.PeekByte(iInputPos); + //FWSInputBuffer.AsString + inc(iInputPos); + end; + + function _GetBytes(aCount: Integer): TIdBytes; + var + temp: TIdBytes; + begin + while FWSInputBuffer.Size < aCount do + begin + InternalReadDataFromSource(temp, True); + FWSInputBuffer.Write(temp); + if FWSInputBuffer.Size < aCount then + Sleep(1); + end; + + FWSInputBuffer.ExtractToBytes(Result, aCount); + end; + +var + iByte: Byte; + i, iCode: NativeInt; + bHasMask: boolean; + iDataLength, iPos: Int64; + rMask: record + case Boolean of + True : (MaskAsBytes: array[0..3] of Byte); + False: (MaskAsInt : Int32); + end; +begin + iInputPos := 0; + SetLength(aData, 0); + aDataCode := wdcNone; + + //wait + process data + iByte := _GetByte; + (* 0 1 2 3 + 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 (nr) + 7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0 (bit) + +-+-+-+-+-------+-+-------------+-------------------------------+ + |F|R|R|R| opcode|M| Payload len | Extended payload length | + |I|S|S|S| (4) |A| (7) | (16/64) | + |N|V|V|V| |S| | (if payload len==126/127) | + | |1|2|3| |K| | | + +-+-+-+-+-------+-+-------------+ - - - - - - - - - - - - - - - + *) + //FIN, RSV1, RSV2, RSV3: 1 bit each + aFIN := (iByte and (1 shl 7)) > 0; + aRSV1 := (iByte and (1 shl 6)) > 0; + aRSV2 := (iByte and (1 shl 5)) > 0; + aRSV3 := (iByte and (1 shl 4)) > 0; + //Opcode: 4 bits + iCode := (iByte and $0F); //clear 4 MSB's + case iCode of + C_FrameCode_Continuation: aDataCode := wdcContinuation; + C_FrameCode_Text: aDataCode := wdcText; + C_FrameCode_Binary: aDataCode := wdcBinary; + C_FrameCode_Close: aDataCode := wdcClose; + C_FrameCode_Ping: aDataCode := wdcPing; + C_FrameCode_Pong: aDataCode := wdcPong; + else + raise EIdException.CreateFmt('Unsupported data code: %d', [iCode]); + end; + + //Mask: 1 bit + iByte := _GetByte; + bHasMask := (iByte and (1 shl 7)) > 0; + //Length (7 bits or 7+16 bits or 7+64 bits) + iDataLength := (iByte and $7F); //clear 1 MSB + //Extended payload length? + //If 126, the following 2 bytes interpreted as a 16-bit unsigned integer are the payload length + if (iDataLength = 126) then + begin + iByte := _GetByte; + iDataLength := (iByte shl 8); //8 MSB + iByte := _GetByte; + iDataLength := iDataLength + iByte; + end + //If 127, the following 8 bytes interpreted as a 64-bit unsigned integer (the most significant bit MUST be 0) are the payload length + else if (iDataLength = 127) then + begin + iDataLength := 0; + for i := 7 downto 0 do //read 8 bytes in reverse order + begin + iByte := _GetByte; + iDataLength := iDataLength + + (Int64(iByte) shl (8 * i)); //shift bits to left to recreate 64bit integer + end; + Assert(iDataLength > 0); + end; + + //"All frames sent from client to server must have this bit set to 1" + if IsServerSide and not bHasMask then + raise EIdWebSocketHandleError.Create('No mask supplied: mask is required for clients when sending data to server') + else if not IsServerSide and bHasMask then + raise EIdWebSocketHandleError.Create('Mask supplied but mask is not allowed for servers when sending data to clients'); + + //Masking-key: 0 or 4 bytes + if bHasMask then + begin + rMask.MaskAsBytes[0] := _GetByte; + rMask.MaskAsBytes[1] := _GetByte; + rMask.MaskAsBytes[2] := _GetByte; + rMask.MaskAsBytes[3] := _GetByte; + end; + //Payload data: (x+y) bytes + FWSInputBuffer.Remove(iInputPos); //remove first couple of processed bytes (header) + //simple read? + if not bHasMask then + aData := _GetBytes(iDataLength) + else + //reverse mask + begin + aData := _GetBytes(iDataLength); + iPos := 0; + while iPos < iDataLength do + begin + aData[iPos] := aData[iPos] xor + rMask.MaskAsBytes[iPos mod 4]; //apply mask + inc(iPos); + end; + end; + + Result := Length(aData); +end; + +function TIdIOHandlerWebsocket.WriteData(aData: TIdBytes; + aType: TWSDataCode; aFIN, aRSV1, aRSV2, aRSV3: boolean): integer; +var + iByte: Byte; + i: NativeInt; + iDataLength, iPos: Int64; + rLength: Int64Rec; + rMask: record + case Boolean of + True : (MaskAsBytes: array[0..3] of Byte); + False: (MaskAsInt : Int32); + end; + strmData: TMemoryStream; + bData: TBytes; +begin + Result := 0; + Assert(Binding <> nil); + + strmData := TMemoryStream.Create; + try + (* 0 1 2 3 + 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 (nr) + 7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0 (bit) + +-+-+-+-+-------+-+-------------+-------------------------------+ + |F|R|R|R| opcode|M| Payload len | Extended payload length | + |I|S|S|S| (4) |A| (7) | (16/64) | + |N|V|V|V| |S| | (if payload len==126/127) | + | |1|2|3| |K| | | + +-+-+-+-+-------+-+-------------+ - - - - - - - - - - - - - - - + *) + //FIN, RSV1, RSV2, RSV3: 1 bit each + if aFIN then iByte := (1 shl 7); + if aRSV1 then iByte := iByte + (1 shl 6); + if aRSV2 then iByte := iByte + (1 shl 5); + if aRSV3 then iByte := iByte + (1 shl 4); + //Opcode: 4 bits + case aType of + wdcContinuation : iByte := iByte + C_FrameCode_Continuation; + wdcText : iByte := iByte + C_FrameCode_Text; + wdcBinary : iByte := iByte + C_FrameCode_Binary; + wdcClose : iByte := iByte + C_FrameCode_Close; + wdcPing : iByte := iByte + C_FrameCode_Ping; + wdcPong : iByte := iByte + C_FrameCode_Pong; + else + raise EIdException.CreateFmt('Unsupported data code: %d', [Ord(aType)]); + end; + strmData.Write(iByte, SizeOf(iByte)); + + iByte := 0; + //Mask: 1 bit; Note: Clients must apply a mask + if not IsServerSide then iByte := (1 shl 7); + + //Length: 7 bits or 7+16 bits or 7+64 bits + if Length(aData) < 126 then //7 bit, 128 + iByte := iByte + Length(aData) + else if Length(aData) < 1 shl 16 then //16 bit, 65536 + iByte := iByte + 126 + else + iByte := iByte + 127; + strmData.Write(iByte, SizeOf(iByte)); + + //Extended payload length? + if Length(aData) >= 126 then + begin + //If 126, the following 2 bytes interpreted as a 16-bit unsigned integer are the payload length + if Length(aData) < 1 shl 16 then //16 bit, 65536 + begin + rLength.Lo := Length(aData); + iByte := rLength.Bytes[1]; + strmData.Write(iByte, SizeOf(iByte)); + iByte := rLength.Bytes[0]; + strmData.Write(iByte, SizeOf(iByte)); + end + else + //If 127, the following 8 bytes interpreted as a 64-bit unsigned integer (the most significant bit MUST be 0) are the payload length + begin + rLength := Int64Rec(Int64(Length(aData))); + for i := 7 downto 0 do + begin + iByte := rLength.Bytes[i]; + strmData.Write(iByte, SizeOf(iByte)); + end; + end + end; + + //Masking-key: 0 or 4 bytes; Note: Clients must apply a mask + if not IsServerSide then + begin + rMask.MaskAsInt := Random(MaxInt); + strmData.Write(rMask.MaskAsBytes[0], SizeOf(Byte)); + strmData.Write(rMask.MaskAsBytes[1], SizeOf(Byte)); + strmData.Write(rMask.MaskAsBytes[2], SizeOf(Byte)); + strmData.Write(rMask.MaskAsBytes[3], SizeOf(Byte)); + end; + + //write header + strmData.Position := 0; + TIdStreamHelper.ReadBytes(strmData, bData); + Result := Binding.Send(bData); + + //Mask? Note: Only clients must apply a mask + if IsServerSide then + begin + Result := Binding.Send(aData); + end + else + begin + iPos := 0; + iDataLength := Length(aData); + //in place masking + while iPos < iDataLength do + begin + iByte := aData[iPos] xor rMask.MaskAsBytes[iPos mod 4]; //apply mask + aData[iPos] := iByte; + inc(iPos); + end; + + //send masked data + Result := Binding.Send(aData); + end; + finally + strmData.Free; + end; +end; + +end. diff --git a/IdServerIOHandlerWebsocket.pas b/IdServerIOHandlerWebsocket.pas index fe10bd1..80e1061 100644 --- a/IdServerIOHandlerWebsocket.pas +++ b/IdServerIOHandlerWebsocket.pas @@ -26,7 +26,10 @@ function TIdServerIOHandlerWebsocket.Accept(ASocket: TIdSocketHandle; begin Result := inherited Accept(ASocket, AListenerThread, AYarn); if Result <> nil then + begin (Result as TIdIOHandlerWebsocket).IsServerSide := True; //server must not mask, only client + (Result as TIdIOHandlerWebsocket).UseNagle := False; + end; end; procedure TIdServerIOHandlerWebsocket.InitComponent; @@ -40,7 +43,10 @@ function TIdServerIOHandlerWebsocket.MakeClientIOHandler( begin Result := inherited MakeClientIOHandler(ATheThread); if Result <> nil then + begin (Result as TIdIOHandlerWebsocket).IsServerSide := True; //server must not mask, only client + (Result as TIdIOHandlerWebsocket).UseNagle := False; + end; end; end. diff --git a/IdServerSocketIOHandling.pas b/IdServerSocketIOHandling.pas index d9d85dc..23b98dc 100644 --- a/IdServerSocketIOHandling.pas +++ b/IdServerSocketIOHandling.pas @@ -13,14 +13,14 @@ type protected procedure ProcessHeatbeatRequest(const AContext: TSocketIOContext; const aText: string); override; public - function SendToAll(const aMessage: string; const aCallback: TSocketIOMsgJSON = nil): Integer; - procedure SendTo (const aContext: TIdServerContext; const aMessage: string; const aCallback: TSocketIOMsgJSON = nil); + function SendToAll(const aMessage: string; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil): Integer; + procedure SendTo (const aContext: TIdServerContext; const aMessage: string; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil); - function EmitEventToAll(const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil): Integer; + function EmitEventToAll(const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil): Integer; procedure EmitEventTo (const aContext: TSocketIOContext; - const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil);overload; + const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);overload; procedure EmitEventTo (const aContext: TIdServerContext; - const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil);overload; + const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);overload; end; implementation @@ -32,7 +32,7 @@ uses procedure TIdServerSocketIOHandling.EmitEventTo( const aContext: TSocketIOContext; const aEventName: string; - const aData: ISuperObject; const aCallback: TSocketIOMsgJSON); + const aData: ISuperObject; const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError); var jsonarray: string; begin @@ -47,32 +47,32 @@ begin jsonarray := '[' + aData.AsString + ']'; if not Assigned(aCallback) then - WriteSocketIOEvent(aContext, ''{no room}, aEventName, jsonarray, nil) + WriteSocketIOEvent(aContext, ''{no room}, aEventName, jsonarray, nil, nil) else WriteSocketIOEventRef(aContext, ''{no room}, aEventName, jsonarray, procedure(const aData: string) begin aCallback(aContext, SO(aData), nil); - end); + end, aOnError); end; procedure TIdServerSocketIOHandling.EmitEventTo( const aContext: TIdServerContext; const aEventName: string; - const aData: ISuperObject; const aCallback: TSocketIOMsgJSON); + const aData: ISuperObject; const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError); var context: TSocketIOContext; begin Lock; try context := FConnections.Items[aContext]; - EmitEventTo(context, aEventName, aData, aCallback); + EmitEventTo(context, aEventName, aData, aCallback, aOnError); finally UnLock; end; end; function TIdServerSocketIOHandling.EmitEventToAll(const aEventName: string; const aData: ISuperObject; - const aCallback: TSocketIOMsgJSON): Integer; + const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError): Integer; var context: TSocketIOContext; jsonarray: string; @@ -92,13 +92,13 @@ begin if context.IsDisconnected then Continue; if not Assigned(aCallback) then - WriteSocketIOEvent(context, ''{no room}, aEventName, jsonarray, nil) + WriteSocketIOEvent(context, ''{no room}, aEventName, jsonarray, nil, nil) else WriteSocketIOEventRef(context, ''{no room}, aEventName, jsonarray, procedure(const aData: string) begin aCallback(context, SO(aData), nil); - end); + end, aOnError); Inc(Result); end; for context in FConnectionsGUID.Values do @@ -106,13 +106,13 @@ begin if context.IsDisconnected then Continue; if not Assigned(aCallback) then - WriteSocketIOEvent(context, ''{no room}, aEventName, jsonarray, nil) + WriteSocketIOEvent(context, ''{no room}, aEventName, jsonarray, nil, nil) else WriteSocketIOEventRef(context, ''{no room}, aEventName, jsonarray, procedure(const aData: string) begin aCallback(context, SO(aData), nil); - end); + end, aOnError); Inc(Result); end; finally @@ -127,7 +127,7 @@ begin end; procedure TIdServerSocketIOHandling.SendTo(const aContext: TIdServerContext; - const aMessage: string; const aCallback: TSocketIOMsgJSON); + const aMessage: string; const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError); var context: TSocketIOContext; begin @@ -144,14 +144,14 @@ begin procedure(const aData: string) begin aCallback(context, SO(aData), nil); - end); + end, aOnError); finally UnLock; end; end; function TIdServerSocketIOHandling.SendToAll(const aMessage: string; - const aCallback: TSocketIOMsgJSON): Integer; + const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError): Integer; var context: TSocketIOContext; begin @@ -169,7 +169,7 @@ begin procedure(const aData: string) begin aCallback(context, SO(aData), nil); - end); + end, aOnError); Inc(Result); end; for context in FConnectionsGUID.Values do diff --git a/IdServerWebsocketContext.pas b/IdServerWebsocketContext.pas index 2aa3142..b7159cb 100644 --- a/IdServerWebsocketContext.pas +++ b/IdServerWebsocketContext.pas @@ -75,7 +75,7 @@ end; function TIdServerWSContext.IsSocketIO: Boolean; begin //FDocument = '/socket.io/1/websocket/13412152' - Result := StartsText('/socket.io/1/websocket', FPath); + Result := StartsText('/socket.io/1/websocket/', FPath); end; end. diff --git a/IdServerWebsocketHandling.pas b/IdServerWebsocketHandling.pas index cd4aa9b..e01bb29 100644 --- a/IdServerWebsocketHandling.pas +++ b/IdServerWebsocketHandling.pas @@ -1,281 +1,289 @@ -unit IdServerWebsocketHandling; - -interface - -uses - IdContext, IdCustomHTTPServer, IdHashSHA1, - IdServerSocketIOHandling, IdServerWebsocketContext, - Classes, IdServerBaseHandling, IdIOHandlerWebsocket; - -type - TIdServerSocketIOHandling_Ext = class(TIdServerSocketIOHandling) - end; - - TIdServerWebsocketHandling = class(TIdServerBaseHandling) - protected - class procedure DoWSExecute(AThread: TIdContext; aSocketIOHandler: TIdServerSocketIOHandling_Ext);virtual; - class procedure HandleWSMessage(AContext: TIdServerWSContext; aType: TWSDataType; - aRequestStrm, aResponseStrm: TMemoryStream; - aSocketIOHandler: TIdServerSocketIOHandling_Ext);virtual; - public - class function ProcessServerCommandGet(AThread: TIdServerWSContext; - ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo): Boolean; - end; - -implementation - -uses - StrUtils, SysUtils, IdCustomTCPServer, IdCoderMIME; - -{ TIdServerWebsocketHandling } - -class procedure TIdServerWebsocketHandling.DoWSExecute(AThread: TIdContext; aSocketIOHandler: TIdServerSocketIOHandling_Ext); -var - strmRequest, strmResponse: TMemoryStream; - wscode: TWSDataCode; - wstype: TWSDataType; - context: TIdServerWSContext; -begin - context := nil; - try - context := AThread as TIdServerWSContext; - //todo: make seperate function + do it after first real write (not header!) - if context.IOHandler.BusyUpgrading then - begin - context.IOHandler.IsWebsocket := True; - context.IOHandler.BusyUpgrading := False; - end; - //initial connect - if context.IsSocketIO then - begin - Assert(aSocketIOHandler <> nil); - aSocketIOHandler.WriteConnect(context); - end; - //AThread.Connection.Socket.UseNagle := False; - - while AThread.Connection.Connected do - begin - if (AThread.Connection.IOHandler.InputBuffer.Size > 0) or - AThread.Connection.IOHandler.Readable(5 * 1000) then //wait 5s, else ping the client(!) - begin - strmResponse := TMemoryStream.Create; - strmRequest := TMemoryStream.Create; - try - context := AThread as TIdServerWSContext; - - strmRequest.Position := 0; - //first is the type: text or bin - wscode := TWSDataCode(context.IOHandler.ReadLongWord); - //then the length + data = stream - context.IOHandler.ReadStream(strmRequest); - strmRequest.Position := 0; - //ignore ping/pong messages - if wscode in [wdcPing, wdcPong] then - begin - if wscode = wdcPing then - context.IOHandler.WriteData(nil, wdcPong); - Continue; - end; - - if wscode = wdcText then - wstype := wdtText - else - wstype := wdtBinary; - - HandleWSMessage(context, wstype, strmRequest, strmResponse, aSocketIOHandler); - - //write result back (of the same type: text or bin) - if strmResponse.Size > 0 then - begin - if wscode = wdcText then - context.IOHandler.Write(strmResponse, wdtText) - else - context.IOHandler.Write(strmResponse, wdtBinary) - end - else - context.IOHandler.WriteData(nil, wdcPing); - finally - strmRequest.Free; - strmResponse.Free; - end; - end - else - begin - //ping - if context.IsSocketIO then - begin - //context.SocketIOPingSend := True; - Assert(aSocketIOHandler <> nil); - aSocketIOHandler.WritePing(context); - end - else - context.IOHandler.WriteData(nil, wdcPing); - end; - - end; - finally - if context.IsSocketIO then - begin - Assert(aSocketIOHandler <> nil); - aSocketIOHandler.WriteDisConnect(context); - end; - - AThread.Data := nil; - end; -end; - -class procedure TIdServerWebsocketHandling.HandleWSMessage(AContext: TIdServerWSContext; aType: TWSDataType; - aRequestStrm, aResponseStrm: TMemoryStream; - aSocketIOHandler: TIdServerSocketIOHandling_Ext); -begin - if AContext.IsSocketIO then - begin - aRequestStrm.Position := 0; - Assert(aSocketIOHandler <> nil); - aSocketIOHandler.ProcessSocketIORequest(AContext, aRequestStrm); - end - else if Assigned(AContext.OnCustomChannelExecute) then - AContext.OnCustomChannelExecute(AContext, aType, aRequestStrm, aResponseStrm); -end; - -class function TIdServerWebsocketHandling.ProcessServerCommandGet( - AThread: TIdServerWSContext; ARequestInfo: TIdHTTPRequestInfo; - AResponseInfo: TIdHTTPResponseInfo): Boolean; -var - sValue, squid: string; - context: TIdServerWSContext; - hash: TIdHashSHA1; - guid: TGUID; -begin - (* GET /chat HTTP/1.1 - Host: server.example.com - Upgrade: websocket - Connection: Upgrade - Sec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ== - Origin: http://example.com - Sec-WebSocket-Protocol: chat, superchat - Sec-WebSocket-Version: 13 *) - - (* GET ws://echo.websocket.org/?encoding=text HTTP/1.1 - Origin: http://websocket.org - Cookie: __utma=99as - Connection: Upgrade - Host: echo.websocket.org - Sec-WebSocket-Key: uRovscZjNol/umbTt5uKmw== - Upgrade: websocket - Sec-WebSocket-Version: 13 *) - - //Connection: Upgrade - if not SameText('Upgrade', ARequestInfo.Connection) then - begin - //initiele ondersteuning voor socket.io - if SameText(ARequestInfo.document , '/socket.io/1/') then - begin - { - https://github.com/LearnBoost/socket.io-spec - The client will perform an initial HTTP POST request like the following - http://example.com/socket.io/1/ - 200: The handshake was successful. - The body of the response should contain the session id (sid) given to the client, followed by the heartbeat timeout, the connection closing timeout, and the list of supported transports separated by : - The absence of a heartbeat timeout ('') is interpreted as the server and client not expecting heartbeats. - For example 4d4f185e96a7b:15:10:websocket,xhr-polling. - } - AResponseInfo.ResponseNo := 200; - AResponseInfo.ResponseText := 'Socket.io connect OK'; - - CreateGUID(guid); - squid := GUIDToString(guid); - AResponseInfo.ContentText := squid + - ':15:10:websocket,xhr-polling'; - AResponseInfo.CloseConnection := False; - //(AThread.SocketIO as TIdServerSocketIOHandling_Ext).NewConnection(AThread); - (AThread.SocketIO as TIdServerSocketIOHandling_Ext).NewConnection(squid, AThread.Binding.PeerIP); - - Result := True; //handled - end - //'/socket.io/1/xhr-polling/2129478544' - else if StartsText('/socket.io/1/xhr-polling/', ARequestInfo.document) then - begin - AResponseInfo.ContentStream := TMemoryStream.Create; - AResponseInfo.CloseConnection := False; - - squid := Copy(ARequestInfo.Document, 1 + Length('/socket.io/1/xhr-polling/'), Length(ARequestInfo.document)); - if ARequestInfo.CommandType = hcGET then - (AThread.SocketIO as TIdServerSocketIOHandling_Ext) - .ProcessSocketIO_XHR(squid, ARequestInfo.PostStream, AResponseInfo.ContentStream) - else if ARequestInfo.CommandType = hcPOST then - (AThread.SocketIO as TIdServerSocketIOHandling_Ext) - .ProcessSocketIO_XHR(squid, ARequestInfo.PostStream, nil); //no response expected with POST! - Result := True; //handled - end - else - Result := False; //NOT handled - end - else - begin - Result := True; //handled - context := AThread as TIdServerWSContext; - - //Sec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ== - sValue := ARequestInfo.RawHeaders.Values['sec-websocket-key']; - //"The value of this header field MUST be a nonce consisting of a randomly - // selected 16-byte value that has been base64-encoded" +unit IdServerWebsocketHandling; + +interface + +uses + IdContext, IdCustomHTTPServer, + {$IF CompilerVersion <= 21.0} //D2010 + IdHashSHA1, + {$else} + IdHashSHA, //XE3 etc + {$IFEND} + IdServerSocketIOHandling, IdServerWebsocketContext, + Classes, IdServerBaseHandling, IdIOHandlerWebsocket; + +type + TIdServerSocketIOHandling_Ext = class(TIdServerSocketIOHandling) + end; + + TIdServerWebsocketHandling = class(TIdServerBaseHandling) + protected + class procedure DoWSExecute(AThread: TIdContext; aSocketIOHandler: TIdServerSocketIOHandling_Ext);virtual; + class procedure HandleWSMessage(AContext: TIdServerWSContext; aType: TWSDataType; + aRequestStrm, aResponseStrm: TMemoryStream; + aSocketIOHandler: TIdServerSocketIOHandling_Ext);virtual; + public + class function ProcessServerCommandGet(AThread: TIdServerWSContext; + ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo): Boolean; + end; + +implementation + +uses + StrUtils, SysUtils, IdCustomTCPServer, IdCoderMIME; + +{ TIdServerWebsocketHandling } + +class procedure TIdServerWebsocketHandling.DoWSExecute(AThread: TIdContext; aSocketIOHandler: TIdServerSocketIOHandling_Ext); +var + strmRequest, strmResponse: TMemoryStream; + wscode: TWSDataCode; + wstype: TWSDataType; + context: TIdServerWSContext; +begin + context := nil; + try + context := AThread as TIdServerWSContext; + //todo: make seperate function + do it after first real write (not header!) + if context.IOHandler.BusyUpgrading then + begin + context.IOHandler.IsWebsocket := True; + context.IOHandler.BusyUpgrading := False; + end; + //initial connect + if context.IsSocketIO then + begin + Assert(aSocketIOHandler <> nil); + aSocketIOHandler.WriteConnect(context); + end; + //AThread.Connection.Socket.UseNagle := False; + + while AThread.Connection.Connected do + begin + if (AThread.Connection.IOHandler.InputBuffer.Size > 0) or + AThread.Connection.IOHandler.Readable(5 * 1000) then //wait 5s, else ping the client(!) + begin + strmResponse := TMemoryStream.Create; + strmRequest := TMemoryStream.Create; + try + context := AThread as TIdServerWSContext; + + strmRequest.Position := 0; + //first is the type: text or bin + wscode := TWSDataCode(context.IOHandler.ReadLongWord); + //then the length + data = stream + context.IOHandler.ReadStream(strmRequest); + strmRequest.Position := 0; + //ignore ping/pong messages + if wscode in [wdcPing, wdcPong] then + begin + if wscode = wdcPing then + context.IOHandler.WriteData(nil, wdcPong); + Continue; + end; + + if wscode = wdcText then + wstype := wdtText + else + wstype := wdtBinary; + + HandleWSMessage(context, wstype, strmRequest, strmResponse, aSocketIOHandler); + + //write result back (of the same type: text or bin) + if strmResponse.Size > 0 then + begin + if wscode = wdcText then + context.IOHandler.Write(strmResponse, wdtText) + else + context.IOHandler.Write(strmResponse, wdtBinary) + end + else + context.IOHandler.WriteData(nil, wdcPing); + finally + strmRequest.Free; + strmResponse.Free; + end; + end + else + begin + //ping + if context.IsSocketIO then + begin + //context.SocketIOPingSend := True; + Assert(aSocketIOHandler <> nil); + aSocketIOHandler.WritePing(context); + end + else + context.IOHandler.WriteData(nil, wdcPing); + end; + + end; + finally + if context.IsSocketIO then + begin + Assert(aSocketIOHandler <> nil); + aSocketIOHandler.WriteDisConnect(context); + end; + + AThread.Data := nil; + end; +end; + +class procedure TIdServerWebsocketHandling.HandleWSMessage(AContext: TIdServerWSContext; aType: TWSDataType; + aRequestStrm, aResponseStrm: TMemoryStream; + aSocketIOHandler: TIdServerSocketIOHandling_Ext); +begin + if AContext.IsSocketIO then + begin + aRequestStrm.Position := 0; + Assert(aSocketIOHandler <> nil); + aSocketIOHandler.ProcessSocketIORequest(AContext, aRequestStrm); + end + else if Assigned(AContext.OnCustomChannelExecute) then + AContext.OnCustomChannelExecute(AContext, aType, aRequestStrm, aResponseStrm); +end; + +class function TIdServerWebsocketHandling.ProcessServerCommandGet( + AThread: TIdServerWSContext; ARequestInfo: TIdHTTPRequestInfo; + AResponseInfo: TIdHTTPResponseInfo): Boolean; +var + sValue, squid: string; + context: TIdServerWSContext; + hash: TIdHashSHA1; + guid: TGUID; +begin + (* GET /chat HTTP/1.1 + Host: server.example.com + Upgrade: websocket + Connection: Upgrade + Sec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ== + Origin: http://example.com + Sec-WebSocket-Protocol: chat, superchat + Sec-WebSocket-Version: 13 *) + + (* GET ws://echo.websocket.org/?encoding=text HTTP/1.1 + Origin: http://websocket.org + Cookie: __utma=99as + Connection: Upgrade + Host: echo.websocket.org + Sec-WebSocket-Key: uRovscZjNol/umbTt5uKmw== + Upgrade: websocket + Sec-WebSocket-Version: 13 *) + + //Connection: Upgrade + if not SameText('Upgrade', ARequestInfo.Connection) then + begin + //initiele ondersteuning voor socket.io + if SameText(ARequestInfo.document , '/socket.io/1/') then + begin + { + https://github.com/LearnBoost/socket.io-spec + The client will perform an initial HTTP POST request like the following + http://example.com/socket.io/1/ + 200: The handshake was successful. + The body of the response should contain the session id (sid) given to the client, followed by the heartbeat timeout, the connection closing timeout, and the list of supported transports separated by : + The absence of a heartbeat timeout ('') is interpreted as the server and client not expecting heartbeats. + For example 4d4f185e96a7b:15:10:websocket,xhr-polling. + } + AResponseInfo.ResponseNo := 200; + AResponseInfo.ResponseText := 'Socket.io connect OK'; + + CreateGUID(guid); + squid := GUIDToString(guid); + AResponseInfo.ContentText := squid + + ':15:10:websocket,xhr-polling'; + AResponseInfo.CloseConnection := False; + //(AThread.SocketIO as TIdServerSocketIOHandling_Ext).NewConnection(AThread); + (AThread.SocketIO as TIdServerSocketIOHandling_Ext).NewConnection(squid, AThread.Binding.PeerIP); + + Result := True; //handled + end + //'/socket.io/1/xhr-polling/2129478544' + else if StartsText('/socket.io/1/xhr-polling/', ARequestInfo.document) then + begin + AResponseInfo.ContentStream := TMemoryStream.Create; + AResponseInfo.CloseConnection := False; + + squid := Copy(ARequestInfo.Document, 1 + Length('/socket.io/1/xhr-polling/'), Length(ARequestInfo.document)); + if ARequestInfo.CommandType = hcGET then + (AThread.SocketIO as TIdServerSocketIOHandling_Ext) + .ProcessSocketIO_XHR(squid, ARequestInfo.PostStream, AResponseInfo.ContentStream) + else if ARequestInfo.CommandType = hcPOST then + (AThread.SocketIO as TIdServerSocketIOHandling_Ext) + .ProcessSocketIO_XHR(squid, ARequestInfo.PostStream, nil); //no response expected with POST! + Result := True; //handled + end + else + Result := False; //NOT handled + end + else + begin + Result := True; //handled + context := AThread as TIdServerWSContext; + + //Sec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ== + sValue := ARequestInfo.RawHeaders.Values['sec-websocket-key']; + //"The value of this header field MUST be a nonce consisting of a randomly + // selected 16-byte value that has been base64-encoded" if (sValue <> '') then begin if (Length(TIdDecoderMIME.DecodeString(sValue)) = 16) then - context.WebSocketKey := sValue - else - Abort; //invalid length - end - else - //important: key must exists, otherwise stop! - Abort; - - (* - ws-URI = "ws:" "//" host [ ":" port ] path [ "?" query ] - wss-URI = "wss:" "//" host [ ":" port ] path [ "?" query ] - 2. The method of the request MUST be GET, and the HTTP version MUST be at least 1.1. - For example, if the WebSocket URI is "ws://example.com/chat", - the first line sent should be "GET /chat HTTP/1.1". - 3. The "Request-URI" part of the request MUST match the /resource - name/ defined in Section 3 (a relative URI) or be an absolute - http/https URI that, when parsed, has a /resource name/, /host/, - and /port/ that match the corresponding ws/wss URI. - *) - context.ResourceName := ARequestInfo.Document; - if ARequestInfo.UnparsedParams <> '' then - context.ResourceName := context.ResourceName + '?' + - ARequestInfo.UnparsedParams; - //seperate parts - context.Path := ARequestInfo.Document; - context.Query := ARequestInfo.UnparsedParams; - - //Host: server.example.com - context.Host := ARequestInfo.RawHeaders.Values['host']; - //Origin: http://example.com - context.Origin := ARequestInfo.RawHeaders.Values['origin']; - //Cookie: __utma=99as - context.Cookie := ARequestInfo.RawHeaders.Values['cookie']; - - //Sec-WebSocket-Version: 13 - //"The value of this header field MUST be 13" - sValue := ARequestInfo.RawHeaders.Values['sec-websocket-version']; + context.WebSocketKey := sValue + else + Abort; //invalid length + end + else + //important: key must exists, otherwise stop! + Abort; + + (* + ws-URI = "ws:" "//" host [ ":" port ] path [ "?" query ] + wss-URI = "wss:" "//" host [ ":" port ] path [ "?" query ] + 2. The method of the request MUST be GET, and the HTTP version MUST be at least 1.1. + For example, if the WebSocket URI is "ws://example.com/chat", + the first line sent should be "GET /chat HTTP/1.1". + 3. The "Request-URI" part of the request MUST match the /resource + name/ defined in Section 3 (a relative URI) or be an absolute + http/https URI that, when parsed, has a /resource name/, /host/, + and /port/ that match the corresponding ws/wss URI. + *) + context.ResourceName := ARequestInfo.Document; + if ARequestInfo.UnparsedParams <> '' then + context.ResourceName := context.ResourceName + '?' + + ARequestInfo.UnparsedParams; + //seperate parts + context.Path := ARequestInfo.Document; + context.Query := ARequestInfo.UnparsedParams; + + //Host: server.example.com + context.Host := ARequestInfo.RawHeaders.Values['host']; + //Origin: http://example.com + context.Origin := ARequestInfo.RawHeaders.Values['origin']; + //Cookie: __utma=99as + context.Cookie := ARequestInfo.RawHeaders.Values['cookie']; + + //Sec-WebSocket-Version: 13 + //"The value of this header field MUST be 13" + sValue := ARequestInfo.RawHeaders.Values['sec-websocket-version']; if (sValue <> '') then begin context.WebSocketVersion := StrToIntDef(sValue, 0); - if context.WebSocketVersion < 13 then - Abort; //must be at least 13 - end - else - Abort; //must exist - context.WebSocketProtocol := ARequestInfo.RawHeaders.Values['sec-websocket-protocol']; + if context.WebSocketVersion < 13 then + + Abort; //must be at least 13 + + end + else + Abort; //must exist + + context.WebSocketProtocol := ARequestInfo.RawHeaders.Values['sec-websocket-protocol']; context.WebSocketExtensions := ARequestInfo.RawHeaders.Values['sec-websocket-extensions']; //Response (* HTTP/1.1 101 Switching Protocols - Upgrade: websocket - Connection: Upgrade + Upgrade: websocket + Connection: Upgrade Sec-WebSocket-Accept: s3pPLMBiTxaQ9kYGzzhZRbK+xOo= *) AResponseInfo.ResponseNo := 101; AResponseInfo.ResponseText := 'Switching Protocols'; @@ -287,14 +295,14 @@ begin //Sec-WebSocket-Accept: s3pPLMBiTxaQ9kYGzzhZRbK+xOo= sValue := Trim(context.WebSocketKey) + //... "minus any leading and trailing whitespace" - '258EAFA5-E914-47DA-95CA-C5AB0DC85B11'; //special GUID - hash := TIdHashSHA1.Create; - try - sValue := TIdEncoderMIME.EncodeBytes( //Base64 - hash.HashString(sValue) ); //SHA1 - finally - hash.Free; - end; + '258EAFA5-E914-47DA-95CA-C5AB0DC85B11'; //special GUID + hash := TIdHashSHA1.Create; + try + sValue := TIdEncoderMIME.EncodeBytes( //Base64 + hash.HashString(sValue) ); //SHA1 + finally + hash.Free; + end; AResponseInfo.CustomHeaders.Values['Sec-WebSocket-Accept'] := sValue; //send same protocol back? @@ -308,10 +316,10 @@ begin context.IOHandler.InputBuffer.Clear; context.IOHandler.BusyUpgrading := True; AResponseInfo.WriteHeader; - + //handle all WS communication in seperate loop - DoWSExecute(AThread, (context.SocketIO as TIdServerSocketIOHandling_Ext) ); - end; -end; - -end. + DoWSExecute(AThread, (context.SocketIO as TIdServerSocketIOHandling_Ext) ); + end; +end; + +end. diff --git a/IdSocketIOHandling.pas b/IdSocketIOHandling.pas index 1472b23..994feec 100644 --- a/IdSocketIOHandling.pas +++ b/IdSocketIOHandling.pas @@ -19,6 +19,7 @@ type TSocketIOMsgJSON = reference to procedure(const ASocket: ISocketIOContext; const aJSON: ISuperObject; const aCallback: TSocketIOCallbackObj); TSocketIONotify = reference to procedure(const ASocket: ISocketIOContext); TSocketIOEvent = reference to procedure(const ASocket: ISocketIOContext; const aArgument: TSuperArray; const aCallbackObj: TSocketIOCallbackObj); + TSocketIOError = reference to procedure(const ASocket: ISocketIOContext; const aErrorClass, aErrorMessage: string); TSocketIONotifyList = class(TList); TSocketIOEventList = class(TList); @@ -31,9 +32,9 @@ type function PeerIP: string; function PeerPort: Integer; - procedure EmitEvent(const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil); - procedure Send(const aData: string; const aCallback: TSocketIOMsgJSON = nil); - procedure SendJSON(const aJSON: ISuperObject; const aCallback: TSocketIOMsgJSON = nil); + procedure EmitEvent(const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil); + procedure Send(const aData: string; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil); + procedure SendJSON(const aJSON: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil); end; TSocketIOContext = class(TInterfacedObject, @@ -78,10 +79,10 @@ type //todo: OnEvent per socket //todo: store session info per connection (see Socket.IO Set + Get -> Storing data associated to a client) //todo: namespace using "Of" - procedure EmitEvent(const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil); + procedure EmitEvent(const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil); // procedure BroadcastEventToOthers(const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil); - procedure Send(const aData: string; const aCallback: TSocketIOMsgJSON = nil); - procedure SendJSON(const aJSON: ISuperObject; const aCallback: TSocketIOMsgJSON = nil); + procedure Send(const aData: string; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil); + procedure SendJSON(const aJSON: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil); end; TSocketIOCallbackObj = class @@ -91,6 +92,7 @@ type FMsgNr: Integer; public procedure SendResponse(const aResponse: string); + function IsResponseSend: Boolean; end; TIdBaseSocketIOHandling = class(TIdServerBaseHandling) @@ -113,6 +115,7 @@ type FSocketIOMsgNr: Integer; FSocketIOEventCallback: TDictionary; FSocketIOEventCallbackRef: TDictionary; + FSocketIOErrorRef: TDictionary; function WriteConnect(const ASocket: TSocketIOContext): string; overload; procedure WriteDisConnect(const ASocket: TSocketIOContext);overload; @@ -122,10 +125,10 @@ type procedure WriteDisConnect(const AContext: TIdContext);overload; procedure WritePing(const AContext: TIdContext);overload; - procedure WriteSocketIOMsg(const ASocket: TSocketIOContext; const aRoom, aData: string; aCallback: TSocketIOCallbackRef = nil); - procedure WriteSocketIOJSON(const ASocket: TSocketIOContext; const aRoom, aJSON: string; aCallback: TSocketIOCallbackRef = nil); - procedure WriteSocketIOEvent(const ASocket: TSocketIOContext; const aRoom, aEventName, aJSONArray: string; aCallback: TSocketIOCallback); - procedure WriteSocketIOEventRef(const ASocket: TSocketIOContext; const aRoom, aEventName, aJSONArray: string; aCallback: TSocketIOCallbackRef); + procedure WriteSocketIOMsg(const ASocket: TSocketIOContext; const aRoom, aData: string; aCallback: TSocketIOCallbackRef = nil; const aOnError: TSocketIOError = nil); + procedure WriteSocketIOJSON(const ASocket: TSocketIOContext; const aRoom, aJSON: string; aCallback: TSocketIOCallbackRef = nil; const aOnError: TSocketIOError = nil); + procedure WriteSocketIOEvent(const ASocket: TSocketIOContext; const aRoom, aEventName, aJSONArray: string; aCallback: TSocketIOCallback; const aOnError: TSocketIOError); + procedure WriteSocketIOEventRef(const ASocket: TSocketIOContext; const aRoom, aEventName, aJSONArray: string; aCallback: TSocketIOCallbackRef; const aOnError: TSocketIOError); procedure WriteSocketIOResult(const ASocket: TSocketIOContext; aRequestMsgNr: Integer; const aRoom, aData: string); procedure ProcessSocketIO_XHR(const aGUID: string; const aStrmRequest, aStrmResponse: TStream); @@ -160,8 +163,8 @@ type TIdSocketIOHandling = class(TIdBaseSocketIOHandling) public - procedure Send(const aMessage: string; const aCallback: TSocketIOMsgJSON = nil); - procedure Emit(const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil); + procedure Send(const aMessage: string; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil); + procedure Emit(const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil); end; implementation @@ -181,6 +184,7 @@ begin FSocketIOEventCallback := TDictionary.Create; FSocketIOEventCallbackRef := TDictionary.Create; + FSocketIOErrorRef := TDictionary.Create; end; destructor TIdBaseSocketIOHandling.Destroy; @@ -189,6 +193,7 @@ var squid: string; begin FSocketIOEventCallback.Free; FSocketIOEventCallbackRef.Free; + FSocketIOErrorRef.Free; FOnEventList.Free; FOnConnectionList.Free; @@ -348,7 +353,7 @@ procedure TIdBaseSocketIOHandling.ProcessCloseChannel( begin if aChannel <> '' then //todo: close channel - else + else if (ASocket.FContext <> nil) then ASocket.FContext.Connection.Disconnect; end; @@ -576,6 +581,8 @@ var callback: TSocketIOCallback; callbackref: TSocketIOCallbackRef; callbackobj: TSocketIOCallbackObj; + errorref: TSocketIOError; + error: ISuperObject; begin if not FConnections.ContainsValue(ASocket) and not FConnectionsGUID.ContainsValue(ASocket) then @@ -640,7 +647,15 @@ begin callbackobj.FHandling := Self; callbackobj.FSocket := ASocket; callbackobj.FMsgNr := imsg; + try OnSocketIOMsg(ASocket, sdata, callbackobj); //, imsg, bCallback); + except + on E:Exception do + begin + if not callbackobj.IsResponseSend then + callbackobj.SendResponse( SO(['Error', SO(['Type', e.ClassName, 'Message', e.Message])]).AsJSon ); + end; + end; finally callbackobj.Free; end @@ -665,7 +680,15 @@ begin callbackobj.FHandling := Self; callbackobj.FSocket := ASocket; callbackobj.FMsgNr := imsg; + try OnSocketIOJson(ASocket, SO(sdata), callbackobj); //, imsg, bCallback); + except + on E:Exception do + begin + if not callbackobj.IsResponseSend then + callbackobj.SendResponse( SO(['Error', SO(['Type', e.ClassName, 'Message', e.Message])]).AsJSon ); + end; + end; finally callbackobj.Free; end @@ -700,6 +723,24 @@ begin imsg := StrToIntDef(smsg, 0); sData := Copy(sdata, Pos('+', sData)+1, Length(sData)); + if FSocketIOErrorRef.TryGetValue(imsg, errorref) then + begin + FSocketIOErrorRef.Remove(imsg); + //'[{"Error":{"Message":"Operation aborted","Type":"EAbort"}}]' + if ContainsText(sdata, '{"Error":') then + begin + error := SO(sdata); + if error.IsType(stArray) then + error := error.O['0']; + error := error.O['Error']; + if error.S['Message'] <> '' then + errorref(ASocket, error.S['Type'], error.S['Message']) + else + errorref(ASocket, 'Unknown', sdata); + Exit; + end; + end; + if FSocketIOEventCallback.TryGetValue(imsg, callback) then begin FSocketIOEventCallback.Remove(imsg); @@ -782,7 +823,7 @@ begin end; procedure TIdBaseSocketIOHandling.WriteSocketIOEvent(const ASocket: TSocketIOContext; const aRoom, aEventName, - aJSONArray: string; aCallback: TSocketIOCallback); + aJSONArray: string; aCallback: TSocketIOCallback; const aOnError: TSocketIOError); var sresult: string; begin @@ -799,12 +840,15 @@ begin sresult := Format('5:%d+:%s:{"name":"%s", "args":%s}', [FSocketIOMsgNr, aRoom, aEventName, aJSONArray]); FSocketIOEventCallback.Add(FSocketIOMsgNr, aCallback); + + if Assigned(aOnError) then + FSocketIOErrorRef.Add(FSocketIOMsgNr, aOnError); end; WriteString(ASocket, sresult); end; procedure TIdBaseSocketIOHandling.WriteSocketIOEventRef(const ASocket: TSocketIOContext; - const aRoom, aEventName, aJSONArray: string; aCallback: TSocketIOCallbackRef); + const aRoom, aEventName, aJSONArray: string; aCallback: TSocketIOCallbackRef; const aOnError: TSocketIOError); var sresult: string; begin @@ -821,12 +865,15 @@ begin sresult := Format('5:%d+:%s:{"name":"%s", "args":%s}', [FSocketIOMsgNr, aRoom, aEventName, aJSONArray]); FSocketIOEventCallbackRef.Add(FSocketIOMsgNr, aCallback); + + if Assigned(aOnError) then + FSocketIOErrorRef.Add(FSocketIOMsgNr, aOnError); end; WriteString(ASocket, sresult); end; procedure TIdBaseSocketIOHandling.WriteSocketIOJSON(const ASocket: TSocketIOContext; - const aRoom, aJSON: string; aCallback: TSocketIOCallbackRef = nil); + const aRoom, aJSON: string; aCallback: TSocketIOCallbackRef = nil; const aOnError: TSocketIOError = nil); var sresult: string; begin @@ -843,13 +890,16 @@ begin sresult := Format('4:%d+:%s:%s', [FSocketIOMsgNr, aRoom, aJSON]); FSocketIOEventCallbackRef.Add(FSocketIOMsgNr, aCallback); + + if Assigned(aOnError) then + FSocketIOErrorRef.Add(FSocketIOMsgNr, aOnError); end; WriteString(ASocket, sresult); end; procedure TIdBaseSocketIOHandling.WriteSocketIOMsg(const ASocket: TSocketIOContext; - const aRoom, aData: string; aCallback: TSocketIOCallbackRef = nil); + const aRoom, aData: string; aCallback: TSocketIOCallbackRef = nil; const aOnError: TSocketIOError = nil); var sresult: string; begin @@ -866,6 +916,9 @@ begin sresult := Format('3:%d+:%s:%s', [FSocketIOMsgNr, aRoom, aData]); FSocketIOEventCallbackRef.Add(FSocketIOMsgNr, aCallback); + + if Assigned(aOnError) then + FSocketIOErrorRef.Add(FSocketIOMsgNr, aOnError); end; WriteString(ASocket, sresult); @@ -896,7 +949,7 @@ begin if (ASocket.FIOHandler <> nil) then begin - Assert(ASocket.FIOHandler.IsWebsocket); + //Assert(ASocket.FIOHandler.IsWebsocket); if DebugHook <> 0 then Windows.OutputDebugString(PChar('Send: ' + aText)); ASocket.FIOHandler.Write(aText); @@ -915,9 +968,15 @@ end; { TSocketIOCallbackObj } +function TSocketIOCallbackObj.IsResponseSend: Boolean; +begin + Result := (FMsgNr < 0); +end; + procedure TSocketIOCallbackObj.SendResponse(const aResponse: string); begin FHandling.WriteSocketIOResult(FSocket, FMsgNr, '', aResponse); + FMsgNr := -1; end; { TSocketIOContext } @@ -940,17 +999,17 @@ begin end; procedure TSocketIOContext.EmitEvent(const aEventName: string; const aData: ISuperObject; - const aCallback: TSocketIOMsgJSON); + const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError); begin if not Assigned(aCallback) then - FHandling.WriteSocketIOEvent(Self, '', aEventName, aData.AsJSon, nil) + FHandling.WriteSocketIOEvent(Self, '', aEventName, aData.AsJSon, nil, nil) else begin FHandling.WriteSocketIOEventRef(Self, '', aEventName, aData.AsJSon, procedure(const aData: string) begin aCallback(Self, SO(aData), nil); - end); + end, aOnError); end; end; @@ -1007,7 +1066,7 @@ begin end; procedure TSocketIOContext.Send(const aData: string; - const aCallback: TSocketIOMsgJSON); + const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError); begin if not Assigned(aCallback) then FHandling.WriteSocketIOMsg(Self, '', aData) @@ -1017,12 +1076,12 @@ begin procedure(const aData: string) begin aCallback(Self, SO(aData), nil); - end); + end, aOnError); end; end; procedure TSocketIOContext.SendJSON(const aJSON: ISuperObject; - const aCallback: TSocketIOMsgJSON); + const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError); begin if not Assigned(aCallback) then FHandling.WriteSocketIOJSON(Self, '', aJSON.AsJSon()) @@ -1032,7 +1091,7 @@ begin procedure(const aData: string) begin aCallback(Self, SO(aData), nil); - end); + end, aOnError); end; end; @@ -1131,7 +1190,7 @@ end; { TIdSocketIOHandling } procedure TIdSocketIOHandling.Emit(const aEventName: string; - const aData: ISuperObject; const aCallback: TSocketIOMsgJSON); + const aData: ISuperObject; const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError); var context: TSocketIOContext; jsonarray: string; @@ -1154,13 +1213,13 @@ begin if context.IsDisconnected then Continue; if not Assigned(aCallback) then - WriteSocketIOEvent(context, ''{no room}, aEventName, jsonarray, nil) + WriteSocketIOEvent(context, ''{no room}, aEventName, jsonarray, nil, nil) else WriteSocketIOEventRef(context, ''{no room}, aEventName, jsonarray, procedure(const aData: string) begin aCallback(context, SO(aData), nil); - end); + end, aOnError); Inc(isendcount); end; for context in FConnectionsGUID.Values do @@ -1168,13 +1227,13 @@ begin if context.IsDisconnected then Continue; if not Assigned(aCallback) then - WriteSocketIOEvent(context, ''{no room}, aEventName, jsonarray, nil) + WriteSocketIOEvent(context, ''{no room}, aEventName, jsonarray, nil, nil) else WriteSocketIOEventRef(context, ''{no room}, aEventName, jsonarray, procedure(const aData: string) begin aCallback(context, SO(aData), nil); - end); + end, aOnError); Inc(isendcount); end; @@ -1186,7 +1245,7 @@ begin end; procedure TIdSocketIOHandling.Send(const aMessage: string; - const aCallback: TSocketIOMsgJSON); + const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError); var context: TSocketIOContext; isendcount: Integer; @@ -1209,7 +1268,7 @@ begin procedure(const aData: string) begin aCallback(context, SO(aData), nil); - end); + end, aOnError); Inc(isendcount); end; for context in FConnectionsGUID.Values do @@ -1225,7 +1284,7 @@ begin procedure(const aData: string) begin aCallback(context, SO(aData), nil); - end); + end, aOnError); Inc(isendcount); end; diff --git a/superobject/superobject.pas b/superobject/superobject.pas new file mode 100644 index 0000000..c3db269 --- /dev/null +++ b/superobject/superobject.pas @@ -0,0 +1,6572 @@ +(* + * Super Object Toolkit + * + * Usage allowed under the restrictions of the Lesser GNU General Public License + * or alternatively the restrictions of the Mozilla Public License 1.1 + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for + * the specific language governing rights and limitations under the License. + * + * Unit owner : Henri Gourvest + * Web site : http://www.progdigy.com + * + * This unit is inspired from the json c lib: + * Michael Clark + * http://oss.metaparadigm.com/json-c/ + * + * CHANGES: + * v1.2 + * + support of currency data type + * + right trim unquoted string + * + read Unicode Files and streams (Litle Endian with BOM) + * + Fix bug on javadate functions + windows nt compatibility + * + Now you can force to parse only the canonical syntax of JSON using the stric parameter + * + Delphi 2010 RTTI marshalling + * v1.1 + * + Double licence MPL or LGPL. + * + Delphi 2009 compatibility & Unicode support. + * + AsString return a string instead of PChar. + * + Escaped and Unascaped JSON serialiser. + * + Missed FormFeed added \f + * - Removed @ trick, uses forcepath() method instead. + * + Fixed parse error with uppercase E symbol in numbers. + * + Fixed possible buffer overflow when enlarging array. + * + Added "delete", "pack", "insert" methods for arrays and/or objects + * + Multi parametters when calling methods + * + Delphi Enumerator (for obj1 in obj2 do ...) + * + Format method ex: obj.format('<%name%>%tab[1]%') + * + ParseFile and ParseStream methods + * + Parser now understand hexdecimal c syntax ex: \xFF + * + Null Object Design Patern (ex: for obj in values.N['path'] do ...) + * v1.0 + * + renamed class + * + interfaced object + * + added a new data type: the method + * + parser can now evaluate properties and call methods + * - removed obselet rpc class + * - removed "find" method, now you can use "parse" method instead + * v0.6 + * + refactoring + * v0.5 + * + new find method to get or set value using a path syntax + * ex: obj.s['obj.prop[1]'] := 'string value'; + * obj.a['@obj.array'].b[n] := true; // @ -> create property if necessary + * v0.4 + * + bug corrected: AVL tree badly balanced. + * v0.3 + * + New validator partially based on the Kwalify syntax. + * + extended syntax to parse unquoted fields. + * + Freepascal compatibility win32/64 Linux32/64. + * + JavaToDelphiDateTime and DelphiToJavaDateTime improved for UTC. + * + new TJsonObject.Compare function. + * v0.2 + * + Hashed string list replaced with a faster AVL tree + * + JsonInt data type can be changed to int64 + * + JavaToDelphiDateTime and DelphiToJavaDateTime helper fonctions + * + from json-c v0.7 + * + Add escaping of backslash to json output + * + Add escaping of foward slash on tokenizing and output + * + Changes to internal tokenizer from using recursion to + * using a depth state structure to allow incremental parsing + * v0.1 + * + first release + *) + +{$IFDEF FPC} + {$MODE OBJFPC}{$H+} +{$ENDIF} + +{$DEFINE SUPER_METHOD} +{$DEFINE WINDOWSNT_COMPATIBILITY} +{.$DEFINE DEBUG} // track memory leack + +unit superobject; + +interface +uses + Classes +{$IFDEF VER210} + ,Generics.Collections, RTTI, TypInfo +{$ENDIF} + ; + +type +{$IFNDEF FPC} + PtrInt = longint; + PtrUInt = Longword; +{$ENDIF} + SuperInt = Int64; + +{$if (sizeof(Char) = 1)} + SOChar = WideChar; + SOIChar = Word; + PSOChar = PWideChar; + SOString = WideString; +{$else} + SOChar = Char; + SOIChar = Word; + PSOChar = PChar; + SOString = string; +{$ifend} + +const + SUPER_ARRAY_LIST_DEFAULT_SIZE = 32; + SUPER_TOKENER_MAX_DEPTH = 32; + + SUPER_AVL_MAX_DEPTH = sizeof(longint) * 8; + SUPER_AVL_MASK_HIGH_BIT = not ((not longword(0)) shr 1); + +type + // forward declarations + TSuperObject = class; + ISuperObject = interface; + TSuperArray = class; + +(* AVL Tree + * This is a "special" autobalanced AVL tree + * It use a hash value for fast compare + *) + +{$IFDEF SUPER_METHOD} + TSuperMethod = procedure(const This, Params: ISuperObject; var Result: ISuperObject); +{$ENDIF} + + + TSuperAvlBitArray = set of 0..SUPER_AVL_MAX_DEPTH - 1; + + TSuperAvlSearchType = (stEQual, stLess, stGreater); + TSuperAvlSearchTypes = set of TSuperAvlSearchType; + TSuperAvlIterator = class; + + TSuperAvlEntry = class + private + FGt, FLt: TSuperAvlEntry; + FBf: integer; + FHash: Cardinal; + FName: SOString; + FPtr: Pointer; + function GetValue: ISuperObject; + procedure SetValue(const val: ISuperObject); + public + class function Hash(const k: SOString): Cardinal; virtual; + constructor Create(const AName: SOString; Obj: Pointer); virtual; + property Name: SOString read FName; + property Ptr: Pointer read FPtr; + property Value: ISuperObject read GetValue write SetValue; + end; + + TSuperAvlTree = class + private + FRoot: TSuperAvlEntry; + FCount: Integer; + function balance(bal: TSuperAvlEntry): TSuperAvlEntry; + protected + procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); virtual; + function CompareNodeNode(node1, node2: TSuperAvlEntry): integer; virtual; + function CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer; virtual; + function Insert(h: TSuperAvlEntry): TSuperAvlEntry; virtual; + function Search(const k: SOString; st: TSuperAvlSearchTypes = [stEqual]): TSuperAvlEntry; virtual; + public + constructor Create; virtual; + destructor Destroy; override; + function IsEmpty: boolean; + procedure Clear(all: boolean = false); virtual; + procedure Pack(all: boolean); + function Delete(const k: SOString): ISuperObject; + function GetEnumerator: TSuperAvlIterator; + property count: Integer read FCount; + end; + + TSuperTableString = class(TSuperAvlTree) + protected + procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); override; + procedure PutO(const k: SOString; const value: ISuperObject); + function GetO(const k: SOString): ISuperObject; + procedure PutS(const k: SOString; const value: SOString); + function GetS(const k: SOString): SOString; + procedure PutI(const k: SOString; value: SuperInt); + function GetI(const k: SOString): SuperInt; + procedure PutD(const k: SOString; value: Double); + function GetD(const k: SOString): Double; + procedure PutB(const k: SOString; value: Boolean); + function GetB(const k: SOString): Boolean; +{$IFDEF SUPER_METHOD} + procedure PutM(const k: SOString; value: TSuperMethod); + function GetM(const k: SOString): TSuperMethod; +{$ENDIF} + procedure PutN(const k: SOString; const value: ISuperObject); + function GetN(const k: SOString): ISuperObject; + procedure PutC(const k: SOString; value: Currency); + function GetC(const k: SOString): Currency; + public + property O[const k: SOString]: ISuperObject read GetO write PutO; default; + property S[const k: SOString]: SOString read GetS write PutS; + property I[const k: SOString]: SuperInt read GetI write PutI; + property D[const k: SOString]: Double read GetD write PutD; + property B[const k: SOString]: Boolean read GetB write PutB; +{$IFDEF SUPER_METHOD} + property M[const k: SOString]: TSuperMethod read GetM write PutM; +{$ENDIF} + property N[const k: SOString]: ISuperObject read GetN write PutN; + property C[const k: SOString]: Currency read GetC write PutC; + + function GetValues: ISuperObject; + function GetNames: ISuperObject; + end; + + TSuperAvlIterator = class + private + FTree: TSuperAvlTree; + FBranch: TSuperAvlBitArray; + FDepth: LongInt; + FPath: array[0..SUPER_AVL_MAX_DEPTH - 2] of TSuperAvlEntry; + public + constructor Create(tree: TSuperAvlTree); virtual; + procedure Search(const k: SOString; st: TSuperAvlSearchTypes = [stEQual]); + procedure First; + procedure Last; + function GetIter: TSuperAvlEntry; + procedure Next; + procedure Prior; + // delphi enumerator + function MoveNext: Boolean; + property Current: TSuperAvlEntry read GetIter; + end; + + TSuperObjectArray = array[0..(high(PtrInt) div sizeof(TSuperObject))-1] of ISuperObject; + PSuperObjectArray = ^TSuperObjectArray; + + TSuperArray = class + private + FArray: PSuperObjectArray; + FLength: Integer; + FSize: Integer; + procedure Expand(max: Integer); + protected + function GetO(const index: integer): ISuperObject; + procedure PutO(const index: integer; const Value: ISuperObject); + function GetB(const index: integer): Boolean; + procedure PutB(const index: integer; Value: Boolean); + function GetI(const index: integer): SuperInt; + procedure PutI(const index: integer; Value: SuperInt); + function GetD(const index: integer): Double; + procedure PutD(const index: integer; Value: Double); + function GetC(const index: integer): Currency; + procedure PutC(const index: integer; Value: Currency); + function GetS(const index: integer): SOString; + procedure PutS(const index: integer; const Value: SOString); +{$IFDEF SUPER_METHOD} + function GetM(const index: integer): TSuperMethod; + procedure PutM(const index: integer; Value: TSuperMethod); +{$ENDIF} + function GetN(const index: integer): ISuperObject; + procedure PutN(const index: integer; const Value: ISuperObject); + public + constructor Create; virtual; + destructor Destroy; override; + function Add(const Data: ISuperObject): Integer; + function Delete(index: Integer): ISuperObject; + procedure Insert(index: Integer; const value: ISuperObject); + procedure Clear(all: boolean = false); + procedure Pack(all: boolean); + property Length: Integer read FLength; + + function ToJson: string; + + property N[const index: integer]: ISuperObject read GetN write PutN; + property O[const index: integer]: ISuperObject read GetO write PutO; default; + property B[const index: integer]: boolean read GetB write PutB; + property I[const index: integer]: SuperInt read GetI write PutI; + property D[const index: integer]: Double read GetD write PutD; + property C[const index: integer]: Currency read GetC write PutC; + property S[const index: integer]: SOString read GetS write PutS; +{$IFDEF SUPER_METHOD} + property M[const index: integer]: TSuperMethod read GetM write PutM; +{$ENDIF} +// property A[const index: integer]: TSuperArray read GetA; + end; + + TSuperWriter = class + public + // abstact methods to overide + function Append(buf: PSOChar; Size: Integer): Integer; overload; virtual; abstract; + function Append(buf: PSOChar): Integer; overload; virtual; abstract; + procedure Reset; virtual; abstract; + end; + + TSuperWriterString = class(TSuperWriter) + private + FBuf: PSOChar; + FBPos: integer; + FSize: integer; + public + function Append(buf: PSOChar; Size: Integer): Integer; overload; override; + function Append(buf: PSOChar): Integer; overload; override; + procedure Reset; override; + procedure TrimRight; + constructor Create; virtual; + destructor Destroy; override; + function GetString: SOString; + property Data: PSOChar read FBuf; + property Size: Integer read FSize; + property Position: integer read FBPos; + end; + + TSuperWriterStream = class(TSuperWriter) + private + FStream: TStream; + public + function Append(buf: PSOChar): Integer; override; + procedure Reset; override; + constructor Create(AStream: TStream); reintroduce; virtual; + end; + + TSuperAnsiWriterStream = class(TSuperWriterStream) + public + function Append(buf: PSOChar; Size: Integer): Integer; override; + end; + + TSuperUnicodeWriterStream = class(TSuperWriterStream) + public + function Append(buf: PSOChar; Size: Integer): Integer; override; + end; + + TSuperWriterFake = class(TSuperWriter) + private + FSize: Integer; + public + function Append(buf: PSOChar; Size: Integer): Integer; override; + function Append(buf: PSOChar): Integer; override; + procedure Reset; override; + constructor Create; reintroduce; virtual; + property size: integer read FSize; + end; + + TSuperWriterSock = class(TSuperWriter) + private + FSocket: longint; + FSize: Integer; + public + function Append(buf: PSOChar; Size: Integer): Integer; override; + function Append(buf: PSOChar): Integer; override; + procedure Reset; override; + constructor Create(ASocket: longint); reintroduce; virtual; + property Socket: longint read FSocket; + property Size: Integer read FSize; + end; + + TSuperTokenizerError = ( + teSuccess, + teContinue, + teDepth, + teParseEof, + teParseUnexpected, + teParseNull, + teParseBoolean, + teParseNumber, + teParseArray, + teParseObjectKeyName, + teParseObjectKeySep, + teParseObjectValueSep, + teParseString, + teParseComment, + teEvalObject, + teEvalArray, + teEvalMethod, + teEvalInt + ); + + TSuperTokenerState = ( + tsEatws, + tsStart, + tsFinish, + tsNull, + tsCommentStart, + tsComment, + tsCommentEol, + tsCommentEnd, + tsString, + tsStringEscape, + tsIdentifier, + tsEscapeUnicode, + tsEscapeHexadecimal, + tsBoolean, + tsNumber, + tsArray, + tsArrayAdd, + tsArraySep, + tsObjectFieldStart, + tsObjectField, + tsObjectUnquotedField, + tsObjectFieldEnd, + tsObjectValue, + tsObjectValueAdd, + tsObjectSep, + tsEvalProperty, + tsEvalArray, + tsEvalMethod, + tsParamValue, + tsParamPut, + tsMethodValue, + tsMethodPut + ); + + PSuperTokenerSrec = ^TSuperTokenerSrec; + TSuperTokenerSrec = record + state, saved_state: TSuperTokenerState; + obj: ISuperObject; + current: ISuperObject; + field_name: SOString; + parent: ISuperObject; + gparent: ISuperObject; + end; + + TSuperTokenizer = class + public + str: PSOChar; + pb: TSuperWriterString; + depth, is_double, floatcount, st_pos, char_offset: Integer; + err: TSuperTokenizerError; + ucs_char: Word; + quote_char: SOChar; + stack: array[0..SUPER_TOKENER_MAX_DEPTH-1] of TSuperTokenerSrec; + line, col: Integer; + public + constructor Create; virtual; + destructor Destroy; override; + procedure ResetLevel(adepth: integer); + procedure Reset; + end; + + // supported object types + TSuperType = ( + stNull, + stBoolean, + stDouble, + stCurrency, + stInt, + stObject, + stArray, + stString +{$IFDEF SUPER_METHOD} + ,stMethod +{$ENDIF} + ); + + TSuperValidateError = ( + veRuleMalformated, + veFieldIsRequired, + veInvalidDataType, + veFieldNotFound, + veUnexpectedField, + veDuplicateEntry, + veValueNotInEnum, + veInvalidLength, + veInvalidRange + ); + + TSuperFindOption = ( + foCreatePath, + foPutValue, + foDelete +{$IFDEF SUPER_METHOD} + ,foCallMethod +{$ENDIF} + ); + + TSuperFindOptions = set of TSuperFindOption; + TSuperCompareResult = (cpLess, cpEqu, cpGreat, cpError); + TSuperOnValidateError = procedure(sender: Pointer; error: TSuperValidateError; const objpath: SOString); + + TSuperEnumerator = class + private + FObj: ISuperObject; + FObjEnum: TSuperAvlIterator; + FCount: Integer; + public + constructor Create(const obj: ISuperObject); virtual; + destructor Destroy; override; + function MoveNext: Boolean; + function GetCurrent: ISuperObject; + property Current: ISuperObject read GetCurrent; + end; + + ISuperObject = interface + ['{4B86A9E3-E094-4E5A-954A-69048B7B6327}'] + function GetEnumerator: TSuperEnumerator; + function GetDataType: TSuperType; + function GetProcessing: boolean; + procedure SetProcessing(value: boolean); + function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject; + function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString; + + function GetO(const path: SOString): ISuperObject; + procedure PutO(const path: SOString; const Value: ISuperObject); + function GetB(const path: SOString): Boolean; + procedure PutB(const path: SOString; Value: Boolean); + function GetI(const path: SOString): SuperInt; + procedure PutI(const path: SOString; Value: SuperInt); + function GetD(const path: SOString): Double; + procedure PutC(const path: SOString; Value: Currency); + function GetC(const path: SOString): Currency; + procedure PutD(const path: SOString; Value: Double); + function GetS(const path: SOString): SOString; + procedure PutS(const path: SOString; const Value: SOString); +{$IFDEF SUPER_METHOD} + function GetM(const path: SOString): TSuperMethod; + procedure PutM(const path: SOString; Value: TSuperMethod); +{$ENDIF} + function GetA(const path: SOString): TSuperArray; + + // Null Object Design patern + function GetN(const path: SOString): ISuperObject; + procedure PutN(const path: SOString; const Value: ISuperObject); + + // Writers + function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; + function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload; + function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload; + function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload; + function CalcSize(indent: boolean = false; escape: boolean = true): integer; + + // convert + function AsBoolean: Boolean; + function AsInteger: SuperInt; + function AsDouble: Double; + function AsCurrency: Currency; + function AsString: SOString; + function AsArray: TSuperArray; + function AsObject: TSuperTableString; +{$IFDEF SUPER_METHOD} + function AsMethod: TSuperMethod; +{$ENDIF} + function AsJSon(indent: boolean = false; escape: boolean = true): SOString; + + procedure Clear(all: boolean = false); + procedure Pack(all: boolean = false); + + property N[const path: SOString]: ISuperObject read GetN write PutN; + property O[const path: SOString]: ISuperObject read GetO write PutO; default; + property B[const path: SOString]: boolean read GetB write PutB; + property I[const path: SOString]: SuperInt read GetI write PutI; + property D[const path: SOString]: Double read GetD write PutD; + property C[const path: SOString]: Currency read GetC write PutC; + property S[const path: SOString]: SOString read GetS write PutS; +{$IFDEF SUPER_METHOD} + property M[const path: SOString]: TSuperMethod read GetM write PutM; +{$ENDIF} + property A[const path: SOString]: TSuperArray read GetA; + +{$IFDEF SUPER_METHOD} + function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload; + function call(const path, param: SOString): ISuperObject; overload; +{$ENDIF} + // clone a node + function Clone: ISuperObject; + function Delete(const path: SOString): ISuperObject; + // merges tow objects of same type, if reference is true then nodes are not cloned + procedure Merge(const obj: ISuperObject; reference: boolean = false); overload; + procedure Merge(const str: SOString); overload; + + // validate methods + function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; + function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; + + // compare + function Compare(const obj: ISuperObject): TSuperCompareResult; overload; + function Compare(const str: SOString): TSuperCompareResult; overload; + + // the data type + function IsType(AType: TSuperType): boolean; + property DataType: TSuperType read GetDataType; + property Processing: boolean read GetProcessing write SetProcessing; + + function GetDataPtr: Pointer; + procedure SetDataPtr(const Value: Pointer); + property DataPtr: Pointer read GetDataPtr write SetDataPtr; + end; + + TSuperObject = class(TObject, ISuperObject) + private + FRefCount: Integer; + FProcessing: boolean; + FDataType: TSuperType; + FDataPtr: Pointer; +{.$if true} + FO: record + case TSuperType of + stBoolean: (c_boolean: boolean); + stDouble: (c_double: double); + stCurrency: (c_currency: Currency); + stInt: (c_int: SuperInt); + stObject: (c_object: TSuperTableString); + stArray: (c_array: TSuperArray); +{$IFDEF SUPER_METHOD} + stMethod: (c_method: TSuperMethod); +{$ENDIF} + end; +{.$ifend} + FOString: SOString; + function GetDataType: TSuperType; + function GetDataPtr: Pointer; + procedure SetDataPtr(const Value: Pointer); + protected + function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; + function _AddRef: Integer; virtual; stdcall; + function _Release: Integer; virtual; stdcall; + + function GetO(const path: SOString): ISuperObject; + procedure PutO(const path: SOString; const Value: ISuperObject); + function GetB(const path: SOString): Boolean; + procedure PutB(const path: SOString; Value: Boolean); + function GetI(const path: SOString): SuperInt; + procedure PutI(const path: SOString; Value: SuperInt); + function GetD(const path: SOString): Double; + procedure PutD(const path: SOString; Value: Double); + procedure PutC(const path: SOString; Value: Currency); + function GetC(const path: SOString): Currency; + function GetS(const path: SOString): SOString; + procedure PutS(const path: SOString; const Value: SOString); +{$IFDEF SUPER_METHOD} + function GetM(const path: SOString): TSuperMethod; + procedure PutM(const path: SOString; Value: TSuperMethod); +{$ENDIF} + function GetA(const path: SOString): TSuperArray; + function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; virtual; + public + function GetEnumerator: TSuperEnumerator; + procedure AfterConstruction; override; + procedure BeforeDestruction; override; + class function NewInstance: TObject; override; + property RefCount: Integer read FRefCount; + + function GetProcessing: boolean; + procedure SetProcessing(value: boolean); + + // Writers + function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload; + function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload; + function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload; + function CalcSize(indent: boolean = false; escape: boolean = true): integer; + function AsJSon(indent: boolean = false; escape: boolean = true): SOString; + + // parser ... owned! + class function ParseString(s: PSOChar; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = []; + const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; + class function ParseStream(stream: TStream; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = []; + const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; + class function ParseFile(const FileName: string; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = []; + const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; + class function ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer; strict: Boolean; const this: ISuperObject = nil; + options: TSuperFindOptions = []; const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; + + // constructors / destructor + constructor Create(jt: TSuperType = stObject); overload; virtual; + constructor Create(b: boolean); overload; virtual; + constructor Create(i: SuperInt); overload; virtual; + constructor Create(d: double); overload; virtual; + constructor CreateCurrency(c: Currency); overload; virtual; + constructor Create(const s: SOString); overload; virtual; +{$IFDEF SUPER_METHOD} + constructor Create(m: TSuperMethod); overload; virtual; +{$ENDIF} + destructor Destroy; override; + + // convert + function AsBoolean: Boolean; virtual; + function AsInteger: SuperInt; virtual; + function AsDouble: Double; virtual; + function AsCurrency: Currency; virtual; + function AsString: SOString; virtual; + function AsArray: TSuperArray; virtual; + function AsObject: TSuperTableString; virtual; +{$IFDEF SUPER_METHOD} + function AsMethod: TSuperMethod; virtual; +{$ENDIF} + procedure Clear(all: boolean = false); virtual; + procedure Pack(all: boolean = false); virtual; + function GetN(const path: SOString): ISuperObject; + procedure PutN(const path: SOString; const Value: ISuperObject); + function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject; + function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString; + + property N[const path: SOString]: ISuperObject read GetN write PutN; + property O[const path: SOString]: ISuperObject read GetO write PutO; default; + property B[const path: SOString]: boolean read GetB write PutB; + property I[const path: SOString]: SuperInt read GetI write PutI; + property D[const path: SOString]: Double read GetD write PutD; + property C[const path: SOString]: Currency read GetC write PutC; + property S[const path: SOString]: SOString read GetS write PutS; +{$IFDEF SUPER_METHOD} + property M[const path: SOString]: TSuperMethod read GetM write PutM; +{$ENDIF} + property A[const path: SOString]: TSuperArray read GetA; + +{$IFDEF SUPER_METHOD} + function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload; virtual; + function call(const path, param: SOString): ISuperObject; overload; virtual; +{$ENDIF} + // clone a node + function Clone: ISuperObject; virtual; + function Delete(const path: SOString): ISuperObject; + // merges tow objects of same type, if reference is true then nodes are not cloned + procedure Merge(const obj: ISuperObject; reference: boolean = false); overload; + procedure Merge(const str: SOString); overload; + + // validate methods + function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; + function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; + + // compare + function Compare(const obj: ISuperObject): TSuperCompareResult; overload; + function Compare(const str: SOString): TSuperCompareResult; overload; + + // the data type + function IsType(AType: TSuperType): boolean; + property DataType: TSuperType read GetDataType; + // a data pointer to link to something ele, a treeview for example + property DataPtr: Pointer read GetDataPtr write SetDataPtr; + property Processing: boolean read GetProcessing; + end; + +{$IFDEF VER210} + TSuperRttiContext = class; + + TSerialFromJson = function(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean; + TSerialToJson = function(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject; + + TSuperAttribute = class(TCustomAttribute) + private + FName: string; + public + constructor Create(const AName: string); + property Name: string read FName; + end; + + SOName = class(TSuperAttribute); + SODefault = class(TSuperAttribute); + + + TSuperRttiContext = class + private + class function GetFieldName(r: TRttiField): string; + class function GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject; + public + Context: TRttiContext; + SerialFromJson: TDictionary; + SerialToJson: TDictionary; + constructor Create; virtual; + destructor Destroy; override; + function FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject; var Value: TValue): Boolean; virtual; + function ToJson(var value: TValue; const index: ISuperObject): ISuperObject; virtual; + function AsType(const obj: ISuperObject): T; + function AsJson(const obj: T; const index: ISuperObject = nil): ISuperObject; + end; + + TSuperObjectHelper = class helper for TObject + public + function ToJson(ctx: TSuperRttiContext = nil): ISuperObject; + constructor FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil); overload; + constructor FromJson(const str: string; ctx: TSuperRttiContext = nil); overload; + end; +{$ENDIF} + + TSuperObjectIter = record + key: SOString; + val: ISuperObject; + Ite: TSuperAvlIterator; + end; + +function ObjectIsError(obj: TSuperObject): boolean; +function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean; +function ObjectGetType(const obj: ISuperObject): TSuperType; + +function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean; +function ObjectFindNext(var F: TSuperObjectIter): boolean; +procedure ObjectFindClose(var F: TSuperObjectIter); + +function SO(const s: SOString = '{}'): ISuperObject; overload; +function SO(const value: Variant): ISuperObject; overload; +function SO(const Args: array of const): ISuperObject; overload; + +function SA(const Args: array of const): ISuperObject; overload; + +function JavaToDelphiDateTime(const dt: int64): TDateTime; +function DelphiToJavaDateTime(const dt: TDateTime): int64; + +{$IFDEF VER210} + +type + TSuperInvokeResult = ( + irSuccess, + irMethothodError, // method don't exist + irParamError, // invalid parametters + irError // other error + ); + +function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue; const method: string; const params: ISuperObject; var Return: ISuperObject): TSuperInvokeResult; overload; +function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext = nil): ISuperObject; overload; +function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext = nil): ISuperObject; overload; +{$ENDIF} + +implementation +uses sysutils, +{$IFDEF UNIX} + baseunix, unix, DateUtils +{$ELSE} + Windows +{$ENDIF} +{$IFDEF FPC} + ,sockets +{$ELSE} + ,WinSock +{$ENDIF}; + +{$IFDEF DEBUG} +var + debugcount: integer = 0; +{$ENDIF} + +const + super_number_chars_set = ['0'..'9','.','+','-','e','E']; + super_hex_chars: PSOChar = '0123456789abcdef'; + super_hex_chars_set = ['0'..'9','a'..'f','A'..'F']; + + ESC_BS: PSOChar = '\b'; + ESC_LF: PSOChar = '\n'; + ESC_CR: PSOChar = '\r'; + ESC_TAB: PSOChar = '\t'; + ESC_FF: PSOChar = '\f'; + ESC_QUOT: PSOChar = '\"'; + ESC_SL: PSOChar = '\\'; + ESC_SR: PSOChar = '\/'; + ESC_ZERO: PSOChar = '\u0000'; + + TOK_CRLF: PSOChar = #13#10; + TOK_SP: PSOChar = #32; + TOK_BS: PSOChar = #8; + TOK_TAB: PSOChar = #9; + TOK_LF: PSOChar = #10; + TOK_FF: PSOChar = #12; + TOK_CR: PSOChar = #13; +// TOK_SL: PSOChar = '\'; +// TOK_SR: PSOChar = '/'; + TOK_NULL: PSOChar = 'null'; + TOK_CBL: PSOChar = '{'; // curly bracket left + TOK_CBR: PSOChar = '}'; // curly bracket right + TOK_ARL: PSOChar = '['; + TOK_ARR: PSOChar = ']'; + TOK_ARRAY: PSOChar = '[]'; + TOK_OBJ: PSOChar = '{}'; // empty object + TOK_COM: PSOChar = ','; // Comma + TOK_DQT: PSOChar = '"'; // Double Quote + TOK_TRUE: PSOChar = 'true'; + TOK_FALSE: PSOChar = 'false'; + +{$if (sizeof(Char) = 1)} +function StrLComp(const Str1, Str2: PSOChar; MaxLen: Cardinal): Integer; +var + P1, P2: PWideChar; + I: Cardinal; + C1, C2: WideChar; +begin + P1 := Str1; + P2 := Str2; + I := 0; + while I < MaxLen do + begin + C1 := P1^; + C2 := P2^; + + if (C1 <> C2) or (C1 = #0) then + begin + Result := Ord(C1) - Ord(C2); + Exit; + end; + + Inc(P1); + Inc(P2); + Inc(I); + end; + Result := 0; +end; + +function StrComp(const Str1, Str2: PSOChar): Integer; +var + P1, P2: PWideChar; + C1, C2: WideChar; +begin + P1 := Str1; + P2 := Str2; + while True do + begin + C1 := P1^; + C2 := P2^; + + if (C1 <> C2) or (C1 = #0) then + begin + Result := Ord(C1) - Ord(C2); + Exit; + end; + + Inc(P1); + Inc(P2); + end; +end; + +function StrLen(const Str: PSOChar): Cardinal; +var + p: PSOChar; +begin + Result := 0; + if Str <> nil then + begin + p := Str; + while p^ <> #0 do inc(p); + Result := (p - Str); + end; +end; +{$ifend} + +function CurrToStr(c: Currency): SOString; +var + p: PSOChar; + i, len: Integer; +begin + Result := IntToStr(Abs(PInt64(@c)^)); + len := Length(Result); + SetLength(Result, len+1); + if c <> 0 then + begin + while len <= 4 do + begin + Result := '0' + Result; + inc(len); + end; + + p := PSOChar(Result); + inc(p, len-1); + i := 0; + repeat + if p^ <> '0' then + begin + len := len - i + 1; + repeat + p[1] := p^; + dec(p); + inc(i); + until i > 3; + Break; + end; + dec(p); + inc(i); + if i > 3 then + begin + len := len - i + 1; + Break; + end; + until false; + p[1] := '.'; + SetLength(Result, len); + if c < 0 then + Result := '-' + Result; + end; +end; + +{$IFDEF UNIX} + {$linklib c} +{$ENDIF} +function gcvt(value: Double; ndigit: longint; buf: PAnsiChar): PAnsiChar; cdecl; + external {$IFDEF MSWINDOWS} 'msvcrt.dll' name '_gcvt'{$ENDIF}; + +{$IFDEF UNIX} +type + ptm = ^tm; + tm = record + tm_sec: Integer; (* Seconds: 0-59 (K&R says 0-61?) *) + tm_min: Integer; (* Minutes: 0-59 *) + tm_hour: Integer; (* Hours since midnight: 0-23 *) + tm_mday: Integer; (* Day of the month: 1-31 *) + tm_mon: Integer; (* Months *since* january: 0-11 *) + tm_year: Integer; (* Years since 1900 *) + tm_wday: Integer; (* Days since Sunday (0-6) *) + tm_yday: Integer; (* Days since Jan. 1: 0-365 *) + tm_isdst: Integer; (* +1 Daylight Savings Time, 0 No DST, -1 don't know *) + end; + +function mktime(p: ptm): LongInt; cdecl; external; +function gmtime(const t: PLongint): ptm; cdecl; external; +function localtime (const t: PLongint): ptm; cdecl; external; + +function DelphiToJavaDateTime(const dt: TDateTime): Int64; +var + p: ptm; + l, ms: Integer; + v: Int64; +begin + v := Round((dt - 25569) * 86400000); + ms := v mod 1000; + l := v div 1000; + p := localtime(@l); + Result := Int64(mktime(p)) * 1000 + ms; +end; + +function JavaToDelphiDateTime(const dt: int64): TDateTime; +var + p: ptm; + l, ms: Integer; +begin + l := dt div 1000; + ms := dt mod 1000; + p := gmtime(@l); + Result := EncodeDateTime(p^.tm_year+1900, p^.tm_mon+1, p^.tm_mday, p^.tm_hour, p^.tm_min, p^.tm_sec, ms); +end; +{$ELSE} + +{$IFDEF WINDOWSNT_COMPATIBILITY} +function DayLightCompareDate(const date: PSystemTime; + const compareDate: PSystemTime): Integer; +var + limit_day, dayinsecs, weekofmonth: Integer; + First: Word; +begin + if (date^.wMonth < compareDate^.wMonth) then + begin + Result := -1; (* We are in a month before the date limit. *) + Exit; + end; + + if (date^.wMonth > compareDate^.wMonth) then + begin + Result := 1; (* We are in a month after the date limit. *) + Exit; + end; + + (* if year is 0 then date is in day-of-week format, otherwise + * it's absolute date. + *) + if (compareDate^.wYear = 0) then + begin + (* compareDate.wDay is interpreted as number of the week in the month + * 5 means: the last week in the month *) + weekofmonth := compareDate^.wDay; + (* calculate the day of the first DayOfWeek in the month *) + First := (6 + compareDate^.wDayOfWeek - date^.wDayOfWeek + date^.wDay) mod 7 + 1; + limit_day := First + 7 * (weekofmonth - 1); + (* check needed for the 5th weekday of the month *) + if (limit_day > MonthDays[(date^.wMonth=2) and IsLeapYear(date^.wYear)][date^.wMonth - 1]) then + dec(limit_day, 7); + end + else + limit_day := compareDate^.wDay; + + (* convert to seconds *) + limit_day := ((limit_day * 24 + compareDate^.wHour) * 60 + compareDate^.wMinute ) * 60; + dayinsecs := ((date^.wDay * 24 + date^.wHour) * 60 + date^.wMinute ) * 60 + date^.wSecond; + (* and compare *) + + if dayinsecs < limit_day then + Result := -1 else + if dayinsecs > limit_day then + Result := 1 else + Result := 0; (* date is equal to the date limit. *) +end; + +function CompTimeZoneID(const pTZinfo: PTimeZoneInformation; + lpFileTime: PFileTime; islocal: Boolean): LongWord; +var + ret: Integer; + beforeStandardDate, afterDaylightDate: Boolean; + llTime: Int64; + SysTime: TSystemTime; + ftTemp: TFileTime; +begin + llTime := 0; + + if (pTZinfo^.DaylightDate.wMonth <> 0) then + begin + (* if year is 0 then date is in day-of-week format, otherwise + * it's absolute date. + *) + if ((pTZinfo^.StandardDate.wMonth = 0) or + ((pTZinfo^.StandardDate.wYear = 0) and + ((pTZinfo^.StandardDate.wDay < 1) or + (pTZinfo^.StandardDate.wDay > 5) or + (pTZinfo^.DaylightDate.wDay < 1) or + (pTZinfo^.DaylightDate.wDay > 5)))) then + begin + SetLastError(ERROR_INVALID_PARAMETER); + Result := TIME_ZONE_ID_INVALID; + Exit; + end; + + if (not islocal) then + begin + llTime := PInt64(lpFileTime)^; + dec(llTime, Int64(pTZinfo^.Bias + pTZinfo^.DaylightBias) * 600000000); + PInt64(@ftTemp)^ := llTime; + lpFileTime := @ftTemp; + end; + + FileTimeToSystemTime(lpFileTime^, SysTime); + + (* check for daylight savings *) + ret := DayLightCompareDate(@SysTime, @pTZinfo^.StandardDate); + if (ret = -2) then + begin + Result := TIME_ZONE_ID_INVALID; + Exit; + end; + + beforeStandardDate := ret < 0; + + if (not islocal) then + begin + dec(llTime, Int64(pTZinfo^.StandardBias - pTZinfo^.DaylightBias) * 600000000); + PInt64(@ftTemp)^ := llTime; + FileTimeToSystemTime(lpFileTime^, SysTime); + end; + + ret := DayLightCompareDate(@SysTime, @pTZinfo^.DaylightDate); + if (ret = -2) then + begin + Result := TIME_ZONE_ID_INVALID; + Exit; + end; + + afterDaylightDate := ret >= 0; + + Result := TIME_ZONE_ID_STANDARD; + if( pTZinfo^.DaylightDate.wMonth < pTZinfo^.StandardDate.wMonth ) then + begin + (* Northern hemisphere *) + if( beforeStandardDate and afterDaylightDate) then + Result := TIME_ZONE_ID_DAYLIGHT; + end else (* Down south *) + if( beforeStandardDate or afterDaylightDate) then + Result := TIME_ZONE_ID_DAYLIGHT; + end else + (* No transition date *) + Result := TIME_ZONE_ID_UNKNOWN; +end; + +function GetTimezoneBias(const pTZinfo: PTimeZoneInformation; + lpFileTime: PFileTime; islocal: Boolean; pBias: PLongint): Boolean; +var + bias: LongInt; + tzid: LongWord; +begin + bias := pTZinfo^.Bias; + tzid := CompTimeZoneID(pTZinfo, lpFileTime, islocal); + + if( tzid = TIME_ZONE_ID_INVALID) then + begin + Result := False; + Exit; + end; + if (tzid = TIME_ZONE_ID_DAYLIGHT) then + inc(bias, pTZinfo^.DaylightBias) + else if (tzid = TIME_ZONE_ID_STANDARD) then + inc(bias, pTZinfo^.StandardBias); + pBias^ := bias; + Result := True; +end; + +function SystemTimeToTzSpecificLocalTime( + lpTimeZoneInformation: PTimeZoneInformation; + lpUniversalTime, lpLocalTime: PSystemTime): BOOL; +var + ft: TFileTime; + lBias: LongInt; + llTime: Int64; + tzinfo: TTimeZoneInformation; +begin + if (lpTimeZoneInformation <> nil) then + tzinfo := lpTimeZoneInformation^ else + if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then + begin + Result := False; + Exit; + end; + + if (not SystemTimeToFileTime(lpUniversalTime^, ft)) then + begin + Result := False; + Exit; + end; + llTime := PInt64(@ft)^; + if (not GetTimezoneBias(@tzinfo, @ft, False, @lBias)) then + begin + Result := False; + Exit; + end; + (* convert minutes to 100-nanoseconds-ticks *) + dec(llTime, Int64(lBias) * 600000000); + PInt64(@ft)^ := llTime; + Result := FileTimeToSystemTime(ft, lpLocalTime^); +end; + +function TzSpecificLocalTimeToSystemTime( + const lpTimeZoneInformation: PTimeZoneInformation; + const lpLocalTime: PSystemTime; lpUniversalTime: PSystemTime): BOOL; +var + ft: TFileTime; + lBias: LongInt; + t: Int64; + tzinfo: TTimeZoneInformation; +begin + if (lpTimeZoneInformation <> nil) then + tzinfo := lpTimeZoneInformation^ + else + if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then + begin + Result := False; + Exit; + end; + + if (not SystemTimeToFileTime(lpLocalTime^, ft)) then + begin + Result := False; + Exit; + end; + t := PInt64(@ft)^; + if (not GetTimezoneBias(@tzinfo, @ft, True, @lBias)) then + begin + Result := False; + Exit; + end; + (* convert minutes to 100-nanoseconds-ticks *) + inc(t, Int64(lBias) * 600000000); + PInt64(@ft)^ := t; + Result := FileTimeToSystemTime(ft, lpUniversalTime^); +end; +{$ELSE} +function TzSpecificLocalTimeToSystemTime( + lpTimeZoneInformation: PTimeZoneInformation; + lpLocalTime, lpUniversalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll'; + +function SystemTimeToTzSpecificLocalTime( + lpTimeZoneInformation: PTimeZoneInformation; + lpUniversalTime, lpLocalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll'; +{$ENDIF} + +function JavaToDelphiDateTime(const dt: int64): TDateTime; +var + t: TSystemTime; +begin + DateTimeToSystemTime(25569 + (dt / 86400000), t); + SystemTimeToTzSpecificLocalTime(nil, @t, @t); + Result := SystemTimeToDateTime(t); +end; + +function DelphiToJavaDateTime(const dt: TDateTime): int64; +var + t: TSystemTime; +begin + DateTimeToSystemTime(dt, t); + TzSpecificLocalTimeToSystemTime(nil, @t, @t); + Result := Round((SystemTimeToDateTime(t) - 25569) * 86400000) +end; +{$ENDIF} + + +function SO(const s: SOString): ISuperObject; overload; +begin + Result := TSuperObject.ParseString(PSOChar(s), False); +end; + +function SA(const Args: array of const): ISuperObject; overload; +type + TByteArray = array[0..sizeof(integer) - 1] of byte; + PByteArray = ^TByteArray; +var + j: Integer; + intf: IInterface; +begin + Result := TSuperObject.Create(stArray); + for j := 0 to length(Args) - 1 do + with Result.AsArray do + case TVarRec(Args[j]).VType of + vtInteger : Add(TSuperObject.Create(TVarRec(Args[j]).VInteger)); + vtInt64 : Add(TSuperObject.Create(TVarRec(Args[j]).VInt64^)); + vtBoolean : Add(TSuperObject.Create(TVarRec(Args[j]).VBoolean)); + vtChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VChar))); + vtWideChar: Add(TSuperObject.Create(SOChar(TVarRec(Args[j]).VWideChar))); + vtExtended: Add(TSuperObject.Create(TVarRec(Args[j]).VExtended^)); + vtCurrency: Add(TSuperObject.CreateCurrency(TVarRec(Args[j]).VCurrency^)); + vtString : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VString^))); + vtPChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VPChar^))); + vtAnsiString: Add(TSuperObject.Create(SOString(AnsiString(TVarRec(Args[j]).VAnsiString)))); + vtWideString: Add(TSuperObject.Create(SOString(PWideChar(TVarRec(Args[j]).VWideString)))); + vtInterface: + if TVarRec(Args[j]).VInterface = nil then + Add(nil) else + if IInterface(TVarRec(Args[j]).VInterface).QueryInterface(ISuperObject, intf) = 0 then + Add(ISuperObject(intf)) else + Add(nil); + vtPointer : + if TVarRec(Args[j]).VPointer = nil then + Add(nil) else + Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer))); + vtVariant: + Add(SO(TVarRec(Args[j]).VVariant^)); + vtObject: + if TVarRec(Args[j]).VPointer = nil then + Add(nil) else + Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer))); + vtClass: + if TVarRec(Args[j]).VPointer = nil then + Add(nil) else + Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer))); +{$if declared(vtUnicodeString)} + vtUnicodeString: + Add(TSuperObject.Create(SOString(string(TVarRec(Args[j]).VUnicodeString)))); +{$ifend} + else + assert(false); + end; +end; + +function SO(const Args: array of const): ISuperObject; overload; +var + j: Integer; + arr: ISuperObject; +begin + Result := TSuperObject.Create(stObject); + arr := SA(Args); + with arr.AsArray do + for j := 0 to (Length div 2) - 1 do + Result.AsObject.PutO(O[j*2].AsString, O[(j*2) + 1]); +end; + +function SO(const value: Variant): ISuperObject; overload; +begin + with TVarData(value) do + case VType of + varNull: Result := nil; + varEmpty: Result := nil; + varSmallInt: Result := TSuperObject.Create(VSmallInt); + varInteger: Result := TSuperObject.Create(VInteger); + varSingle: Result := TSuperObject.Create(VSingle); + varDouble: Result := TSuperObject.Create(VDouble); + varCurrency: Result := TSuperObject.CreateCurrency(VCurrency); + varDate: Result := TSuperObject.Create(DelphiToJavaDateTime(vDate)); + varOleStr: Result := TSuperObject.Create(SOString(VOleStr)); + varBoolean: Result := TSuperObject.Create(VBoolean); + varShortInt: Result := TSuperObject.Create(VShortInt); + varByte: Result := TSuperObject.Create(VByte); + varWord: Result := TSuperObject.Create(VWord); + varLongWord: Result := TSuperObject.Create(VLongWord); + varInt64: Result := TSuperObject.Create(VInt64); + varString: Result := TSuperObject.Create(SOString(AnsiString(VString))); +{$if declared(varUString)} + varUString: Result := TSuperObject.Create(SOString(string(VUString))); +{$ifend} + else + raise Exception.CreateFmt('Unsuported variant data type: %d', [VType]); + end; +end; + +function ObjectIsError(obj: TSuperObject): boolean; +begin + Result := PtrUInt(obj) > PtrUInt(-4000); +end; + +function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean; +begin + if obj <> nil then + Result := typ = obj.DataType else + Result := typ = stNull; +end; + +function ObjectGetType(const obj: ISuperObject): TSuperType; +begin + if obj <> nil then + Result := obj.DataType else + Result := stNull; +end; + +function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean; +var + i: TSuperAvlEntry; +begin + if ObjectIsType(obj, stObject) then + begin + F.Ite := TSuperAvlIterator.Create(obj.AsObject); + F.Ite.First; + i := F.Ite.GetIter; + if i <> nil then + begin + f.key := i.Name; + f.val := i.Value; + Result := true; + end else + Result := False; + end else + Result := False; +end; + +function ObjectFindNext(var F: TSuperObjectIter): boolean; +var + i: TSuperAvlEntry; +begin + F.Ite.Next; + i := F.Ite.GetIter; + if i <> nil then + begin + f.key := i.FName; + f.val := i.Value; + Result := true; + end else + Result := False; +end; + +procedure ObjectFindClose(var F: TSuperObjectIter); +begin + F.Ite.Free; + F.val := nil; +end; + +{$IFDEF VER210} + +function serialtoboolean(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject; +begin + Result := TSuperObject.Create(TValueData(value).FAsSLong <> 0); +end; + +function serialtodatetime(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject; +begin + Result := TSuperObject.Create(DelphiToJavaDateTime(TValueData(value).FAsDouble)); +end; + +function serialtoguid(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject; +var + g: TGUID; +begin + value.ExtractRawData(@g); + Result := TSuperObject.Create( + format('%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x', + [g.D1, g.D2, g.D3, + g.D4[0], g.D4[1], g.D4[2], + g.D4[3], g.D4[4], g.D4[5], + g.D4[6], g.D4[7]]) + ); +end; + +function serialfromboolean(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean; +var + o: ISuperObject; +begin + case ObjectGetType(obj) of + stBoolean: + begin + TValueData(Value).FAsSLong := obj.AsInteger; + Result := True; + end; + stInt: + begin + TValueData(Value).FAsSLong := ord(obj.AsInteger <> 0); + Result := True; + end; + stString: + begin + o := SO(obj.AsString); + if not ObjectIsType(o, stString) then + Result := serialfromboolean(ctx, SO(obj.AsString), Value) else + Result := False; + end; + else + Result := False; + end; +end; + +function serialfromdatetime(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean; +var + dt: TDateTime; +begin + case ObjectGetType(obj) of + stInt: + begin + TValueData(Value).FAsDouble := JavaToDelphiDateTime(obj.AsInteger); + Result := True; + end; + stString: + begin + if TryStrToDateTime(obj.AsString, dt) then + begin + TValueData(Value).FAsDouble := dt; + Result := True; + end else + Result := False; + end; + else + Result := False; + end; +end; + +function UuidFromString(const s: PSOChar; Uuid: PGUID): Boolean; +const + hex2bin: array[#0..#102] of short = ( + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x00 *) + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x10 *) + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x20 *) + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1, (* 0x30 *) + -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x40 *) + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x50 *) + -1,10,11,12,13,14,15); (* 0x60 *) +var + i: Integer; +begin + if (strlen(s) <> 36) then Exit(False); + + if ((s[8] <> '-') or (s[13] <> '-') or (s[18] <> '-') or (s[23] <> '-')) then + Exit(False); + + for i := 0 to 35 do + begin + if not i in [8,13,18,23] then + if ((s[i] > 'f') or ((hex2bin[s[i]] = -1) and (s[i] <> ''))) then + Exit(False); + end; + + uuid.D1 := ((hex2bin[s[0]] shl 28) or (hex2bin[s[1]] shl 24) or (hex2bin[s[2]] shl 20) or (hex2bin[s[3]] shl 16) or + (hex2bin[s[4]] shl 12) or (hex2bin[s[5]] shl 8) or (hex2bin[s[6]] shl 4) or hex2bin[s[7]]); + uuid.D2 := (hex2bin[s[9]] shl 12) or (hex2bin[s[10]] shl 8) or (hex2bin[s[11]] shl 4) or hex2bin[s[12]]; + uuid.D3 := (hex2bin[s[14]] shl 12) or (hex2bin[s[15]] shl 8) or (hex2bin[s[16]] shl 4) or hex2bin[s[17]]; + + uuid.D4[0] := (hex2bin[s[19]] shl 4) or hex2bin[s[20]]; + uuid.D4[1] := (hex2bin[s[21]] shl 4) or hex2bin[s[22]]; + uuid.D4[2] := (hex2bin[s[24]] shl 4) or hex2bin[s[25]]; + uuid.D4[3] := (hex2bin[s[26]] shl 4) or hex2bin[s[27]]; + uuid.D4[4] := (hex2bin[s[28]] shl 4) or hex2bin[s[29]]; + uuid.D4[5] := (hex2bin[s[30]] shl 4) or hex2bin[s[31]]; + uuid.D4[6] := (hex2bin[s[32]] shl 4) or hex2bin[s[33]]; + uuid.D4[7] := (hex2bin[s[34]] shl 4) or hex2bin[s[35]]; + Result := True; +end; + +function serialfromguid(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean; +begin + case ObjectGetType(obj) of + stNull: + begin + FillChar(Value.GetReferenceToRawData^, SizeOf(TGUID), 0); + Result := True; + end; + stString: Result := UuidFromString(PSOChar(obj.AsString), Value.GetReferenceToRawData); + else + Result := False; + end; +end; + +function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext): ISuperObject; overload; +var + owned: Boolean; +begin + if ctx = nil then + begin + ctx := TSuperRttiContext.Create; + owned := True; + end else + owned := False; + try + if TrySOInvoke(ctx, obj, method, params, Result) <> irSuccess then + raise Exception.Create('Invalid method call'); + finally + if owned then + ctx.Free; + end; +end; + +function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext): ISuperObject; overload; +begin + Result := SOInvoke(obj, method, so(params), ctx) +end; + +function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue; + const method: string; const params: ISuperObject; + var Return: ISuperObject): TSuperInvokeResult; +var + t: TRttiInstanceType; + m: TRttiMethod; + a: TArray; + ps: TArray; + v: TValue; + index: ISuperObject; + + function GetParams: Boolean; + var + i: Integer; + begin + case ObjectGetType(params) of + stArray: + for i := 0 to Length(ps) - 1 do + if (pfOut in ps[i].Flags) then + TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else + if not ctx.FromJson(ps[i].ParamType.Handle, params.AsArray[i], a[i]) then + Exit(False); + stObject: + for i := 0 to Length(ps) - 1 do + if (pfOut in ps[i].Flags) then + TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else + if not ctx.FromJson(ps[i].ParamType.Handle, params.AsObject[ps[i].Name], a[i]) then + Exit(False); + stNull: ; + else + Exit(False); + end; + Result := True; + end; + + procedure SetParams; + var + i: Integer; + begin + case ObjectGetType(params) of + stArray: + for i := 0 to Length(ps) - 1 do + if (ps[i].Flags * [pfVar, pfOut]) <> [] then + params.AsArray[i] := ctx.ToJson(a[i], index); + stObject: + for i := 0 to Length(ps) - 1 do + if (ps[i].Flags * [pfVar, pfOut]) <> [] then + params.AsObject[ps[i].Name] := ctx.ToJson(a[i], index); + end; + end; + +begin + Result := irSuccess; + index := SO; + case obj.Kind of + tkClass: + begin + t := TRttiInstanceType(ctx.Context.GetType(obj.AsObject.ClassType)); + m := t.GetMethod(method); + if m = nil then Exit(irMethothodError); + ps := m.GetParameters; + SetLength(a, Length(ps)); + if not GetParams then Exit(irParamError); + if m.IsClassMethod then + begin + v := m.Invoke(obj.AsObject.ClassType, a); + Return := ctx.ToJson(v, index); + SetParams; + end else + begin + v := m.Invoke(obj, a); + Return := ctx.ToJson(v, index); + SetParams; + end; + end; + tkClassRef: + begin + t := TRttiInstanceType(ctx.Context.GetType(obj.AsClass)); + m := t.GetMethod(method); + if m = nil then Exit(irMethothodError); + ps := m.GetParameters; + SetLength(a, Length(ps)); + + if not GetParams then Exit(irParamError); + if m.IsClassMethod then + begin + v := m.Invoke(obj, a); + Return := ctx.ToJson(v, index); + SetParams; + end else + Exit(irError); + end; + else + Exit(irError); + end; +end; + +{$ENDIF} + +{ TSuperEnumerator } + +constructor TSuperEnumerator.Create(const obj: ISuperObject); +begin + FObj := obj; + FCount := -1; + if ObjectIsType(FObj, stObject) then + FObjEnum := FObj.AsObject.GetEnumerator else + FObjEnum := nil; +end; + +destructor TSuperEnumerator.Destroy; +begin + if FObjEnum <> nil then + FObjEnum.Free; +end; + +function TSuperEnumerator.MoveNext: Boolean; +begin + case ObjectGetType(FObj) of + stObject: Result := FObjEnum.MoveNext; + stArray: + begin + inc(FCount); + if FCount < FObj.AsArray.Length then + Result := True else + Result := False; + end; + else + Result := false; + end; +end; + +function TSuperEnumerator.GetCurrent: ISuperObject; +begin + case ObjectGetType(FObj) of + stObject: Result := FObjEnum.Current.Value; + stArray: Result := FObj.AsArray.GetO(FCount); + else + Result := FObj; + end; +end; + +{ TSuperObject } + +constructor TSuperObject.Create(jt: TSuperType); +begin + inherited Create; +{$IFDEF DEBUG} + InterlockedIncrement(debugcount); +{$ENDIF} + + FProcessing := false; + FDataPtr := nil; + FDataType := jt; + case FDataType of + stObject: FO.c_object := TSuperTableString.Create; + stArray: FO.c_array := TSuperArray.Create; + stString: FOString := ''; + else + FO.c_object := nil; + end; +end; + +constructor TSuperObject.Create(b: boolean); +begin + Create(stBoolean); + FO.c_boolean := b; +end; + +constructor TSuperObject.Create(i: SuperInt); +begin + Create(stInt); + FO.c_int := i; +end; + +constructor TSuperObject.Create(d: double); +begin + Create(stDouble); + FO.c_double := d; +end; + +constructor TSuperObject.CreateCurrency(c: Currency); +begin + Create(stCurrency); + FO.c_currency := c; +end; + +destructor TSuperObject.Destroy; +begin +{$IFDEF DEBUG} + InterlockedDecrement(debugcount); +{$ENDIF} + case FDataType of + stObject: FO.c_object.Free; + stArray: FO.c_array.Free; + end; + inherited; +end; + +function TSuperObject.Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; +function DoEscape(str: PSOChar; len: Integer): Integer; +var + pos, start_offset: Integer; + c: SOChar; + buf: array[0..5] of SOChar; +type + TByteChar = record + case integer of + 0: (a, b: Byte); + 1: (c: WideChar); + end; + begin + if str = nil then + begin + Result := 0; + exit; + end; + pos := 0; start_offset := 0; + with writer do + while pos < len do + begin + c := str[pos]; + case c of + #8,#9,#10,#12,#13,'"','\','/': + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + + if(c = #8) then Append(ESC_BS, 2) + else if (c = #9) then Append(ESC_TAB, 2) + else if (c = #10) then Append(ESC_LF, 2) + else if (c = #12) then Append(ESC_FF, 2) + else if (c = #13) then Append(ESC_CR, 2) + else if (c = '"') then Append(ESC_QUOT, 2) + else if (c = '\') then Append(ESC_SL, 2) + else if (c = '/') then Append(ESC_SR, 2); + inc(pos); + start_offset := pos; + end; + else + if (SOIChar(c) > 255) then + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + buf[0] := '\'; + buf[1] := 'u'; + buf[2] := super_hex_chars[TByteChar(c).b shr 4]; + buf[3] := super_hex_chars[TByteChar(c).b and $f]; + buf[4] := super_hex_chars[TByteChar(c).a shr 4]; + buf[5] := super_hex_chars[TByteChar(c).a and $f]; + Append(@buf, 6); + inc(pos); + start_offset := pos; + end else + if (c < #32) or (c > #127) then + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + buf[0] := '\'; + buf[1] := 'u'; + buf[2] := '0'; + buf[3] := '0'; + buf[4] := super_hex_chars[ord(c) shr 4]; + buf[5] := super_hex_chars[ord(c) and $f]; + Append(buf, 6); + inc(pos); + start_offset := pos; + end else + inc(pos); + end; + end; + if(pos - start_offset > 0) then + writer.Append(str + start_offset, pos - start_offset); + Result := 0; + end; + +function DoMinimalEscape(str: PSOChar; len: Integer): Integer; +var + pos, start_offset: Integer; + c: SOChar; +type + TByteChar = record + case integer of + 0: (a, b: Byte); + 1: (c: WideChar); + end; + begin + if str = nil then + begin + Result := 0; + exit; + end; + pos := 0; start_offset := 0; + with writer do + while pos < len do + begin + c := str[pos]; + case c of + #0: + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + Append(ESC_ZERO, 6); + inc(pos); + start_offset := pos; + end; + '"': + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + Append(ESC_QUOT, 2); + inc(pos); + start_offset := pos; + end; + '\': + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + Append(ESC_SL, 2); + inc(pos); + start_offset := pos; + end; + '/': + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + Append(ESC_SR, 2); + inc(pos); + start_offset := pos; + end; + else + inc(pos); + end; + end; + if(pos - start_offset > 0) then + writer.Append(str + start_offset, pos - start_offset); + Result := 0; + end; + + + procedure _indent(i: shortint; r: boolean); + begin + inc(level, i); + if r then + with writer do + begin +{$IFDEF MSWINDOWS} + Append(TOK_CRLF, 2); +{$ELSE} + Append(TOK_LF, 1); +{$ENDIF} + for i := 0 to level - 1 do + Append(TOK_SP, 1); + end; + end; +var + k,j: Integer; + iter: TSuperObjectIter; + st: AnsiString; + val: ISuperObject; + fbuffer: array[0..31] of AnsiChar; +const + ENDSTR_A: PSOChar = '": '; + ENDSTR_B: PSOChar = '":'; +begin + + if FProcessing then + begin + Result := writer.Append(TOK_NULL, 4); + Exit; + end; + + FProcessing := true; + with writer do + try + case FDataType of + stObject: + if FO.c_object.FCount > 0 then + begin + k := 0; + Append(TOK_CBL, 1); + if indent then _indent(1, false); + if ObjectFindFirst(Self, iter) then + repeat + {$IFDEF SUPER_METHOD} + if (iter.val = nil) or not ObjectIsType(iter.val, stMethod) then + begin + {$ENDIF} + if (iter.val = nil) or (not iter.val.Processing) then + begin + if(k <> 0) then + Append(TOK_COM, 1); + if indent then _indent(0, true); + Append(TOK_DQT, 1); + if escape then + doEscape(PSOChar(iter.key), Length(iter.key)) else + DoMinimalEscape(PSOChar(iter.key), Length(iter.key)); + if indent then + Append(ENDSTR_A, 3) else + Append(ENDSTR_B, 2); + if(iter.val = nil) then + Append(TOK_NULL, 4) else + iter.val.write(writer, indent, escape, level); + inc(k); + end; + {$IFDEF SUPER_METHOD} + end; + {$ENDIF} + until not ObjectFindNext(iter); + ObjectFindClose(iter); + if indent then _indent(-1, true); + Result := Append(TOK_CBR, 1); + end else + Result := Append(TOK_OBJ, 2); + stBoolean: + begin + if (FO.c_boolean) then + Result := Append(TOK_TRUE, 4) else + Result := Append(TOK_FALSE, 5); + end; + stInt: + begin + str(FO.c_int, st); + Result := Append(PSOChar(SOString(st))); + end; + stDouble: + Result := Append(PSOChar(SOString(gcvt(FO.c_double, 15, fbuffer)))); + stCurrency: + begin + Result := Append(PSOChar(CurrToStr(FO.c_currency))); + end; + stString: + begin + Append(TOK_DQT, 1); + if escape then + doEscape(PSOChar(FOString), Length(FOString)) else + DoMinimalEscape(PSOChar(FOString), Length(FOString)); + Append(TOK_DQT, 1); + Result := 0; + end; + stArray: + if FO.c_array.FLength > 0 then + begin + Append(TOK_ARL, 1); + if indent then _indent(1, true); + k := 0; + j := 0; + while k < FO.c_array.FLength do + begin + + val := FO.c_array.GetO(k); + {$IFDEF SUPER_METHOD} + if not ObjectIsType(val, stMethod) then + begin + {$ENDIF} + if (val = nil) or (not val.Processing) then + begin + if (j <> 0) then + Append(TOK_COM, 1); + if(val = nil) then + Append(TOK_NULL, 4) else + val.write(writer, indent, escape, level); + inc(j); + end; + {$IFDEF SUPER_METHOD} + end; + {$ENDIF} + inc(k); + end; + if indent then _indent(-1, false); + Result := Append(TOK_ARR, 1); + end else + Result := Append(TOK_ARRAY, 2); + stNull: + Result := Append(TOK_NULL, 4); + else + Result := 0; + end; + finally + FProcessing := false; + end; +end; + +function TSuperObject.IsType(AType: TSuperType): boolean; +begin + Result := AType = FDataType; +end; + +function TSuperObject.AsBoolean: boolean; +begin + case FDataType of + stBoolean: Result := FO.c_boolean; + stInt: Result := (FO.c_int <> 0); + stDouble: Result := (FO.c_double <> 0); + stCurrency: Result := (FO.c_currency <> 0); + stString: Result := (Length(FOString) <> 0); + stNull: Result := False; + else + Result := True; + end; +end; + +function TSuperObject.AsInteger: SuperInt; +var + code: integer; + cint: SuperInt; +begin + case FDataType of + stInt: Result := FO.c_int; + stDouble: Result := round(FO.c_double); + stCurrency: Result := round(FO.c_currency); + stBoolean: Result := ord(FO.c_boolean); + stString: + begin + Val(FOString, cint, code); + if code = 0 then + Result := cint else + Result := 0; + end; + else + Result := 0; + end; +end; + +function TSuperObject.AsDouble: Double; +var + code: integer; + cdouble: double; +begin + case FDataType of + stDouble: Result := FO.c_double; + stCurrency: Result := FO.c_currency; + stInt: Result := FO.c_int; + stBoolean: Result := ord(FO.c_boolean); + stString: + begin + Val(FOString, cdouble, code); + if code = 0 then + Result := cdouble else + Result := 0.0; + end; + else + Result := 0.0; + end; +end; + +function TSuperObject.AsCurrency: Currency; +var + code: integer; + cdouble: double; +begin + case FDataType of + stDouble: Result := FO.c_double; + stCurrency: Result := FO.c_currency; + stInt: Result := FO.c_int; + stBoolean: Result := ord(FO.c_boolean); + stString: + begin + Val(FOString, cdouble, code); + if code = 0 then + Result := cdouble else + Result := 0.0; + end; + else + Result := 0.0; + end; +end; + +function TSuperObject.AsString: SOString; +begin + if FDataType = stString then + Result := FOString else + Result := AsJSon(false, false); +end; + +function TSuperObject.GetEnumerator: TSuperEnumerator; +begin + Result := TSuperEnumerator.Create(Self); +end; + +procedure TSuperObject.AfterConstruction; +begin + InterlockedDecrement(FRefCount); +end; + +procedure TSuperObject.BeforeDestruction; +begin + if RefCount <> 0 then + raise Exception.Create('Invalid pointer'); +end; + +function TSuperObject.AsArray: TSuperArray; +begin + if FDataType = stArray then + Result := FO.c_array else + Result := nil; +end; + +function TSuperObject.AsObject: TSuperTableString; +begin + if FDataType = stObject then + Result := FO.c_object else + Result := nil; +end; + +function TSuperObject.AsJSon(indent, escape: boolean): SOString; +var + pb: TSuperWriterString; +begin + pb := TSuperWriterString.Create; + try + if(Write(pb, indent, escape, 0) < 0) then + begin + Result := ''; + Exit; + end; + if pb.FBPos > 0 then + Result := pb.FBuf else + Result := ''; + finally + pb.Free; + end; +end; + +class function TSuperObject.ParseString(s: PSOChar; strict: Boolean; partial: boolean; const this: ISuperObject; + options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject; +var + tok: TSuperTokenizer; + obj: ISuperObject; +begin + tok := TSuperTokenizer.Create; + obj := ParseEx(tok, s, -1, strict, this, options, put, dt); + if(tok.err <> teSuccess) or (not partial and (s[tok.char_offset] <> #0)) then + Result := nil else + Result := obj; + tok.Free; +end; + +class function TSuperObject.ParseStream(stream: TStream; strict: Boolean; + partial: boolean; const this: ISuperObject; options: TSuperFindOptions; + const put: ISuperObject; dt: TSuperType): ISuperObject; +const + BUFFER_SIZE = 1024; +var + tok: TSuperTokenizer; + buffera: array[0..BUFFER_SIZE-1] of AnsiChar; + bufferw: array[0..BUFFER_SIZE-1] of SOChar; + bom: array[0..1] of byte; + unicode: boolean; + j, size: Integer; + st: string; +begin + st := ''; + tok := TSuperTokenizer.Create; + + if (stream.Read(bom, sizeof(bom)) = 2) and (bom[0] = $FF) and (bom[1] = $FE) then + begin + unicode := true; + size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar); + end else + begin + unicode := false; + stream.Seek(0, soFromBeginning); + size := stream.Read(buffera, BUFFER_SIZE); + end; + + while size > 0 do + begin + if not unicode then + for j := 0 to size - 1 do + bufferw[j] := SOChar(buffera[j]); + ParseEx(tok, bufferw, size, strict, this, options, put, dt); + + if tok.err = teContinue then + begin + if not unicode then + size := stream.Read(buffera, BUFFER_SIZE) else + size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar); + end else + Break; + end; + if(tok.err <> teSuccess) or (not partial and (st[tok.char_offset] <> #0)) then + Result := nil else + Result := tok.stack[tok.depth].current; + tok.Free; +end; + +class function TSuperObject.ParseFile(const FileName: string; strict: Boolean; + partial: boolean; const this: ISuperObject; options: TSuperFindOptions; + const put: ISuperObject; dt: TSuperType): ISuperObject; +var + stream: TFileStream; +begin + stream := TFileStream.Create(FileName, fmOpenRead, fmShareDenyWrite); + try + Result := ParseStream(stream, strict, partial, this, options, put, dt); + finally + stream.Free; + end; +end; + +class function TSuperObject.ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer; + strict: Boolean; const this: ISuperObject; options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject; + +const + spaces = [#32,#8,#9,#10,#12,#13]; + delimiters = ['"', '.', '[', ']', '{', '}', '(', ')', ',', ':', #0]; + reserved = delimiters + spaces; + path = ['a'..'z', 'A'..'Z', '.', '_']; + + function hexdigit(x: SOChar): byte; + begin + if x <= '9' then + Result := byte(x) - byte('0') else + Result := (byte(x) and 7) + 9; + end; + function min(v1, v2: integer): integer; begin if v1 < v2 then result := v1 else result := v2 end; + +var + obj: ISuperObject; + v: SOChar; +{$IFDEF SUPER_METHOD} + sm: TSuperMethod; +{$ENDIF} + numi: SuperInt; + numd: Double; + code: integer; + TokRec: PSuperTokenerSrec; + evalstack: integer; + p: PSOChar; + + function IsEndDelimiter(v: AnsiChar): Boolean; + begin + if tok.depth > 0 then + case tok.stack[tok.depth - 1].state of + tsArrayAdd: Result := v in [',', ']', #0]; + tsObjectValueAdd: Result := v in [',', '}', #0]; + else + Result := v = #0; + end else + Result := v = #0; + end; + +label out, redo_char; +begin + evalstack := 0; + obj := nil; + Result := nil; + TokRec := @tok.stack[tok.depth]; + + tok.char_offset := 0; + tok.err := teSuccess; + + repeat + if (tok.char_offset = len) then + begin + if (tok.depth = 0) and (TokRec^.state = tsEatws) and + (TokRec^.saved_state = tsFinish) then + tok.err := teSuccess else + tok.err := teContinue; + goto out; + end; + + v := str^; + + case v of + #10: + begin + inc(tok.line); + tok.col := 0; + end; + #9: inc(tok.col, 4); + else + inc(tok.col); + end; + +redo_char: + case TokRec^.state of + tsEatws: + begin + if (SOIChar(v) < 256) and (AnsiChar(v) in spaces) then {nop} else + if (v = '/') then + begin + tok.pb.Reset; + tok.pb.Append(@v, 1); + TokRec^.state := tsCommentStart; + end else begin + TokRec^.state := TokRec^.saved_state; + goto redo_char; + end + end; + + tsStart: + case v of + '"', + '''': + begin + TokRec^.state := tsString; + tok.pb.Reset; + tok.quote_char := v; + end; + '-': + begin + TokRec^.state := tsNumber; + tok.pb.Reset; + tok.is_double := 0; + tok.floatcount := -1; + goto redo_char; + end; + + '0'..'9': + begin + if (tok.depth = 0) then + case ObjectGetType(this) of + stObject: + begin + TokRec^.state := tsIdentifier; + TokRec^.current := this; + goto redo_char; + end; + end; + TokRec^.state := tsNumber; + tok.pb.Reset; + tok.is_double := 0; + tok.floatcount := -1; + goto redo_char; + end; + '{': + begin + TokRec^.state := tsEatws; + TokRec^.saved_state := tsObjectFieldStart; + TokRec^.current := TSuperObject.Create(stObject); + end; + '[': + begin + TokRec^.state := tsEatws; + TokRec^.saved_state := tsArray; + TokRec^.current := TSuperObject.Create(stArray); + end; +{$IFDEF SUPER_METHOD} + '(': + begin + if (tok.depth = 0) and ObjectIsType(this, stMethod) then + begin + TokRec^.current := this; + TokRec^.state := tsParamValue; + end; + end; +{$ENDIF} + 'N', + 'n': + begin + TokRec^.state := tsNull; + tok.pb.Reset; + tok.st_pos := 0; + goto redo_char; + end; + 'T', + 't', + 'F', + 'f': + begin + TokRec^.state := tsBoolean; + tok.pb.Reset; + tok.st_pos := 0; + goto redo_char; + end; + else + TokRec^.state := tsIdentifier; + tok.pb.Reset; + goto redo_char; + end; + + tsFinish: + begin + if(tok.depth = 0) then goto out; + obj := TokRec^.current; + tok.ResetLevel(tok.depth); + dec(tok.depth); + TokRec := @tok.stack[tok.depth]; + goto redo_char; + end; + + tsNull: + begin + tok.pb.Append(@v, 1); + if (StrLComp(TOK_NULL, PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then + begin + if (tok.st_pos = 4) then + if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then + TokRec^.state := tsIdentifier else + begin + TokRec^.current := TSuperObject.Create(stNull); + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + goto redo_char; + end; + end else + begin + TokRec^.state := tsIdentifier; + tok.pb.FBuf[tok.st_pos] := #0; + dec(tok.pb.FBPos); + goto redo_char; + end; + inc(tok.st_pos); + end; + + tsCommentStart: + begin + if(v = '*') then + begin + TokRec^.state := tsComment; + end else + if (v = '/') then + begin + TokRec^.state := tsCommentEol; + end else + begin + tok.err := teParseComment; + goto out; + end; + tok.pb.Append(@v, 1); + end; + + tsComment: + begin + if(v = '*') then + TokRec^.state := tsCommentEnd; + tok.pb.Append(@v, 1); + end; + + tsCommentEol: + begin + if (v = #10) then + TokRec^.state := tsEatws else + tok.pb.Append(@v, 1); + end; + + tsCommentEnd: + begin + tok.pb.Append(@v, 1); + if (v = '/') then + TokRec^.state := tsEatws else + TokRec^.state := tsComment; + end; + + tsString: + begin + if (v = tok.quote_char) then + begin + TokRec^.current := TSuperObject.Create(SOString(tok.pb.GetString)); + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + end else + if (v = '\') then + begin + TokRec^.saved_state := tsString; + TokRec^.state := tsStringEscape; + end else + begin + tok.pb.Append(@v, 1); + end + end; + + tsEvalProperty: + begin + if (TokRec^.current = nil) and (foCreatePath in options) then + begin + TokRec^.current := TSuperObject.Create(stObject); + TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current) + end else + if not ObjectIsType(TokRec^.current, stObject) then + begin + tok.err := teEvalObject; + goto out; + end; + tok.pb.Reset; + TokRec^.state := tsIdentifier; + goto redo_char; + end; + + tsEvalArray: + begin + if (TokRec^.current = nil) and (foCreatePath in options) then + begin + TokRec^.current := TSuperObject.Create(stArray); + TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current) + end else + if not ObjectIsType(TokRec^.current, stArray) then + begin + tok.err := teEvalArray; + goto out; + end; + tok.pb.Reset; + TokRec^.state := tsParamValue; + goto redo_char; + end; +{$IFDEF SUPER_METHOD} + tsEvalMethod: + begin + if ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then + begin + tok.pb.Reset; + TokRec^.obj := TSuperObject.Create(stArray); + TokRec^.state := tsMethodValue; + goto redo_char; + end else + begin + tok.err := teEvalMethod; + goto out; + end; + end; + + tsMethodValue: + begin + case v of + ')': + TokRec^.state := tsIdentifier; + else + if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then + begin + tok.err := teDepth; + goto out; + end; + inc(evalstack); + TokRec^.state := tsMethodPut; + inc(tok.depth); + tok.ResetLevel(tok.depth); + TokRec := @tok.stack[tok.depth]; + goto redo_char; + end; + end; + + tsMethodPut: + begin + TokRec^.obj.AsArray.Add(obj); + case v of + ',': + begin + tok.pb.Reset; + TokRec^.saved_state := tsMethodValue; + TokRec^.state := tsEatws; + end; + ')': + begin + if TokRec^.obj.AsArray.Length = 1 then + TokRec^.obj := TokRec^.obj.AsArray.GetO(0); + dec(evalstack); + tok.pb.Reset; + TokRec^.saved_state := tsIdentifier; + TokRec^.state := tsEatws; + end; + else + tok.err := teEvalMethod; + goto out; + end; + end; +{$ENDIF} + tsParamValue: + begin + case v of + ']': + TokRec^.state := tsIdentifier; + else + if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then + begin + tok.err := teDepth; + goto out; + end; + inc(evalstack); + TokRec^.state := tsParamPut; + inc(tok.depth); + tok.ResetLevel(tok.depth); + TokRec := @tok.stack[tok.depth]; + goto redo_char; + end; + end; + + tsParamPut: + begin + dec(evalstack); + TokRec^.obj := obj; + tok.pb.Reset; + TokRec^.saved_state := tsIdentifier; + TokRec^.state := tsEatws; + if v <> ']' then + begin + tok.err := teEvalArray; + goto out; + end; + end; + + tsIdentifier: + begin + if (this = nil) then + begin + if (SOIChar(v) < 256) and IsEndDelimiter(AnsiChar(v)) then + begin + if not strict then + begin + tok.pb.TrimRight; + TokRec^.current := TSuperObject.Create(tok.pb.Fbuf); + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + goto redo_char; + end else + begin + tok.err := teParseString; + goto out; + end; + end else + if (v = '\') then + begin + TokRec^.saved_state := tsIdentifier; + TokRec^.state := tsStringEscape; + end else + tok.pb.Append(@v, 1); + end else + begin + if (SOIChar(v) < 256) and (AnsiChar(v) in reserved) then + begin + TokRec^.gparent := TokRec^.parent; + if TokRec^.current = nil then + TokRec^.parent := this else + TokRec^.parent := TokRec^.current; + + case ObjectGetType(TokRec^.parent) of + stObject: + case v of + '.': + begin + TokRec^.state := tsEvalProperty; + if tok.pb.FBPos > 0 then + TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); + end; + '[': + begin + TokRec^.state := tsEvalArray; + if tok.pb.FBPos > 0 then + TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); + end; + '(': + begin + TokRec^.state := tsEvalMethod; + if tok.pb.FBPos > 0 then + TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); + end; + else + if tok.pb.FBPos > 0 then + TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); + if (foPutValue in options) and (evalstack = 0) then + begin + TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, put); + TokRec^.current := put + end else + if (foDelete in options) and (evalstack = 0) then + begin + TokRec^.current := TokRec^.parent.AsObject.Delete(tok.pb.Fbuf); + end else + if (TokRec^.current = nil) and (foCreatePath in options) then + begin + TokRec^.current := TSuperObject.Create(dt); + TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current); + end; + TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); + TokRec^.state := tsFinish; + goto redo_char; + end; + stArray: + begin + if TokRec^.obj <> nil then + begin + if not ObjectIsType(TokRec^.obj, stInt) or (TokRec^.obj.AsInteger < 0) then + begin + tok.err := teEvalInt; + TokRec^.obj := nil; + goto out; + end; + numi := TokRec^.obj.AsInteger; + TokRec^.obj := nil; + + TokRec^.current := TokRec^.parent.AsArray.GetO(numi); + case v of + '.': + if (TokRec^.current = nil) and (foCreatePath in options) then + begin + TokRec^.current := TSuperObject.Create(stObject); + TokRec^.parent.AsArray.PutO(numi, TokRec^.current); + end else + if (TokRec^.current = nil) then + begin + tok.err := teEvalObject; + goto out; + end; + '[': + begin + if (TokRec^.current = nil) and (foCreatePath in options) then + begin + TokRec^.current := TSuperObject.Create(stArray); + TokRec^.parent.AsArray.Add(TokRec^.current); + end else + if (TokRec^.current = nil) then + begin + tok.err := teEvalArray; + goto out; + end; + TokRec^.state := tsEvalArray; + end; + '(': TokRec^.state := tsEvalMethod; + else + if (foPutValue in options) and (evalstack = 0) then + begin + TokRec^.parent.AsArray.PutO(numi, put); + TokRec^.current := put; + end else + if (foDelete in options) and (evalstack = 0) then + begin + TokRec^.current := TokRec^.parent.AsArray.Delete(numi); + end else + TokRec^.current := TokRec^.parent.AsArray.GetO(numi); + TokRec^.state := tsFinish; + goto redo_char + end; + end else + begin + case v of + '.': + begin + if (foPutValue in options) then + begin + TokRec^.current := TSuperObject.Create(stObject); + TokRec^.parent.AsArray.Add(TokRec^.current); + end else + TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1); + end; + '[': + begin + if (foPutValue in options) then + begin + TokRec^.current := TSuperObject.Create(stArray); + TokRec^.parent.AsArray.Add(TokRec^.current); + end else + TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1); + TokRec^.state := tsEvalArray; + end; + '(': + begin + if not (foPutValue in options) then + TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1) else + TokRec^.current := nil; + + TokRec^.state := tsEvalMethod; + end; + else + if (foPutValue in options) and (evalstack = 0) then + begin + TokRec^.parent.AsArray.Add(put); + TokRec^.current := put; + end else + if tok.pb.FBPos = 0 then + TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1); + TokRec^.state := tsFinish; + goto redo_char + end; + end; + end; +{$IFDEF SUPER_METHOD} + stMethod: + case v of + '.': + begin + TokRec^.current := nil; + sm := TokRec^.parent.AsMethod; + sm(TokRec^.gparent, TokRec^.obj, TokRec^.current); + TokRec^.obj := nil; + end; + '[': + begin + TokRec^.current := nil; + sm := TokRec^.parent.AsMethod; + sm(TokRec^.gparent, TokRec^.obj, TokRec^.current); + TokRec^.state := tsEvalArray; + TokRec^.obj := nil; + end; + '(': + begin + TokRec^.current := nil; + sm := TokRec^.parent.AsMethod; + sm(TokRec^.gparent, TokRec^.obj, TokRec^.current); + TokRec^.state := tsEvalMethod; + TokRec^.obj := nil; + end; + else + if not (foPutValue in options) or (evalstack > 0) then + begin + TokRec^.current := nil; + sm := TokRec^.parent.AsMethod; + sm(TokRec^.gparent, TokRec^.obj, TokRec^.current); + TokRec^.obj := nil; + TokRec^.state := tsFinish; + goto redo_char + end else + begin + tok.err := teEvalMethod; + TokRec^.obj := nil; + goto out; + end; + end; +{$ENDIF} + end; + end else + tok.pb.Append(@v, 1); + end; + end; + + tsStringEscape: + case v of + 'b', + 'n', + 'r', + 't', + 'f': + begin + if(v = 'b') then tok.pb.Append(TOK_BS, 1) + else if(v = 'n') then tok.pb.Append(TOK_LF, 1) + else if(v = 'r') then tok.pb.Append(TOK_CR, 1) + else if(v = 't') then tok.pb.Append(TOK_TAB, 1) + else if(v = 'f') then tok.pb.Append(TOK_FF, 1); + TokRec^.state := TokRec^.saved_state; + end; + 'u': + begin + tok.ucs_char := 0; + tok.st_pos := 0; + TokRec^.state := tsEscapeUnicode; + end; + 'x': + begin + tok.ucs_char := 0; + tok.st_pos := 0; + TokRec^.state := tsEscapeHexadecimal; + end + else + tok.pb.Append(@v, 1); + TokRec^.state := TokRec^.saved_state; + end; + + tsEscapeUnicode: + begin + if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then + begin + inc(tok.ucs_char, (Word(hexdigit(v)) shl ((3-tok.st_pos)*4))); + inc(tok.st_pos); + if (tok.st_pos = 4) then + begin + tok.pb.Append(@tok.ucs_char, 1); + TokRec^.state := TokRec^.saved_state; + end + end else + begin + tok.err := teParseString; + goto out; + end + end; + tsEscapeHexadecimal: + begin + if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then + begin + inc(tok.ucs_char, (Word(hexdigit(v)) shl ((1-tok.st_pos)*4))); + inc(tok.st_pos); + if (tok.st_pos = 2) then + begin + tok.pb.Append(@tok.ucs_char, 1); + TokRec^.state := TokRec^.saved_state; + end + end else + begin + tok.err := teParseString; + goto out; + end + end; + tsBoolean: + begin + tok.pb.Append(@v, 1); + if (StrLComp('true', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then + begin + if (tok.st_pos = 4) then + if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then + TokRec^.state := tsIdentifier else + begin + TokRec^.current := TSuperObject.Create(true); + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + goto redo_char; + end + end else + if (StrLComp('false', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 5)) = 0) then + begin + if (tok.st_pos = 5) then + if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then + TokRec^.state := tsIdentifier else + begin + TokRec^.current := TSuperObject.Create(false); + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + goto redo_char; + end + end else + begin + TokRec^.state := tsIdentifier; + tok.pb.FBuf[tok.st_pos] := #0; + dec(tok.pb.FBPos); + goto redo_char; + end; + inc(tok.st_pos); + end; + + tsNumber: + begin + if (SOIChar(v) < 256) and (AnsiChar(v) in super_number_chars_set) then + begin + tok.pb.Append(@v, 1); + if (SOIChar(v) < 256) then + case v of + '.': begin + tok.is_double := 1; + tok.floatcount := 0; + end; + 'e','E': + begin + tok.is_double := 1; + tok.floatcount := -1; + end; + '0'..'9': + begin + + if (tok.is_double = 1) and (tok.floatcount >= 0) then + begin + inc(tok.floatcount); + if tok.floatcount > 4 then + tok.floatcount := -1; + end; + end; + end; + end else + begin + if (tok.is_double = 0) then + begin + val(tok.pb.FBuf, numi, code); + if ObjectIsType(this, stArray) then + begin + if (foPutValue in options) and (evalstack = 0) then + begin + this.AsArray.PutO(numi, put); + TokRec^.current := put; + end else + if (foDelete in options) and (evalstack = 0) then + TokRec^.current := this.AsArray.Delete(numi) else + TokRec^.current := this.AsArray.GetO(numi); + end else + TokRec^.current := TSuperObject.Create(numi); + + end else + if (tok.is_double <> 0) then + begin + if tok.floatcount >= 0 then + begin + p := tok.pb.FBuf; + while p^ <> '.' do inc(p); + for code := 0 to tok.floatcount - 1 do + begin + p^ := p[1]; + inc(p); + end; + p^ := #0; + val(tok.pb.FBuf, numi, code); + case tok.floatcount of + 0: numi := numi * 10000; + 1: numi := numi * 1000; + 2: numi := numi * 100; + 3: numi := numi * 10; + end; + TokRec^.current := TSuperObject.CreateCurrency(PCurrency(@numi)^); + end else + begin + val(tok.pb.FBuf, numd, code); + TokRec^.current := TSuperObject.Create(numd); + end; + end else + begin + tok.err := teParseNumber; + goto out; + end; + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + goto redo_char; + end + end; + + tsArray: + begin + if (v = ']') then + begin + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + end else + begin + if(tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then + begin + tok.err := teDepth; + goto out; + end; + TokRec^.state := tsArrayAdd; + inc(tok.depth); + tok.ResetLevel(tok.depth); + TokRec := @tok.stack[tok.depth]; + goto redo_char; + end + end; + + tsArrayAdd: + begin + TokRec^.current.AsArray.Add(obj); + TokRec^.saved_state := tsArraySep; + TokRec^.state := tsEatws; + goto redo_char; + end; + + tsArraySep: + begin + if (v = ']') then + begin + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + end else + if (v = ',') then + begin + TokRec^.saved_state := tsArray; + TokRec^.state := tsEatws; + end else + begin + tok.err := teParseArray; + goto out; + end + end; + + tsObjectFieldStart: + begin + if (v = '}') then + begin + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + end else + if (SOIChar(v) < 256) and (AnsiChar(v) in ['"', '''']) then + begin + tok.quote_char := v; + tok.pb.Reset; + TokRec^.state := tsObjectField; + end else + if not((SOIChar(v) < 256) and ((AnsiChar(v) in reserved) or strict)) then + begin + TokRec^.state := tsObjectUnquotedField; + tok.pb.Reset; + goto redo_char; + end else + begin + tok.err := teParseObjectKeyName; + goto out; + end + end; + + tsObjectField: + begin + if (v = tok.quote_char) then + begin + TokRec^.field_name := tok.pb.FBuf; + TokRec^.saved_state := tsObjectFieldEnd; + TokRec^.state := tsEatws; + end else + if (v = '\') then + begin + TokRec^.saved_state := tsObjectField; + TokRec^.state := tsStringEscape; + end else + begin + tok.pb.Append(@v, 1); + end + end; + + tsObjectUnquotedField: + begin + if (SOIChar(v) < 256) and (AnsiChar(v) in [':', #0]) then + begin + TokRec^.field_name := tok.pb.FBuf; + TokRec^.saved_state := tsObjectFieldEnd; + TokRec^.state := tsEatws; + goto redo_char; + end else + if (v = '\') then + begin + TokRec^.saved_state := tsObjectUnquotedField; + TokRec^.state := tsStringEscape; + end else + tok.pb.Append(@v, 1); + end; + + tsObjectFieldEnd: + begin + if (v = ':') then + begin + TokRec^.saved_state := tsObjectValue; + TokRec^.state := tsEatws; + end else + begin + tok.err := teParseObjectKeySep; + goto out; + end + end; + + tsObjectValue: + begin + if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then + begin + tok.err := teDepth; + goto out; + end; + TokRec^.state := tsObjectValueAdd; + inc(tok.depth); + tok.ResetLevel(tok.depth); + TokRec := @tok.stack[tok.depth]; + goto redo_char; + end; + + tsObjectValueAdd: + begin + TokRec^.current.AsObject.PutO(TokRec^.field_name, obj); + TokRec^.field_name := ''; + TokRec^.saved_state := tsObjectSep; + TokRec^.state := tsEatws; + goto redo_char; + end; + + tsObjectSep: + begin + if (v = '}') then + begin + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + end else + if (v = ',') then + begin + TokRec^.saved_state := tsObjectFieldStart; + TokRec^.state := tsEatws; + end else + begin + tok.err := teParseObjectValueSep; + goto out; + end + end; + end; + inc(str); + inc(tok.char_offset); + until v = #0; + + if(TokRec^.state <> tsFinish) and + (TokRec^.saved_state <> tsFinish) then + tok.err := teParseEof; + + out: + if(tok.err in [teSuccess]) then + begin +{$IFDEF SUPER_METHOD} + if (foCallMethod in options) and ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then + begin + sm := TokRec^.current.AsMethod; + sm(TokRec^.parent, put, Result); + end else +{$ENDIF} + Result := TokRec^.current; + end else + Result := nil; +end; + +procedure TSuperObject.PutO(const path: SOString; const Value: ISuperObject); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], Value); +end; + +procedure TSuperObject.PutB(const path: SOString; Value: Boolean); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); +end; + +procedure TSuperObject.PutD(const path: SOString; Value: Double); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); +end; + +procedure TSuperObject.PutC(const path: SOString; Value: Currency); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.CreateCurrency(Value)); +end; + +procedure TSuperObject.PutI(const path: SOString; Value: SuperInt); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); +end; + +procedure TSuperObject.PutS(const path: SOString; const Value: SOString); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); +end; + +function TSuperObject.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; +begin + if GetInterface(IID, Obj) then + Result := 0 + else + Result := E_NOINTERFACE; +end; + +function TSuperObject.SaveTo(stream: TStream; indent, escape: boolean): integer; +var + pb: TSuperWriterStream; +begin + if escape then + pb := TSuperAnsiWriterStream.Create(stream) else + pb := TSuperUnicodeWriterStream.Create(stream); + + if(Write(pb, indent, escape, 0) < 0) then + begin + pb.Reset; + pb.Free; + Result := 0; + Exit; + end; + Result := stream.Size; + pb.Free; +end; + +function TSuperObject.CalcSize(indent, escape: boolean): integer; +var + pb: TSuperWriterFake; +begin + pb := TSuperWriterFake.Create; + if(Write(pb, indent, escape, 0) < 0) then + begin + pb.Free; + Result := 0; + Exit; + end; + Result := pb.FSize; + pb.Free; +end; + +function TSuperObject.SaveTo(socket: Integer; indent, escape: boolean): integer; +var + pb: TSuperWriterSock; +begin + pb := TSuperWriterSock.Create(socket); + if(Write(pb, indent, escape, 0) < 0) then + begin + pb.Free; + Result := 0; + Exit; + end; + Result := pb.FSize; + pb.Free; +end; + +constructor TSuperObject.Create(const s: SOString); +begin + Create(stString); + FOString := s; +end; + +procedure TSuperObject.Clear(all: boolean); +begin + if FProcessing then exit; + FProcessing := true; + try + case FDataType of + stBoolean: FO.c_boolean := false; + stDouble: FO.c_double := 0.0; + stCurrency: FO.c_currency := 0.0; + stInt: FO.c_int := 0; + stObject: FO.c_object.Clear(all); + stArray: FO.c_array.Clear(all); + stString: FOString := ''; +{$IFDEF SUPER_METHOD} + stMethod: FO.c_method := nil; +{$ENDIF} + end; + finally + FProcessing := false; + end; +end; + +procedure TSuperObject.Pack(all: boolean = false); +begin + if FProcessing then exit; + FProcessing := true; + try + case FDataType of + stObject: FO.c_object.Pack(all); + stArray: FO.c_array.Pack(all); + end; + finally + FProcessing := false; + end; +end; + +function TSuperObject.GetN(const path: SOString): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, true, self); + if Result = nil then + Result := TSuperObject.Create(stNull); +end; + +procedure TSuperObject.PutN(const path: SOString; const Value: ISuperObject); +begin + if Value = nil then + ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], TSuperObject.Create(stNull)) else + ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], Value); +end; + +function TSuperObject.Delete(const path: SOString): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, true, self, [foDelete]); +end; + +function TSuperObject.Clone: ISuperObject; +var + ite: TSuperObjectIter; + arr: TSuperArray; + j: integer; +begin + case FDataType of + stBoolean: Result := TSuperObject.Create(FO.c_boolean); + stDouble: Result := TSuperObject.Create(FO.c_double); + stCurrency: Result := TSuperObject.CreateCurrency(FO.c_currency); + stInt: Result := TSuperObject.Create(FO.c_int); + stString: Result := TSuperObject.Create(FOString); +{$IFDEF SUPER_METHOD} + stMethod: Result := TSuperObject.Create(FO.c_method); +{$ENDIF} + stObject: + begin + Result := TSuperObject.Create(stObject); + if ObjectFindFirst(self, ite) then + with Result.AsObject do + repeat + PutO(ite.key, ite.val.Clone); + until not ObjectFindNext(ite); + ObjectFindClose(ite); + end; + stArray: + begin + Result := TSuperObject.Create(stArray); + arr := AsArray; + with Result.AsArray do + for j := 0 to arr.Length - 1 do + Add(arr.GetO(j).Clone); + end; + else + Result := nil; + end; +end; + +procedure TSuperObject.Merge(const obj: ISuperObject; reference: boolean); +var + prop1, prop2: ISuperObject; + ite: TSuperObjectIter; + arr: TSuperArray; + j: integer; +begin + if ObjectIsType(obj, FDataType) then + case FDataType of + stBoolean: FO.c_boolean := obj.AsBoolean; + stDouble: FO.c_double := obj.AsDouble; + stCurrency: FO.c_currency := obj.AsCurrency; + stInt: FO.c_int := obj.AsInteger; + stString: FOString := obj.AsString; +{$IFDEF SUPER_METHOD} + stMethod: FO.c_method := obj.AsMethod; +{$ENDIF} + stObject: + begin + if ObjectFindFirst(obj, ite) then + with FO.c_object do + repeat + prop1 := FO.c_object.GetO(ite.key); + if (prop1 <> nil) and (ite.val <> nil) and (prop1.DataType = ite.val.DataType) then + prop1.Merge(ite.val) else + if reference then + PutO(ite.key, ite.val) else + PutO(ite.key, ite.val.Clone); + until not ObjectFindNext(ite); + ObjectFindClose(ite); + end; + stArray: + begin + arr := obj.AsArray; + with FO.c_array do + for j := 0 to arr.Length - 1 do + begin + prop1 := GetO(j); + prop2 := arr.GetO(j); + if (prop1 <> nil) and (prop2 <> nil) and (prop1.DataType = prop2.DataType) then + prop1.Merge(prop2) else + if reference then + PutO(j, prop2) else + PutO(j, prop2.Clone); + end; + end; + end; +end; + +procedure TSuperObject.Merge(const str: SOString); +begin + Merge(TSuperObject.ParseString(PSOChar(str), False), true); +end; + +class function TSuperObject.NewInstance: TObject; +begin + Result := inherited NewInstance; + TSuperObject(Result).FRefCount := 1; +end; + +function TSuperObject.ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, True, Self, [foCreatePath], nil, dataType); +end; + +function TSuperObject.Format(const str: SOString; BeginSep: SOChar; EndSep: SOChar): SOString; +var + p1, p2: PSOChar; +begin + Result := ''; + p2 := PSOChar(str); + p1 := p2; + while true do + if p2^ = BeginSep then + begin + if p2 > p1 then + Result := Result + Copy(p1, 0, p2-p1); + inc(p2); + p1 := p2; + while true do + if p2^ = EndSep then Break else + if p2^ = #0 then Exit else + inc(p2); + Result := Result + GetS(copy(p1, 0, p2-p1)); + inc(p2); + p1 := p2; + end + else if p2^ = #0 then + begin + if p2 > p1 then + Result := Result + Copy(p1, 0, p2-p1); + Break; + end else + inc(p2); +end; + +function TSuperObject.GetO(const path: SOString): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, True, Self); +end; + +function TSuperObject.GetA(const path: SOString): TSuperArray; +var + obj: ISuperObject; +begin + obj := ParseString(PSOChar(path), False, True, Self); + if obj <> nil then + Result := obj.AsArray else + Result := nil; +end; + +function TSuperObject.GetB(const path: SOString): Boolean; +var + obj: ISuperObject; +begin + obj := GetO(path); + if obj <> nil then + Result := obj.AsBoolean else + Result := false; +end; + +function TSuperObject.GetD(const path: SOString): Double; +var + obj: ISuperObject; +begin + obj := GetO(path); + if obj <> nil then + Result := obj.AsDouble else + Result := 0.0; +end; + +function TSuperObject.GetC(const path: SOString): Currency; +var + obj: ISuperObject; +begin + obj := GetO(path); + if obj <> nil then + Result := obj.AsCurrency else + Result := 0.0; +end; + +function TSuperObject.GetI(const path: SOString): SuperInt; +var + obj: ISuperObject; +begin + obj := GetO(path); + if obj <> nil then + Result := obj.AsInteger else + Result := 0; +end; + +function TSuperObject.GetDataPtr: Pointer; +begin + Result := FDataPtr; +end; + +function TSuperObject.GetDataType: TSuperType; +begin + Result := FDataType +end; + +function TSuperObject.GetS(const path: SOString): SOString; +var + obj: ISuperObject; +begin + obj := GetO(path); + if obj <> nil then + Result := obj.AsString else + Result := ''; +end; + +function TSuperObject.SaveTo(const FileName: string; indent, escape: boolean): integer; +var + stream: TFileStream; +begin + stream := TFileStream.Create(FileName, fmCreate); + try + Result := SaveTo(stream, indent, escape); + finally + stream.Free; + end; +end; + +function TSuperObject.Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; +begin + Result := Validate(TSuperObject.ParseString(PSOChar(rules), False), TSuperObject.ParseString(PSOChar(defs), False), callback, sender); +end; + +function TSuperObject.Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; +type + TDataType = (dtUnknown, dtStr, dtInt, dtFloat, dtNumber, dtText, dtBool, + dtMap, dtSeq, dtScalar, dtAny); +var + datatypes: ISuperObject; + names: ISuperObject; + + function FindInheritedProperty(const prop: PSOChar; p: ISuperObject): ISuperObject; + var + o: ISuperObject; + e: TSuperAvlEntry; + begin + o := p[prop]; + if o <> nil then + result := o else + begin + o := p['inherit']; + if (o <> nil) and ObjectIsType(o, stString) then + begin + e := names.AsObject.Search(o.AsString); + if (e <> nil) then + Result := FindInheritedProperty(prop, e.Value) else + Result := nil; + end else + Result := nil; + end; + end; + + function FindDataType(o: ISuperObject): TDataType; + var + e: TSuperAvlEntry; + obj: ISuperObject; + begin + obj := FindInheritedProperty('type', o); + if obj <> nil then + begin + e := datatypes.AsObject.Search(obj.AsString); + if e <> nil then + Result := TDataType(e.Value.AsInteger) else + Result := dtUnknown; + end else + Result := dtUnknown; + end; + + procedure GetNames(o: ISuperObject); + var + obj: ISuperObject; + f: TSuperObjectIter; + begin + obj := o['name']; + if ObjectIsType(obj, stString) then + names[obj.AsString] := o; + + case FindDataType(o) of + dtMap: + begin + obj := o['mapping']; + if ObjectIsType(obj, stObject) then + begin + if ObjectFindFirst(obj, f) then + repeat + if ObjectIsType(f.val, stObject) then + GetNames(f.val); + until not ObjectFindNext(f); + ObjectFindClose(f); + end; + end; + dtSeq: + begin + obj := o['sequence']; + if ObjectIsType(obj, stObject) then + GetNames(obj); + end; + end; + end; + + function FindInheritedField(const prop: SOString; p: ISuperObject): ISuperObject; + var + o: ISuperObject; + e: TSuperAvlEntry; + begin + o := p['mapping']; + if ObjectIsType(o, stObject) then + begin + o := o.AsObject.GetO(prop); + if o <> nil then + begin + Result := o; + Exit; + end; + end; + + o := p['inherit']; + if ObjectIsType(o, stString) then + begin + e := names.AsObject.Search(o.AsString); + if (e <> nil) then + Result := FindInheritedField(prop, e.Value) else + Result := nil; + end else + Result := nil; + end; + + function InheritedFieldExist(const obj: ISuperObject; p: ISuperObject; const name: SOString = ''): boolean; + var + o: ISuperObject; + e: TSuperAvlEntry; + j: TSuperAvlIterator; + begin + Result := true; + o := p['mapping']; + if ObjectIsType(o, stObject) then + begin + j := TSuperAvlIterator.Create(o.AsObject); + try + j.First; + e := j.GetIter; + while e <> nil do + begin + if obj.AsObject.Search(e.Name) = nil then + begin + Result := False; + if assigned(callback) then + callback(sender, veFieldNotFound, name + '.' + e.Name); + end; + j.Next; + e := j.GetIter; + end; + + finally + j.Free; + end; + end; + + o := p['inherit']; + if ObjectIsType(o, stString) then + begin + e := names.AsObject.Search(o.AsString); + if (e <> nil) then + Result := InheritedFieldExist(obj, e.Value, name) and Result; + end; + end; + + function getInheritedBool(f: PSOChar; p: ISuperObject; default: boolean = false): boolean; + var + o: ISuperObject; + begin + o := FindInheritedProperty(f, p); + case ObjectGetType(o) of + stBoolean: Result := o.AsBoolean; + stNull: Result := Default; + else + Result := default; + if assigned(callback) then + callback(sender, veRuleMalformated, f); + end; + end; + + procedure GetInheritedFieldList(list: ISuperObject; p: ISuperObject); + var + o: ISuperObject; + e: TSuperAvlEntry; + i: TSuperAvlIterator; + begin + Result := true; + o := p['mapping']; + if ObjectIsType(o, stObject) then + begin + i := TSuperAvlIterator.Create(o.AsObject); + try + i.First; + e := i.GetIter; + while e <> nil do + begin + if list.AsObject.Search(e.Name) = nil then + list[e.Name] := e.Value; + i.Next; + e := i.GetIter; + end; + + finally + i.Free; + end; + end; + + o := p['inherit']; + if ObjectIsType(o, stString) then + begin + e := names.AsObject.Search(o.AsString); + if (e <> nil) then + GetInheritedFieldList(list, e.Value); + end; + end; + + function CheckEnum(o: ISuperObject; p: ISuperObject; name: SOString = ''): boolean; + var + enum: ISuperObject; + i: integer; + begin + Result := false; + enum := FindInheritedProperty('enum', p); + case ObjectGetType(enum) of + stArray: + for i := 0 to enum.AsArray.Length - 1 do + if (o.AsString = enum.AsArray[i].AsString) then + begin + Result := true; + exit; + end; + stNull: Result := true; + else + Result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, ''); + Exit; + end; + + if (not Result) and assigned(callback) then + callback(sender, veValueNotInEnum, name); + end; + + function CheckLength(len: integer; p: ISuperObject; const objpath: SOString): boolean; + var + length, o: ISuperObject; + begin + result := true; + length := FindInheritedProperty('length', p); + case ObjectGetType(length) of + stObject: + begin + o := length.AsObject.GetO('min'); + if (o <> nil) and (o.AsInteger > len) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidLength, objpath); + end; + o := length.AsObject.GetO('max'); + if (o <> nil) and (o.AsInteger < len) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidLength, objpath); + end; + o := length.AsObject.GetO('minex'); + if (o <> nil) and (o.AsInteger >= len) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidLength, objpath); + end; + o := length.AsObject.GetO('maxex'); + if (o <> nil) and (o.AsInteger <= len) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidLength, objpath); + end; + end; + stNull: ; + else + Result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, ''); + end; + end; + + function CheckRange(obj: ISuperObject; p: ISuperObject; const objpath: SOString): boolean; + var + length, o: ISuperObject; + begin + result := true; + length := FindInheritedProperty('range', p); + case ObjectGetType(length) of + stObject: + begin + o := length.AsObject.GetO('min'); + if (o <> nil) and (o.Compare(obj) = cpGreat) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidRange, objpath); + end; + o := length.AsObject.GetO('max'); + if (o <> nil) and (o.Compare(obj) = cpLess) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidRange, objpath); + end; + o := length.AsObject.GetO('minex'); + if (o <> nil) and (o.Compare(obj) in [cpGreat, cpEqu]) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidRange, objpath); + end; + o := length.AsObject.GetO('maxex'); + if (o <> nil) and (o.Compare(obj) in [cpLess, cpEqu]) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidRange, objpath); + end; + end; + stNull: ; + else + Result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, ''); + end; + end; + + + function process(o: ISuperObject; p: ISuperObject; objpath: SOString = ''): boolean; + var + ite: TSuperAvlIterator; + ent: TSuperAvlEntry; + p2, o2, sequence: ISuperObject; + s: SOString; + i: integer; + uniquelist, fieldlist: ISuperObject; + begin + Result := true; + if (o = nil) then + begin + if getInheritedBool('required', p) then + begin + if assigned(callback) then + callback(sender, veFieldIsRequired, objpath); + result := false; + end; + end else + case FindDataType(p) of + dtStr: + case ObjectGetType(o) of + stString: + begin + Result := Result and CheckLength(Length(o.AsString), p, objpath); + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtBool: + case ObjectGetType(o) of + stBoolean: + begin + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtInt: + case ObjectGetType(o) of + stInt: + begin + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtFloat: + case ObjectGetType(o) of + stDouble, stCurrency: + begin + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtMap: + case ObjectGetType(o) of + stObject: + begin + // all objects have and match a rule ? + ite := TSuperAvlIterator.Create(o.AsObject); + try + ite.First; + ent := ite.GetIter; + while ent <> nil do + begin + p2 := FindInheritedField(ent.Name, p); + if ObjectIsType(p2, stObject) then + result := process(ent.Value, p2, objpath + '.' + ent.Name) and result else + begin + if assigned(callback) then + callback(sender, veUnexpectedField, objpath + '.' + ent.Name); + result := false; // field have no rule + end; + ite.Next; + ent := ite.GetIter; + end; + finally + ite.Free; + end; + + // all expected field exists ? + Result := InheritedFieldExist(o, p, objpath) and Result; + end; + stNull: {nop}; + else + result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, objpath); + end; + dtSeq: + case ObjectGetType(o) of + stArray: + begin + sequence := FindInheritedProperty('sequence', p); + if sequence <> nil then + case ObjectGetType(sequence) of + stObject: + begin + for i := 0 to o.AsArray.Length - 1 do + result := process(o.AsArray.GetO(i), sequence, objpath + '[' + IntToStr(i) + ']') and result; + if getInheritedBool('unique', sequence) then + begin + // type is unique ? + uniquelist := TSuperObject.Create(stObject); + try + for i := 0 to o.AsArray.Length - 1 do + begin + s := o.AsArray.GetO(i).AsString; + if (s <> '') then + begin + if uniquelist.AsObject.Search(s) = nil then + uniquelist[s] := nil else + begin + Result := False; + if Assigned(callback) then + callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + ']'); + end; + end; + end; + finally + uniquelist := nil; + end; + end; + + // field is unique ? + if (FindDataType(sequence) = dtMap) then + begin + fieldlist := TSuperObject.Create(stObject); + try + GetInheritedFieldList(fieldlist, sequence); + ite := TSuperAvlIterator.Create(fieldlist.AsObject); + try + ite.First; + ent := ite.GetIter; + while ent <> nil do + begin + if getInheritedBool('unique', ent.Value) then + begin + uniquelist := TSuperObject.Create(stObject); + try + for i := 0 to o.AsArray.Length - 1 do + begin + o2 := o.AsArray.GetO(i); + if o2 <> nil then + begin + s := o2.AsObject.GetO(ent.Name).AsString; + if (s <> '') then + if uniquelist.AsObject.Search(s) = nil then + uniquelist[s] := nil else + begin + Result := False; + if Assigned(callback) then + callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + '].' + ent.name); + end; + end; + end; + finally + uniquelist := nil; + end; + end; + ite.Next; + ent := ite.GetIter; + end; + finally + ite.Free; + end; + finally + fieldlist := nil; + end; + end; + + + end; + stNull: {nop}; + else + result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, objpath); + end; + Result := Result and CheckLength(o.AsArray.Length, p, objpath); + + end; + else + result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, objpath); + end; + dtNumber: + case ObjectGetType(o) of + stInt, + stDouble, stCurrency: + begin + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtText: + case ObjectGetType(o) of + stInt, + stDouble, + stCurrency, + stString: + begin + result := result and CheckLength(Length(o.AsString), p, objpath); + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtScalar: + case ObjectGetType(o) of + stBoolean, + stDouble, + stCurrency, + stInt, + stString: + begin + result := result and CheckLength(Length(o.AsString), p, objpath); + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtAny:; + else + if assigned(callback) then + callback(sender, veRuleMalformated, objpath); + result := false; + end; + Result := Result and CheckEnum(o, p, objpath) + + end; +var + j: integer; + +begin + Result := False; + datatypes := TSuperObject.Create(stObject); + names := TSuperObject.Create; + try + datatypes.I['str'] := ord(dtStr); + datatypes.I['int'] := ord(dtInt); + datatypes.I['float'] := ord(dtFloat); + datatypes.I['number'] := ord(dtNumber); + datatypes.I['text'] := ord(dtText); + datatypes.I['bool'] := ord(dtBool); + datatypes.I['map'] := ord(dtMap); + datatypes.I['seq'] := ord(dtSeq); + datatypes.I['scalar'] := ord(dtScalar); + datatypes.I['any'] := ord(dtAny); + + if ObjectIsType(defs, stArray) then + for j := 0 to defs.AsArray.Length - 1 do + if ObjectIsType(defs.AsArray[j], stObject) then + GetNames(defs.AsArray[j]) else + begin + if assigned(callback) then + callback(sender, veRuleMalformated, ''); + Exit; + end; + + + if ObjectIsType(rules, stObject) then + GetNames(rules) else + begin + if assigned(callback) then + callback(sender, veRuleMalformated, ''); + Exit; + end; + + Result := process(self, rules); + + finally + datatypes := nil; + names := nil; + end; +end; + +function TSuperObject._AddRef: Integer; stdcall; +begin + Result := InterlockedIncrement(FRefCount); +end; + +function TSuperObject._Release: Integer; stdcall; +begin + Result := InterlockedDecrement(FRefCount); + if Result = 0 then + Destroy; +end; + +function TSuperObject.Compare(const str: SOString): TSuperCompareResult; +begin + Result := Compare(TSuperObject.ParseString(PSOChar(str), False)); +end; + +function TSuperObject.Compare(const obj: ISuperObject): TSuperCompareResult; + function GetIntCompResult(const i: int64): TSuperCompareResult; + begin + if i < 0 then result := cpLess else + if i = 0 then result := cpEqu else + Result := cpGreat; + end; + + function GetDblCompResult(const d: double): TSuperCompareResult; + begin + if d < 0 then result := cpLess else + if d = 0 then result := cpEqu else + Result := cpGreat; + end; + +begin + case DataType of + stBoolean: + case ObjectGetType(obj) of + stBoolean: Result := GetIntCompResult(ord(FO.c_boolean) - ord(obj.AsBoolean)); + stDouble: Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsDouble); + stCurrency:Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsCurrency); + stInt: Result := GetIntCompResult(ord(FO.c_boolean) - obj.AsInteger); + stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); + else + Result := cpError; + end; + stDouble: + case ObjectGetType(obj) of + stBoolean: Result := GetDblCompResult(FO.c_double - ord(obj.AsBoolean)); + stDouble: Result := GetDblCompResult(FO.c_double - obj.AsDouble); + stCurrency:Result := GetDblCompResult(FO.c_double - obj.AsCurrency); + stInt: Result := GetDblCompResult(FO.c_double - obj.AsInteger); + stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); + else + Result := cpError; + end; + stCurrency: + case ObjectGetType(obj) of + stBoolean: Result := GetDblCompResult(FO.c_currency - ord(obj.AsBoolean)); + stDouble: Result := GetDblCompResult(FO.c_currency - obj.AsDouble); + stCurrency:Result := GetDblCompResult(FO.c_currency - obj.AsCurrency); + stInt: Result := GetDblCompResult(FO.c_currency - obj.AsInteger); + stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); + else + Result := cpError; + end; + stInt: + case ObjectGetType(obj) of + stBoolean: Result := GetIntCompResult(FO.c_int - ord(obj.AsBoolean)); + stDouble: Result := GetDblCompResult(FO.c_int - obj.AsDouble); + stCurrency:Result := GetDblCompResult(FO.c_int - obj.AsCurrency); + stInt: Result := GetIntCompResult(FO.c_int - obj.AsInteger); + stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); + else + Result := cpError; + end; + stString: + case ObjectGetType(obj) of + stBoolean, + stDouble, + stCurrency, + stInt, + stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); + else + Result := cpError; + end; + else + Result := cpError; + end; +end; + +{$IFDEF SUPER_METHOD} +function TSuperObject.AsMethod: TSuperMethod; +begin + if FDataType = stMethod then + Result := FO.c_method else + Result := nil; +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +constructor TSuperObject.Create(m: TSuperMethod); +begin + Create(stMethod); + FO.c_method := m; +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +function TSuperObject.GetM(const path: SOString): TSuperMethod; +var + v: ISuperObject; +begin + v := ParseString(PSOChar(path), False, True, Self); + if (v <> nil) and (ObjectGetType(v) = stMethod) then + Result := v.AsMethod else + Result := nil; +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +procedure TSuperObject.PutM(const path: SOString; Value: TSuperMethod); +begin + ParseString(PSOChar(path), False, True, Self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +function TSuperObject.call(const path: SOString; const param: ISuperObject): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], param); +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +function TSuperObject.call(const path, param: SOString): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], TSuperObject.ParseString(PSOChar(param), False)); +end; +{$ENDIF} + +function TSuperObject.GetProcessing: boolean; +begin + Result := FProcessing; +end; + +procedure TSuperObject.SetDataPtr(const Value: Pointer); +begin + FDataPtr := Value; +end; + +procedure TSuperObject.SetProcessing(value: boolean); +begin + FProcessing := value; +end; + +{ TSuperArray } + +function TSuperArray.Add(const Data: ISuperObject): Integer; +begin + Result := FLength; + PutO(Result, data); +end; + +function TSuperArray.Delete(index: Integer): ISuperObject; +begin + if (Index >= 0) and (Index < FLength) then + begin + Result := FArray^[index]; + FArray^[index] := nil; + Dec(FLength); + if Index < FLength then + begin + Move(FArray^[index + 1], FArray^[index], + (FLength - index) * SizeOf(Pointer)); + Pointer(FArray^[FLength]) := nil; + end; + end; +end; + +procedure TSuperArray.Insert(index: Integer; const value: ISuperObject); +begin + if (Index >= 0) then + if (index < FLength) then + begin + if FLength = FSize then + Expand(index); + if Index < FLength then + Move(FArray^[index], FArray^[index + 1], + (FLength - index) * SizeOf(Pointer)); + Pointer(FArray^[index]) := nil; + FArray^[index] := value; + Inc(FLength); + end else + PutO(index, value); +end; + +procedure TSuperArray.Clear(all: boolean); +var + j: Integer; +begin + for j := 0 to FLength - 1 do + if FArray^[j] <> nil then + begin + if all then + FArray^[j].Clear(all); + FArray^[j] := nil; + end; + FLength := 0; +end; + +procedure TSuperArray.Pack(all: boolean); +var + PackedCount, StartIndex, EndIndex, j: Integer; +begin + if FLength > 0 then + begin + PackedCount := 0; + StartIndex := 0; + repeat + while (StartIndex < FLength) and (FArray^[StartIndex] = nil) do + Inc(StartIndex); + if StartIndex < FLength then + begin + EndIndex := StartIndex; + while (EndIndex < FLength) and (FArray^[EndIndex] <> nil) do + Inc(EndIndex); + + Dec(EndIndex); + + if StartIndex > PackedCount then + Move(FArray^[StartIndex], FArray^[PackedCount], (EndIndex - StartIndex + 1) * SizeOf(Pointer)); + + Inc(PackedCount, EndIndex - StartIndex + 1); + StartIndex := EndIndex + 1; + end; + until StartIndex >= FLength; + FillChar(FArray^[PackedCount], (FLength - PackedCount) * sizeof(Pointer), 0); + FLength := PackedCount; + if all then + for j := 0 to FLength - 1 do + FArray^[j].Pack(all); + end; +end; + +constructor TSuperArray.Create; +begin + inherited Create; + FSize := SUPER_ARRAY_LIST_DEFAULT_SIZE; + FLength := 0; + GetMem(FArray, sizeof(Pointer) * FSize); + FillChar(FArray^, sizeof(Pointer) * FSize, 0); +end; + +destructor TSuperArray.Destroy; +begin + Clear; + FreeMem(FArray); + inherited; +end; + +function TSuperArray.ToJson: string; +var + i: Integer; + o: ISuperObject; +begin + Result := '['; + for i := 0 to Self.Length-1 do + begin + o := Self.O[i]; + Result := Result + #13#10 + + o.AsJSon() + end; + Result := Result + #13#10 + ']'; +end; + +procedure TSuperArray.Expand(max: Integer); +var + new_size: Integer; +begin + if (max < FSize) then + Exit; + if max < (FSize shl 1) then + new_size := (FSize shl 1) else + new_size := max + 1; + ReallocMem(FArray, new_size * sizeof(Pointer)); + FillChar(FArray^[FSize], (new_size - FSize) * sizeof(Pointer), 0); + FSize := new_size; +end; + +function TSuperArray.GetO(const index: Integer): ISuperObject; +begin + if(index >= FLength) then + Result := nil else + Result := FArray^[index]; +end; + +function TSuperArray.GetB(const index: integer): Boolean; +var + obj: ISuperObject; +begin + obj := GetO(index); + if obj <> nil then + Result := obj.AsBoolean else + Result := false; +end; + +function TSuperArray.GetD(const index: integer): Double; +var + obj: ISuperObject; +begin + obj := GetO(index); + if obj <> nil then + Result := obj.AsDouble else + Result := 0.0; +end; + +function TSuperArray.GetI(const index: integer): SuperInt; +var + obj: ISuperObject; +begin + obj := GetO(index); + if obj <> nil then + Result := obj.AsInteger else + Result := 0; +end; + +function TSuperArray.GetS(const index: integer): SOString; +var + obj: ISuperObject; +begin + obj := GetO(index); + if obj <> nil then + Result := obj.AsString else + Result := ''; +end; + +procedure TSuperArray.PutO(const index: Integer; const Value: ISuperObject); +begin + Expand(index); + FArray^[index] := value; + if(FLength <= index) then FLength := index + 1; +end; + +function TSuperArray.GetN(const index: integer): ISuperObject; +begin + Result := GetO(index); + if Result = nil then + Result := TSuperObject.Create(stNull); +end; + +procedure TSuperArray.PutN(const index: integer; const Value: ISuperObject); +begin + if Value <> nil then + PutO(index, Value) else + PutO(index, TSuperObject.Create(stNull)); +end; + +procedure TSuperArray.PutB(const index: integer; Value: Boolean); +begin + PutO(index, TSuperObject.Create(Value)); +end; + +procedure TSuperArray.PutD(const index: integer; Value: Double); +begin + PutO(index, TSuperObject.Create(Value)); +end; + +function TSuperArray.GetC(const index: integer): Currency; +var + obj: ISuperObject; +begin + obj := GetO(index); + if obj <> nil then + Result := obj.AsCurrency else + Result := 0.0; +end; + +procedure TSuperArray.PutC(const index: integer; Value: Currency); +begin + PutO(index, TSuperObject.CreateCurrency(Value)); +end; + +procedure TSuperArray.PutI(const index: integer; Value: SuperInt); +begin + PutO(index, TSuperObject.Create(Value)); +end; + +procedure TSuperArray.PutS(const index: integer; const Value: SOString); +begin + PutO(index, TSuperObject.Create(Value)); +end; + +{$IFDEF SUPER_METHOD} +function TSuperArray.GetM(const index: integer): TSuperMethod; +var + v: ISuperObject; +begin + v := GetO(index); + if (ObjectGetType(v) = stMethod) then + Result := v.AsMethod else + Result := nil; +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +procedure TSuperArray.PutM(const index: integer; Value: TSuperMethod); +begin + PutO(index, TSuperObject.Create(Value)); +end; +{$ENDIF} + +{ TSuperWriterString } + +function TSuperWriterString.Append(buf: PSOChar; Size: Integer): Integer; + function max(a, b: Integer): integer; begin if a > b then Result := a else Result := b end; +begin + Result := size; + if Size > 0 then + begin + if (FSize - FBPos <= size) then + begin + FSize := max(FSize * 2, FBPos + size + 8); + ReallocMem(FBuf, FSize * SizeOf(SOChar)); + end; + // fast move + case size of + 1: FBuf[FBPos] := buf^; + 2: PInteger(@FBuf[FBPos])^ := PInteger(buf)^; + 4: PInt64(@FBuf[FBPos])^ := PInt64(buf)^; + else + move(buf^, FBuf[FBPos], size * SizeOf(SOChar)); + end; + inc(FBPos, size); + FBuf[FBPos] := #0; + end; +end; + +function TSuperWriterString.Append(buf: PSOChar): Integer; +begin + Result := Append(buf, strlen(buf)); +end; + +constructor TSuperWriterString.Create; +begin + inherited; + FSize := 32; + FBPos := 0; + GetMem(FBuf, FSize * SizeOf(SOChar)); +end; + +destructor TSuperWriterString.Destroy; +begin + inherited; + if FBuf <> nil then + FreeMem(FBuf) +end; + +function TSuperWriterString.GetString: SOString; +begin + SetString(Result, FBuf, FBPos); +end; + +procedure TSuperWriterString.Reset; +begin + FBuf[0] := #0; + FBPos := 0; +end; + +procedure TSuperWriterString.TrimRight; +begin + while (FBPos > 0) and (FBuf[FBPos-1] < #256) and (AnsiChar(FBuf[FBPos-1]) in [#32, #13, #10]) do + begin + dec(FBPos); + FBuf[FBPos] := #0; + end; +end; + +{ TSuperWriterStream } + +function TSuperWriterStream.Append(buf: PSOChar): Integer; +begin + Result := Append(buf, StrLen(buf)); +end; + +constructor TSuperWriterStream.Create(AStream: TStream); +begin + inherited Create; + FStream := AStream; +end; + +procedure TSuperWriterStream.Reset; +begin + FStream.Size := 0; +end; + +{ TSuperWriterStream } + +function TSuperAnsiWriterStream.Append(buf: PSOChar; Size: Integer): Integer; +var + Buffer: array[0..1023] of AnsiChar; + pBuffer: PAnsiChar; + i: Integer; +begin + if Size = 1 then + Result := FStream.Write(buf^, Size) else + begin + if Size > SizeOf(Buffer) then + GetMem(pBuffer, Size) else + pBuffer := @Buffer; + try + for i := 0 to Size - 1 do + pBuffer[i] := AnsiChar(buf[i]); + Result := FStream.Write(pBuffer^, Size); + finally + if pBuffer <> @Buffer then + FreeMem(pBuffer); + end; + end; +end; + +{ TSuperUnicodeWriterStream } + +function TSuperUnicodeWriterStream.Append(buf: PSOChar; Size: Integer): Integer; +begin + Result := FStream.Write(buf^, Size * 2); +end; + +{ TSuperWriterFake } + +function TSuperWriterFake.Append(buf: PSOChar; Size: Integer): Integer; +begin + inc(FSize, Size); + Result := FSize; +end; + +function TSuperWriterFake.Append(buf: PSOChar): Integer; +begin + inc(FSize, Strlen(buf)); + Result := FSize; +end; + +constructor TSuperWriterFake.Create; +begin + inherited Create; + FSize := 0; +end; + +procedure TSuperWriterFake.Reset; +begin + FSize := 0; +end; + +{ TSuperWriterSock } + +function TSuperWriterSock.Append(buf: PSOChar; Size: Integer): Integer; +var + Buffer: array[0..1023] of AnsiChar; + pBuffer: PAnsiChar; + i: Integer; +begin + if Size = 1 then +{$IFDEF FPC} + Result := fpsend(FSocket, buf, size, 0) else +{$ELSE} + Result := send(FSocket, buf^, size, 0) else +{$ENDIF} + begin + if Size > SizeOf(Buffer) then + GetMem(pBuffer, Size) else + pBuffer := @Buffer; + try + for i := 0 to Size - 1 do + pBuffer[i] := AnsiChar(buf[i]); +{$IFDEF FPC} + Result := fpsend(FSocket, pBuffer, size, 0); +{$ELSE} + Result := send(FSocket, pBuffer^, size, 0); +{$ENDIF} + finally + if pBuffer <> @Buffer then + FreeMem(pBuffer); + end; + end; + inc(FSize, Result); +end; + +function TSuperWriterSock.Append(buf: PSOChar): Integer; +begin + Result := Append(buf, StrLen(buf)); +end; + +constructor TSuperWriterSock.Create(ASocket: Integer); +begin + inherited Create; + FSocket := ASocket; + FSize := 0; +end; + +procedure TSuperWriterSock.Reset; +begin + FSize := 0; +end; + +{ TSuperTokenizer } + +constructor TSuperTokenizer.Create; +begin + pb := TSuperWriterString.Create; + line := 1; + col := 0; + Reset; +end; + +destructor TSuperTokenizer.Destroy; +begin + Reset; + pb.Free; + inherited; +end; + +procedure TSuperTokenizer.Reset; +var + i: integer; +begin + for i := depth downto 0 do + ResetLevel(i); + depth := 0; + err := teSuccess; +end; + +procedure TSuperTokenizer.ResetLevel(adepth: integer); +begin + stack[adepth].state := tsEatws; + stack[adepth].saved_state := tsStart; + stack[adepth].current := nil; + stack[adepth].field_name := ''; + stack[adepth].obj := nil; + stack[adepth].parent := nil; + stack[adepth].gparent := nil; +end; + +{ TSuperAvlTree } + +constructor TSuperAvlTree.Create; +begin + FRoot := nil; + FCount := 0; +end; + +destructor TSuperAvlTree.Destroy; +begin + Clear; + inherited; +end; + +function TSuperAvlTree.IsEmpty: boolean; +begin + result := FRoot = nil; +end; + +function TSuperAvlTree.balance(bal: TSuperAvlEntry): TSuperAvlEntry; +var + deep, old: TSuperAvlEntry; + bf: integer; +begin + if (bal.FBf > 0) then + begin + deep := bal.FGt; + if (deep.FBf < 0) then + begin + old := bal; + bal := deep.FLt; + old.FGt := bal.FLt; + deep.FLt := bal.FGt; + bal.FLt := old; + bal.FGt := deep; + bf := bal.FBf; + if (bf <> 0) then + begin + if (bf > 0) then + begin + old.FBf := -1; + deep.FBf := 0; + end else + begin + deep.FBf := 1; + old.FBf := 0; + end; + bal.FBf := 0; + end else + begin + old.FBf := 0; + deep.FBf := 0; + end; + end else + begin + bal.FGt := deep.FLt; + deep.FLt := bal; + if (deep.FBf = 0) then + begin + deep.FBf := -1; + bal.FBf := 1; + end else + begin + deep.FBf := 0; + bal.FBf := 0; + end; + bal := deep; + end; + end else + begin + (* "Less than" subtree is deeper. *) + + deep := bal.FLt; + if (deep.FBf > 0) then + begin + old := bal; + bal := deep.FGt; + old.FLt := bal.FGt; + deep.FGt := bal.FLt; + bal.FGt := old; + bal.FLt := deep; + + bf := bal.FBf; + if (bf <> 0) then + begin + if (bf < 0) then + begin + old.FBf := 1; + deep.FBf := 0; + end else + begin + deep.FBf := -1; + old.FBf := 0; + end; + bal.FBf := 0; + end else + begin + old.FBf := 0; + deep.FBf := 0; + end; + end else + begin + bal.FLt := deep.FGt; + deep.FGt := bal; + if (deep.FBf = 0) then + begin + deep.FBf := 1; + bal.FBf := -1; + end else + begin + deep.FBf := 0; + bal.FBf := 0; + end; + bal := deep; + end; + end; + Result := bal; +end; + +function TSuperAvlTree.Insert(h: TSuperAvlEntry): TSuperAvlEntry; +var + unbal, parentunbal, hh, parent: TSuperAvlEntry; + depth, unbaldepth: longint; + cmp: integer; + unbalbf: integer; + branch: TSuperAvlBitArray; + p: Pointer; +begin + inc(FCount); + h.FLt := nil; + h.FGt := nil; + h.FBf := 0; + branch := []; + + if (FRoot = nil) then + FRoot := h + else + begin + unbal := nil; + parentunbal := nil; + depth := 0; + unbaldepth := 0; + hh := FRoot; + parent := nil; + repeat + if (hh.FBf <> 0) then + begin + unbal := hh; + parentunbal := parent; + unbaldepth := depth; + end; + if hh.FHash <> h.FHash then + begin + if hh.FHash < h.FHash then cmp := -1 else + if hh.FHash > h.FHash then cmp := 1 else + cmp := 0; + end else + cmp := CompareNodeNode(h, hh); + if (cmp = 0) then + begin + Result := hh; + //exchange data + p := hh.Ptr; + hh.FPtr := h.Ptr; + h.FPtr := p; + doDeleteEntry(h, false); + dec(FCount); + exit; + end; + parent := hh; + if (cmp > 0) then + begin + hh := hh.FGt; + include(branch, depth); + end else + begin + hh := hh.FLt; + exclude(branch, depth); + end; + inc(depth); + until (hh = nil); + + if (cmp < 0) then + parent.FLt := h else + parent.FGt := h; + + depth := unbaldepth; + + if (unbal = nil) then + hh := FRoot + else + begin + if depth in branch then + cmp := 1 else + cmp := -1; + inc(depth); + unbalbf := unbal.FBf; + if (cmp < 0) then + dec(unbalbf) else + inc(unbalbf); + if cmp < 0 then + hh := unbal.FLt else + hh := unbal.FGt; + if ((unbalbf <> -2) and (unbalbf <> 2)) then + begin + unbal.FBf := unbalbf; + unbal := nil; + end; + end; + + if (hh <> nil) then + while (h <> hh) do + begin + if depth in branch then + cmp := 1 else + cmp := -1; + inc(depth); + if (cmp < 0) then + begin + hh.FBf := -1; + hh := hh.FLt; + end else (* cmp > 0 *) + begin + hh.FBf := 1; + hh := hh.FGt; + end; + end; + + if (unbal <> nil) then + begin + unbal := balance(unbal); + if (parentunbal = nil) then + FRoot := unbal + else + begin + depth := unbaldepth - 1; + if depth in branch then + cmp := 1 else + cmp := -1; + if (cmp < 0) then + parentunbal.FLt := unbal else + parentunbal.FGt := unbal; + end; + end; + end; + result := h; +end; + +function TSuperAvlTree.Search(const k: SOString; st: TSuperAvlSearchTypes): TSuperAvlEntry; +var + cmp, target_cmp: integer; + match_h, h: TSuperAvlEntry; + ha: Cardinal; +begin + ha := TSuperAvlEntry.Hash(k); + + match_h := nil; + h := FRoot; + + if (stLess in st) then + target_cmp := 1 else + if (stGreater in st) then + target_cmp := -1 else + target_cmp := 0; + + while (h <> nil) do + begin + if h.FHash < ha then cmp := -1 else + if h.FHash > ha then cmp := 1 else + cmp := 0; + + if cmp = 0 then + cmp := CompareKeyNode(PSOChar(k), h); + if (cmp = 0) then + begin + if (stEqual in st) then + begin + match_h := h; + break; + end; + cmp := -target_cmp; + end + else + if (target_cmp <> 0) then + if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then + match_h := h; + if cmp < 0 then + h := h.FLt else + h := h.FGt; + end; + result := match_h; +end; + +function TSuperAvlTree.Delete(const k: SOString): ISuperObject; +var + depth, rm_depth: longint; + branch: TSuperAvlBitArray; + h, parent, child, path, rm, parent_rm: TSuperAvlEntry; + cmp, cmp_shortened_sub_with_path, reduced_depth, bf: integer; + ha: Cardinal; +begin + ha := TSuperAvlEntry.Hash(k); + cmp_shortened_sub_with_path := 0; + branch := []; + + depth := 0; + h := FRoot; + parent := nil; + while true do + begin + if (h = nil) then + exit; + if h.FHash < ha then cmp := -1 else + if h.FHash > ha then cmp := 1 else + cmp := 0; + + if cmp = 0 then + cmp := CompareKeyNode(k, h); + if (cmp = 0) then + break; + parent := h; + if (cmp > 0) then + begin + h := h.FGt; + include(branch, depth) + end else + begin + h := h.FLt; + exclude(branch, depth) + end; + inc(depth); + cmp_shortened_sub_with_path := cmp; + end; + rm := h; + parent_rm := parent; + rm_depth := depth; + + if (h.FBf < 0) then + begin + child := h.FLt; + exclude(branch, depth); + cmp := -1; + end else + begin + child := h.FGt; + include(branch, depth); + cmp := 1; + end; + inc(depth); + + if (child <> nil) then + begin + cmp := -cmp; + repeat + parent := h; + h := child; + if (cmp < 0) then + begin + child := h.FLt; + exclude(branch, depth); + end else + begin + child := h.FGt; + include(branch, depth); + end; + inc(depth); + until (child = nil); + + if (parent = rm) then + cmp_shortened_sub_with_path := -cmp else + cmp_shortened_sub_with_path := cmp; + + if cmp > 0 then + child := h.FLt else + child := h.FGt; + end; + + if (parent = nil) then + FRoot := child else + if (cmp_shortened_sub_with_path < 0) then + parent.FLt := child else + parent.FGt := child; + + if parent = rm then + path := h else + path := parent; + + if (h <> rm) then + begin + h.FLt := rm.FLt; + h.FGt := rm.FGt; + h.FBf := rm.FBf; + if (parent_rm = nil) then + FRoot := h + else + begin + depth := rm_depth - 1; + if (depth in branch) then + parent_rm.FGt := h else + parent_rm.FLt := h; + end; + end; + + if (path <> nil) then + begin + h := FRoot; + parent := nil; + depth := 0; + while (h <> path) do + begin + if (depth in branch) then + begin + child := h.FGt; + h.FGt := parent; + end else + begin + child := h.FLt; + h.FLt := parent; + end; + inc(depth); + parent := h; + h := child; + end; + + reduced_depth := 1; + cmp := cmp_shortened_sub_with_path; + while true do + begin + if (reduced_depth <> 0) then + begin + bf := h.FBf; + if (cmp < 0) then + inc(bf) else + dec(bf); + if ((bf = -2) or (bf = 2)) then + begin + h := balance(h); + bf := h.FBf; + end else + h.FBf := bf; + reduced_depth := integer(bf = 0); + end; + if (parent = nil) then + break; + child := h; + h := parent; + dec(depth); + if depth in branch then + cmp := 1 else + cmp := -1; + if (cmp < 0) then + begin + parent := h.FLt; + h.FLt := child; + end else + begin + parent := h.FGt; + h.FGt := child; + end; + end; + FRoot := h; + end; + if rm <> nil then + begin + Result := rm.GetValue; + doDeleteEntry(rm, false); + dec(FCount); + end; +end; + +procedure TSuperAvlTree.Pack(all: boolean); +var + node1, node2: TSuperAvlEntry; + list: TList; + i: Integer; +begin + node1 := FRoot; + list := TList.Create; + while node1 <> nil do + begin + if (node1.FLt = nil) then + begin + node2 := node1.FGt; + if (node1.FPtr = nil) then + list.Add(node1) else + if all then + node1.Value.Pack(all); + end + else + begin + node2 := node1.FLt; + node1.FLt := node2.FGt; + node2.FGt := node1; + end; + node1 := node2; + end; + for i := 0 to list.Count - 1 do + Delete(TSuperAvlEntry(list[i]).FName); + list.Free; +end; + +procedure TSuperAvlTree.Clear(all: boolean); +var + node1, node2: TSuperAvlEntry; +begin + node1 := FRoot; + while node1 <> nil do + begin + if (node1.FLt = nil) then + begin + node2 := node1.FGt; + doDeleteEntry(node1, all); + end + else + begin + node2 := node1.FLt; + node1.FLt := node2.FGt; + node2.FGt := node1; + end; + node1 := node2; + end; + FRoot := nil; + FCount := 0; +end; + +function TSuperAvlTree.CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer; +begin + Result := StrComp(PSOChar(k), PSOChar(h.FName)); +end; + +function TSuperAvlTree.CompareNodeNode(node1, node2: TSuperAvlEntry): integer; +begin + Result := StrComp(PSOChar(node1.FName), PSOChar(node2.FName)); +end; + +{ TSuperAvlIterator } + +(* Initialize depth to invalid value, to indicate iterator is +** invalid. (Depth is zero-base.) It's not necessary to initialize +** iterators prior to passing them to the "start" function. +*) + +constructor TSuperAvlIterator.Create(tree: TSuperAvlTree); +begin + FDepth := not 0; + FTree := tree; +end; + +procedure TSuperAvlIterator.Search(const k: SOString; st: TSuperAvlSearchTypes); +var + h: TSuperAvlEntry; + d: longint; + cmp, target_cmp: integer; + ha: Cardinal; +begin + ha := TSuperAvlEntry.Hash(k); + h := FTree.FRoot; + d := 0; + FDepth := not 0; + if (h = nil) then + exit; + + if (stLess in st) then + target_cmp := 1 else + if (stGreater in st) then + target_cmp := -1 else + target_cmp := 0; + + while true do + begin + if h.FHash < ha then cmp := -1 else + if h.FHash > ha then cmp := 1 else + cmp := 0; + + if cmp = 0 then + cmp := FTree.CompareKeyNode(k, h); + if (cmp = 0) then + begin + if (stEqual in st) then + begin + FDepth := d; + break; + end; + cmp := -target_cmp; + end + else + if (target_cmp <> 0) then + if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then + FDepth := d; + if cmp < 0 then + h := h.FLt else + h := h.FGt; + if (h = nil) then + break; + if (cmp > 0) then + include(FBranch, d) else + exclude(FBranch, d); + FPath[d] := h; + inc(d); + end; +end; + +procedure TSuperAvlIterator.First; +var + h: TSuperAvlEntry; +begin + h := FTree.FRoot; + FDepth := not 0; + FBranch := []; + while (h <> nil) do + begin + if (FDepth <> not 0) then + FPath[FDepth] := h; + inc(FDepth); + h := h.FLt; + end; +end; + +procedure TSuperAvlIterator.Last; +var + h: TSuperAvlEntry; +begin + h := FTree.FRoot; + FDepth := not 0; + FBranch := [0..SUPER_AVL_MAX_DEPTH - 1]; + while (h <> nil) do + begin + if (FDepth <> not 0) then + FPath[FDepth] := h; + inc(FDepth); + h := h.FGt; + end; +end; + +function TSuperAvlIterator.MoveNext: boolean; +begin + if FDepth = not 0 then + First else + Next; + Result := GetIter <> nil; +end; + +function TSuperAvlIterator.GetIter: TSuperAvlEntry; +begin + if (FDepth = not 0) then + begin + result := nil; + exit; + end; + if FDepth = 0 then + Result := FTree.FRoot else + Result := FPath[FDepth - 1]; +end; + +procedure TSuperAvlIterator.Next; +var + h: TSuperAvlEntry; +begin + if (FDepth <> not 0) then + begin + if FDepth = 0 then + h := FTree.FRoot.FGt else + h := FPath[FDepth - 1].FGt; + + if (h = nil) then + repeat + if (FDepth = 0) then + begin + FDepth := not 0; + break; + end; + dec(FDepth); + until (not (FDepth in FBranch)) + else + begin + include(FBranch, FDepth); + FPath[FDepth] := h; + inc(FDepth); + while true do + begin + h := h.FLt; + if (h = nil) then + break; + exclude(FBranch, FDepth); + FPath[FDepth] := h; + inc(FDepth); + end; + end; + end; +end; + +procedure TSuperAvlIterator.Prior; +var + h: TSuperAvlEntry; +begin + if (FDepth <> not 0) then + begin + if FDepth = 0 then + h := FTree.FRoot.FLt else + h := FPath[FDepth - 1].FLt; + if (h = nil) then + repeat + if (FDepth = 0) then + begin + FDepth := not 0; + break; + end; + dec(FDepth); + until (FDepth in FBranch) + else + begin + exclude(FBranch, FDepth); + FPath[FDepth] := h; + inc(FDepth); + while true do + begin + h := h.FGt; + if (h = nil) then + break; + include(FBranch, FDepth); + FPath[FDepth] := h; + inc(FDepth); + end; + end; + end; +end; + +procedure TSuperAvlTree.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); +begin + Entry.Free; +end; + +function TSuperAvlTree.GetEnumerator: TSuperAvlIterator; +begin + Result := TSuperAvlIterator.Create(Self); +end; + +{ TSuperAvlEntry } + +constructor TSuperAvlEntry.Create(const AName: SOString; Obj: Pointer); +begin + FName := AName; + FPtr := Obj; + FHash := Hash(FName); +end; + +function TSuperAvlEntry.GetValue: ISuperObject; +begin + Result := ISuperObject(FPtr) +end; + +class function TSuperAvlEntry.Hash(const k: SOString): Cardinal; +var + h: cardinal; + i: Integer; +begin + h := 0; +{$Q-} + for i := 1 to Length(k) do + h := h*129 + ord(k[i]) + $9e370001; +{$Q+} + Result := h; +end; + +procedure TSuperAvlEntry.SetValue(const val: ISuperObject); +begin + ISuperObject(FPtr) := val; +end; + +{ TSuperTableString } + +function TSuperTableString.GetValues: ISuperObject; +var + ite: TSuperAvlIterator; + obj: TSuperAvlEntry; +begin + Result := TSuperObject.Create(stArray); + ite := TSuperAvlIterator.Create(Self); + try + ite.First; + obj := ite.GetIter; + while obj <> nil do + begin + Result.AsArray.Add(obj.Value); + ite.Next; + obj := ite.GetIter; + end; + finally + ite.Free; + end; +end; + +function TSuperTableString.GetNames: ISuperObject; +var + ite: TSuperAvlIterator; + obj: TSuperAvlEntry; +begin + Result := TSuperObject.Create(stArray); + ite := TSuperAvlIterator.Create(Self); + try + ite.First; + obj := ite.GetIter; + while obj <> nil do + begin + Result.AsArray.Add(TSuperObject.Create(obj.FName)); + ite.Next; + obj := ite.GetIter; + end; + finally + ite.Free; + end; +end; + +procedure TSuperTableString.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); +begin + if Entry.Ptr <> nil then + begin + if all then Entry.Value.Clear(true); + Entry.Value := nil; + end; + inherited; +end; + +function TSuperTableString.GetO(const k: SOString): ISuperObject; +var + e: TSuperAvlEntry; +begin + e := Search(k); + if e <> nil then + Result := e.Value else + Result := nil +end; + +procedure TSuperTableString.PutO(const k: SOString; const value: ISuperObject); +var + entry: TSuperAvlEntry; +begin + entry := Insert(TSuperAvlEntry.Create(k, Pointer(value))); + if entry.FPtr <> nil then + ISuperObject(entry.FPtr)._AddRef; +end; + +procedure TSuperTableString.PutS(const k: SOString; const value: SOString); +begin + PutO(k, TSuperObject.Create(Value)); +end; + +function TSuperTableString.GetS(const k: SOString): SOString; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsString else + Result := ''; +end; + +procedure TSuperTableString.PutI(const k: SOString; value: SuperInt); +begin + PutO(k, TSuperObject.Create(Value)); +end; + +function TSuperTableString.GetI(const k: SOString): SuperInt; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsInteger else + Result := 0; +end; + +procedure TSuperTableString.PutD(const k: SOString; value: Double); +begin + PutO(k, TSuperObject.Create(Value)); +end; + +procedure TSuperTableString.PutC(const k: SOString; value: Currency); +begin + PutO(k, TSuperObject.CreateCurrency(Value)); +end; + +function TSuperTableString.GetC(const k: SOString): Currency; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsCurrency else + Result := 0.0; +end; + +function TSuperTableString.GetD(const k: SOString): Double; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsDouble else + Result := 0.0; +end; + +procedure TSuperTableString.PutB(const k: SOString; value: Boolean); +begin + PutO(k, TSuperObject.Create(Value)); +end; + +function TSuperTableString.GetB(const k: SOString): Boolean; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsBoolean else + Result := False; +end; + +{$IFDEF SUPER_METHOD} +procedure TSuperTableString.PutM(const k: SOString; value: TSuperMethod); +begin + PutO(k, TSuperObject.Create(Value)); +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +function TSuperTableString.GetM(const k: SOString): TSuperMethod; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsMethod else + Result := nil; +end; +{$ENDIF} + +procedure TSuperTableString.PutN(const k: SOString; const value: ISuperObject); +begin + if value <> nil then + PutO(k, TSuperObject.Create(stNull)) else + PutO(k, value); +end; + +function TSuperTableString.GetN(const k: SOString): ISuperObject; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj else + Result := TSuperObject.Create(stNull); +end; + + +{$IFDEF VER210} + +{ TSuperAttribute } + +constructor TSuperAttribute.Create(const AName: string); +begin + FName := AName; +end; + +{ TSuperRttiContext } + +constructor TSuperRttiContext.Create; +begin + Context := TRttiContext.Create; + SerialFromJson := TDictionary.Create; + SerialToJson := TDictionary.Create; + + SerialFromJson.Add(TypeInfo(Boolean), serialfromboolean); + SerialFromJson.Add(TypeInfo(TDateTime), serialfromdatetime); + SerialFromJson.Add(TypeInfo(TGUID), serialfromguid); + SerialToJson.Add(TypeInfo(Boolean), serialtoboolean); + SerialToJson.Add(TypeInfo(TDateTime), serialtodatetime); + SerialToJson.Add(TypeInfo(TGUID), serialtoguid); +end; + +destructor TSuperRttiContext.Destroy; +begin + SerialFromJson.Free; + SerialToJson.Free; + Context.Free; +end; + +class function TSuperRttiContext.GetFieldName(r: TRttiField): string; +var + o: TCustomAttribute; +begin + for o in r.GetAttributes do + if o is SOName then + Exit(SOName(o).Name); + Result := r.Name; +end; + +class function TSuperRttiContext.GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject; +var + o: TCustomAttribute; +begin + if not ObjectIsType(obj, stNull) then Exit(obj); + for o in r.GetAttributes do + if o is SODefault then + Exit(SO(SODefault(o).Name)); + Result := obj; +end; + +function TSuperRttiContext.AsType(const obj: ISuperObject): T; +var + ret: TValue; +begin + if FromJson(TypeInfo(T), obj, ret) then + Result := ret.AsType else + raise exception.Create('Marshalling error'); +end; + +function TSuperRttiContext.AsJson(const obj: T; const index: ISuperObject = nil): ISuperObject; +var + v: TValue; +begin + TValue.MakeWithoutCopy(@obj, TypeInfo(T), v); + if index <> nil then + Result := ToJson(v, index) else + Result := ToJson(v, so); +end; + +function TSuperRttiContext.FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject; + var Value: TValue): Boolean; + + procedure FromChar; + begin + if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then + begin + Value := string(AnsiString(obj.AsString)[1]); + Result := True; + end else + Result := False; + end; + + procedure FromWideChar; + begin + if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then + begin + Value := obj.AsString[1]; + Result := True; + end else + Result := False; + end; + + procedure FromInt64; + var + i: Int64; + begin + case ObjectGetType(obj) of + stInt: + begin + TValue.Make(nil, TypeInfo, Value); + TValueData(Value).FAsSInt64 := obj.AsInteger; + Result := True; + end; + stString: + begin + if TryStrToInt64(obj.AsString, i) then + begin + TValue.Make(nil, TypeInfo, Value); + TValueData(Value).FAsSInt64 := i; + Result := True; + end else + Result := False; + end; + else + Result := False; + end; + end; + + procedure FromInt(const obj: ISuperObject); + var + TypeData: PTypeData; + i: Integer; + o: ISuperObject; + begin + case ObjectGetType(obj) of + stInt, stBoolean: + begin + i := obj.AsInteger; + TypeData := GetTypeData(TypeInfo); + Result := (i >= TypeData.MinValue) and (i <= TypeData.MaxValue); + if Result then + TValue.Make(@i, TypeInfo, Value); + end; + stString: + begin + o := SO(obj.AsString); + if not ObjectIsType(o, stString) then + FromInt(o) else + Result := False; + end; + else + Result := False; + end; + end; + + procedure fromSet; + begin + if ObjectIsType(obj, stInt) then + begin + TValue.Make(nil, TypeInfo, Value); + TValueData(Value).FAsSLong := obj.AsInteger; + Result := True; + end else + Result := False; + end; + + procedure FromFloat(const obj: ISuperObject); + var + o: ISuperObject; + begin + case ObjectGetType(obj) of + stInt, stDouble, stCurrency: + begin + TValue.Make(nil, TypeInfo, Value); + case GetTypeData(TypeInfo).FloatType of + ftSingle: TValueData(Value).FAsSingle := obj.AsDouble; + ftDouble: TValueData(Value).FAsDouble := obj.AsDouble; + ftExtended: TValueData(Value).FAsExtended := obj.AsDouble; + ftComp: TValueData(Value).FAsSInt64 := obj.AsInteger; + ftCurr: TValueData(Value).FAsCurr := obj.AsCurrency; + end; + Result := True; + end; + stString: + begin + o := SO(obj.AsString); + if not ObjectIsType(o, stString) then + FromFloat(o) else + Result := False; + end + else + Result := False; + end; + end; + + procedure FromString; + begin + case ObjectGetType(obj) of + stObject, stArray: + Result := False; + stnull: + begin + Value := ''; + Result := True; + end; + else + Value := obj.AsString; + Result := True; + end; + end; + + procedure FromClass; + var + f: TRttiField; + v: TValue; + begin + case ObjectGetType(obj) of + stObject: + begin + Result := True; + if Value.Kind <> tkClass then + Value := GetTypeData(TypeInfo).ClassType.Create; + for f in Context.GetType(Value.AsObject.ClassType).GetFields do + if f.FieldType <> nil then + begin + Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v); + if Result then + f.SetValue(Value.AsObject, v) else + Exit; + end; + end; + stNull: + begin + Value := nil; + Result := True; + end + else + // error + Value := nil; + Result := False; + end; + end; + + procedure FromRecord; + var + f: TRttiField; + p: Pointer; + v: TValue; + begin + Result := True; + TValue.Make(nil, TypeInfo, Value); + for f in Context.GetType(TypeInfo).GetFields do + begin + if ObjectIsType(obj, stObject) and (f.FieldType <> nil) then + begin + p := IValueData(TValueData(Value).FHeapData).GetReferenceToRawData; + Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v); + if Result then + f.SetValue(p, v) else + Exit; + end else + begin + Result := False; + Exit; + end; + end; + end; + + procedure FromDynArray; + var + i: Integer; + p: Pointer; + pb: PByte; + val: TValue; + typ: PTypeData; + el: PTypeInfo; + begin + case ObjectGetType(obj) of + stArray: + begin + i := obj.AsArray.Length; + p := nil; + DynArraySetLength(p, TypeInfo, 1, @i); + pb := p; + typ := GetTypeData(TypeInfo); + if typ.elType <> nil then + el := typ.elType^ else + el := typ.elType2^; + + Result := True; + for i := 0 to i - 1 do + begin + Result := FromJson(el, obj.AsArray[i], val); + if not Result then + Break; + val.ExtractRawData(pb); + val := TValue.Empty; + Inc(pb, typ.elSize); + end; + if Result then + TValue.MakeWithoutCopy(@p, TypeInfo, Value) else + DynArrayClear(p, TypeInfo); + end; + stNull: + begin + TValue.MakeWithoutCopy(nil, TypeInfo, Value); + Result := True; + end; + else + i := 1; + p := nil; + DynArraySetLength(p, TypeInfo, 1, @i); + pb := p; + typ := GetTypeData(TypeInfo); + if typ.elType <> nil then + el := typ.elType^ else + el := typ.elType2^; + + Result := FromJson(el, obj, val); + val.ExtractRawData(pb); + val := TValue.Empty; + + if Result then + TValue.MakeWithoutCopy(@p, TypeInfo, Value) else + DynArrayClear(p, TypeInfo); + end; + end; + + procedure FromArray; + var + ArrayData: PArrayTypeData; + idx: Integer; + function ProcessDim(dim: Byte; const o: ISuperobject): Boolean; + var + i: Integer; + v: TValue; + a: PTypeData; + begin + if ObjectIsType(o, stArray) and (ArrayData.Dims[dim-1] <> nil) then + begin + a := @GetTypeData(ArrayData.Dims[dim-1]^).ArrayData; + if (a.MaxValue - a.MinValue + 1) <> o.AsArray.Length then + begin + Result := False; + Exit; + end; + Result := True; + if dim = ArrayData.DimCount then + for i := a.MinValue to a.MaxValue do + begin + Result := FromJson(ArrayData.ElType^, o.AsArray[i], v); + if not Result then + Exit; + Value.SetArrayElement(idx, v); + inc(idx); + end + else + for i := a.MinValue to a.MaxValue do + begin + Result := ProcessDim(dim + 1, o.AsArray[i]); + if not Result then + Exit; + end; + end else + Result := False; + end; + var + i: Integer; + v: TValue; + begin + TValue.Make(nil, TypeInfo, Value); + ArrayData := @GetTypeData(TypeInfo).ArrayData; + idx := 0; + if ArrayData.DimCount = 1 then + begin + if ObjectIsType(obj, stArray) and (obj.AsArray.Length = ArrayData.ElCount) then + begin + Result := True; + for i := 0 to ArrayData.ElCount - 1 do + begin + Result := FromJson(ArrayData.ElType^, obj.AsArray[i], v); + if not Result then + Exit; + Value.SetArrayElement(idx, v); + v := TValue.Empty; + inc(idx); + end; + end else + Result := False; + end else + Result := ProcessDim(1, obj); + end; + + procedure FromClassRef; + var + r: TRttiType; + begin + if ObjectIsType(obj, stString) then + begin + r := Context.FindType(obj.AsString); + if r <> nil then + begin + Value := TRttiInstanceType(r).MetaclassType; + Result := True; + end else + Result := False; + end else + Result := False; + end; + + procedure FromUnknown; + begin + case ObjectGetType(obj) of + stBoolean: + begin + Value := obj.AsBoolean; + Result := True; + end; + stDouble: + begin + Value := obj.AsDouble; + Result := True; + end; + stCurrency: + begin + Value := obj.AsCurrency; + Result := True; + end; + stInt: + begin + Value := obj.AsInteger; + Result := True; + end; + stString: + begin + Value := obj.AsString; + Result := True; + end + else + Value := nil; + Result := False; + end; + end; + + procedure FromInterface; + const soguid: TGuid = '{4B86A9E3-E094-4E5A-954A-69048B7B6327}'; + var + o: ISuperObject; + begin + if CompareMem(@GetTypeData(TypeInfo).Guid, @soguid, SizeOf(TGUID)) then + begin + if obj <> nil then + TValue.Make(@obj, TypeInfo, Value) else + begin + o := TSuperObject.Create(stNull); + TValue.Make(@o, TypeInfo, Value); + end; + Result := True; + end else + Result := False; + end; +var + Serial: TSerialFromJson; +begin + if TypeInfo <> nil then + begin + if not SerialFromJson.TryGetValue(TypeInfo, Serial) then + case TypeInfo.Kind of + tkChar: FromChar; + tkInt64: FromInt64; + tkEnumeration, tkInteger: FromInt(obj); + tkSet: fromSet; + tkFloat: FromFloat(obj); + tkString, tkLString, tkUString, tkWString: FromString; + tkClass: FromClass; + tkMethod: ; + tkWChar: FromWideChar; + tkRecord: FromRecord; + tkPointer: ; + tkInterface: FromInterface; + tkArray: FromArray; + tkDynArray: FromDynArray; + tkClassRef: FromClassRef; + else + FromUnknown + end else + begin + TValue.Make(nil, TypeInfo, Value); + Result := Serial(Self, obj, Value); + end; + end else + Result := False; +end; + +function TSuperRttiContext.ToJson(var value: TValue; const index: ISuperObject): ISuperObject; + procedure ToInt64; + begin + Result := TSuperObject.Create(SuperInt(Value.AsInt64)); + end; + + procedure ToChar; + begin + Result := TSuperObject.Create(string(Value.AsType)); + end; + + procedure ToInteger; + begin + Result := TSuperObject.Create(TValueData(Value).FAsSLong); + end; + + procedure ToFloat; + begin + case Value.TypeData.FloatType of + ftSingle: Result := TSuperObject.Create(TValueData(Value).FAsSingle); + ftDouble: Result := TSuperObject.Create(TValueData(Value).FAsDouble); + ftExtended: Result := TSuperObject.Create(TValueData(Value).FAsExtended); + ftComp: Result := TSuperObject.Create(TValueData(Value).FAsSInt64); + ftCurr: Result := TSuperObject.CreateCurrency(TValueData(Value).FAsCurr); + end; + end; + + procedure ToString; + begin + Result := TSuperObject.Create(string(Value.AsType)); + end; + + procedure ToClass; + var + o: ISuperObject; + f: TRttiField; + v: TValue; + begin + if TValueData(Value).FAsObject <> nil then + begin + o := index[IntToStr(Integer(Value.AsObject))]; + if o = nil then + begin + Result := TSuperObject.Create(stObject); + index[IntToStr(Integer(Value.AsObject))] := Result; + for f in Context.GetType(Value.AsObject.ClassType).GetFields do + if f.FieldType <> nil then + begin + v := f.GetValue(Value.AsObject); + Result.AsObject[GetFieldName(f)] := ToJson(v, index); + end + end else + Result := o; + end else + Result := nil; + end; + + procedure ToWChar; + begin + Result := TSuperObject.Create(string(Value.AsType)); + end; + + procedure ToVariant; + begin + Result := SO(Value.AsVariant); + end; + + procedure ToRecord; + var + f: TRttiField; + v: TValue; + begin + Result := TSuperObject.Create(stObject); + for f in Context.GetType(Value.TypeInfo).GetFields do + begin + v := f.GetValue(IValueData(TValueData(Value).FHeapData).GetReferenceToRawData); + Result.AsObject[GetFieldName(f)] := ToJson(v, index); + end; + end; + + procedure ToArray; + var + idx: Integer; + ArrayData: PArrayTypeData; + + procedure ProcessDim(dim: Byte; const o: ISuperObject); + var + dt: PTypeData; + i: Integer; + o2: ISuperObject; + v: TValue; + begin + if ArrayData.Dims[dim-1] = nil then Exit; + dt := GetTypeData(ArrayData.Dims[dim-1]^); + if Dim = ArrayData.DimCount then + for i := dt.MinValue to dt.MaxValue do + begin + v := Value.GetArrayElement(idx); + o.AsArray.Add(toJSon(v, index)); + inc(idx); + end + else + for i := dt.MinValue to dt.MaxValue do + begin + o2 := TSuperObject.Create(stArray); + o.AsArray.Add(o2); + ProcessDim(dim + 1, o2); + end; + end; + var + i: Integer; + v: TValue; + begin + Result := TSuperObject.Create(stArray); + ArrayData := @Value.TypeData.ArrayData; + idx := 0; + if ArrayData.DimCount = 1 then + for i := 0 to ArrayData.ElCount - 1 do + begin + v := Value.GetArrayElement(i); + Result.AsArray.Add(toJSon(v, index)) + end + else + ProcessDim(1, Result); + end; + + procedure ToDynArray; + var + i: Integer; + v: TValue; + begin + Result := TSuperObject.Create(stArray); + for i := 0 to Value.GetArrayLength - 1 do + begin + v := Value.GetArrayElement(i); + Result.AsArray.Add(toJSon(v, index)); + end; + end; + + procedure ToClassRef; + begin + if TValueData(Value).FAsClass <> nil then + Result := TSuperObject.Create(string( + TValueData(Value).FAsClass.UnitName + '.' + + TValueData(Value).FAsClass.ClassName)) else + Result := nil; + end; + + procedure ToInterface; + begin + if TValueData(Value).FHeapData <> nil then + TValueData(Value).FHeapData.QueryInterface(ISuperObject, Result) else + Result := nil; + end; + +var + Serial: TSerialToJson; +begin + if not SerialToJson.TryGetValue(value.TypeInfo, Serial) then + case Value.Kind of + tkInt64: ToInt64; + tkChar: ToChar; + tkSet, tkInteger, tkEnumeration: ToInteger; + tkFloat: ToFloat; + tkString, tkLString, tkUString, tkWString: ToString; + tkClass: ToClass; + tkWChar: ToWChar; + tkVariant: ToVariant; + tkRecord: ToRecord; + tkArray: ToArray; + tkDynArray: ToDynArray; + tkClassRef: ToClassRef; + tkInterface: ToInterface; + else + result := nil; + end else + Result := Serial(Self, value, index); +end; + +{ TSuperObjectHelper } + +constructor TSuperObjectHelper.FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil); +var + v: TValue; + ctxowned: Boolean; +begin + if ctx = nil then + begin + ctx := TSuperRttiContext.Create; + ctxowned := True; + end else + ctxowned := False; + try + v := Self; + if not ctx.FromJson(v.TypeInfo, obj, v) then + raise Exception.Create('Invalid object'); + finally + if ctxowned then + ctx.Free; + end; +end; + +constructor TSuperObjectHelper.FromJson(const str: string; ctx: TSuperRttiContext = nil); +begin + FromJson(SO(str), ctx); +end; + +function TSuperObjectHelper.ToJson(ctx: TSuperRttiContext = nil): ISuperObject; +var + v: TValue; + ctxowned: boolean; +begin + if ctx = nil then + begin + ctx := TSuperRttiContext.Create; + ctxowned := True; + end else + ctxowned := False; + try + v := Self; + Result := ctx.ToJson(v, SO); + finally + if ctxowned then + ctx.Free; + end; +end; + +{$ENDIF} + +{$IFDEF DEBUG} +initialization + +finalization + Assert(debugcount = 0, 'Memory leak'); +{$ENDIF} +end. + diff --git a/superobject/superxmlparser.pas b/superobject/superxmlparser.pas new file mode 100644 index 0000000..471e895 --- /dev/null +++ b/superobject/superxmlparser.pas @@ -0,0 +1,1391 @@ +unit superxmlparser; +{$IFDEF FPC} + {$MODE OBJFPC}{$H+} +{$ENDIF} + +interface + +uses superobject, classes; + + +type + TOnProcessingInstruction = procedure(const PI, PIParent: ISuperObject); + +function XMLParseString(const data: SOString; pack: Boolean = false; onpi: TOnProcessingInstruction = nil): ISuperObject; +function XMLParseStream(stream: TStream; pack: Boolean = false; onpi: TOnProcessingInstruction = nil): ISuperObject; +function XMLParseFile(const FileName: string; pack: Boolean = false; onpi: TOnProcessingInstruction = nil): ISuperObject; + +const + xmlname = '#name'; + xmlattributes = '#attributes'; + xmlchildren = '#children'; + + dtdname = '#name'; + dtdPubidLiteral = '#pubidliteral'; + dtdSystemLiteral = '#systemliteral'; + + +implementation +uses sysutils {$IFNDEF UNIX}, windows{$ENDIF}; + +const + XML_SPACE : PSOChar = #32; +// XML_ARL: PSOChar = '['; + XML_ARR: PSOChar = ']'; + XML_BIG: PSOChar = '>'; + XML_LOW: PSOChar = '<'; + XML_AMP: PSOChar = '&'; + XML_SQU: PSOChar = ''''; + XML_DQU: PSOChar = '"'; + +type + TSuperXMLState = ( + xsStart, // | + xsEatSpaces, // + xsElement, // <| + xsElementName, // <[a..z]| + xsAttributes, // ..<| + xsCloseElementName, // ..| + xsElementString, // |azer + xsElementComment, // + xsElementPI, // + xsElementCDATA, // + xsEscape, // &| + xsEscape_lt, // &l|t; + xsEscape_gt, // &g|t; + xsEscape_amp, // &a|mp; + xsEscape_apos, // &a|pos; + xsEscape_quot, // &q|uot; + xsEscape_char, // &#|; + xsEscape_char_num, // |123456; + xsEscape_char_hex, // &#x|000FFff; + xsEnd); + + TSuperXMLError = (xeSuccess, xeContinue, xeProcessInst, xeError); + TSuperXMLElementClass = (xcNone, xcElement, xcComment, xcString, xcCdata, xcDocType, xcProcessInst); + TSuperXMLEncoding = ({$IFNDEF UNIX}xnANSI,{$ENDIF} xnUTF8, xnUnicode); + + PSuperXMLStack = ^TSuperXMLStack; + TSuperXMLStack = record + state: TSuperXMLState; + savedstate: TSuperXMLState; + prev: PSuperXMLStack; + next: PSuperXMLStack; + clazz: TSuperXMLElementClass; + obj: ISuperObject; + end; + + TSuperXMLParser = class + private + FStack: PSuperXMLStack; + FDocType: ISuperObject; + FError: TSuperXMLError; + FStr: TSuperWriterString; + FValue: TSuperWriterString; + FPosition: Integer; + FAChar: SOChar; + FPack: Boolean; + procedure StackUp; + procedure StackDown; + procedure Reset; + function ParseBuffer(data: PSOChar; var PI, PIParent: ISuperObject; len: Integer = -1): Integer; + public + constructor Create(pack: Boolean); + destructor Destroy; override; + end; + +{ TXMLContext } + +constructor TSuperXMLParser.Create(pack: Boolean); +begin + FDocType := nil; + FStr := TSuperWriterString.Create; + FValue := TSuperWriterString.Create; + StackUp; + FError := xeSuccess; + FPack := pack; +end; + +destructor TSuperXMLParser.Destroy; +begin + while FStack <> nil do + StackDown; + FStr.Free; + FValue.Free; +end; + +procedure TSuperXMLParser.Reset; +begin + while FStack <> nil do + StackDown; + StackUp; + FError := xeSuccess; +end; + +function TSuperXMLParser.ParseBuffer(data: PSOChar; var PI, PIParent: ISuperObject; len: integer): Integer; +const + spaces = [#32,#9,#10,#13]; + alphas = ['a'..'z', 'A'..'Z', '_', ':', #161..#255]; + nums = ['0'..'9', '.', '-']; + hex = nums + ['a'..'f','A'..'F']; + alphanums = alphas + nums; + publitteral = [#32, #13, #10, 'a'..'z', 'A'..'Z', '0'..'9', '-', '''', '"', '(', ')', + '+', ',', '.', '/', ':', '=', '?', ';', '!', '*', '#', '@', '$', '_', '%']; + + function hexdigit(const x: SOChar): byte; + begin + if x <= '9' then + Result := byte(x) - byte('0') else + Result := (byte(x) and 7) + 9; + end; + + procedure putchildrenstr; + var + anobject: ISuperObject; + begin + anobject := FStack^.obj.AsObject[xmlchildren]; + if anobject = nil then + begin + anobject := TSuperObject.Create(stArray); + FStack^.obj.AsObject[xmlchildren] := anobject; + end; + anobject.AsArray.Add(TSuperObject.Create(FValue.Data)); + end; + + procedure AddProperty(const parent, value: ISuperObject; const name: SOString); + var + anobject: ISuperObject; + arr: ISuperObject; + begin + anobject := parent.AsObject[name]; + if anobject = nil then + parent.AsObject[name] := value else + begin + if (anobject.DataType = stArray) then + anobject.AsArray.Add(value) else + begin + arr := TSuperObject.Create(stArray); + arr.AsArray.Add(anobject); + arr.AsArray.Add(value); + parent.AsObject[name] := arr; + end; + end; + end; + + procedure packend; + var + anobject, anobject2: ISuperObject; + n: Integer; + begin + anobject := FStack^.obj.AsObject[xmlchildren]; + if (anobject <> nil) and (anobject.AsArray.Length = 1) and (anobject.AsArray[0].DataType = stString) then + begin + if FStack^.obj.AsObject.count = 2 then // name + children + begin + if FStack^.prev <> nil then + AddProperty(FStack^.prev^.obj, anobject.AsArray[0], FStack^.obj.AsObject.S[xmlname]) else + begin + AddProperty(FStack^.obj, anobject.AsArray[0], '#text'); + FStack^.obj.AsObject.Delete(xmlchildren); + end; + end + else + begin + AddProperty(FStack^.obj, anobject.AsArray[0], FStack^.obj.AsObject.S[xmlname]); + FStack^.obj.AsObject.Delete(xmlchildren); + if FStack^.prev <> nil then + AddProperty(FStack^.prev^.obj, FStack^.obj, FStack^.obj.AsObject.S[xmlname]) else + FStack^.obj.AsObject.Delete(xmlchildren); + FStack^.obj.AsObject.Delete(xmlname); + end; + end else + begin + if (anobject <> nil) then + begin + for n := 0 to anobject.AsArray.Length - 1 do + begin + anobject2 := anobject.AsArray[n]; + if ObjectIsType(anobject2, stObject) then + begin + AddProperty(FStack^.obj, anobject2, anobject2.AsObject.S[xmlname]); + anobject2.AsObject.Delete(xmlname); + end else + AddProperty(FStack^.obj, anobject2, '#text'); + end; + FStack^.obj.Delete(xmlchildren); + end; + if FStack^.prev <> nil then + AddProperty(FStack^.prev^.obj, FStack^.obj, FStack^.obj.AsObject.S[xmlname]); + FStack^.obj.Delete(xmlname); + end; + end; + +var + c: SOChar; + read: Integer; + p: PSOChar; + anobject: ISuperObject; +label + redo, err; +begin + p := data; + read := 0; + //Result := 0; + repeat + + if (read = len) then + begin + if (FStack^.prev = nil) and ((FStack^.state = xsEnd) or ((FStack^.state = xsEatSpaces) and (FStack^.savedstate = xsEnd))) then + begin + if FPack then + packend; + FError := xeSuccess; + end else + FError := xeContinue; + Result := read; + exit; + end; + c := p^; + redo: + case FStack^.state of + + xsEatSpaces: + if {$IFDEF UNICODE}(c < #256) and {$ENDIF} (AnsiChar(c) in spaces) then {nop} else + begin + FStack^.state := FStack^.savedstate; + goto redo; + end; + + xsStart: + case c of + '<': FStack^.state := xsElement; + else + goto err; + end; + xsElement: + begin + case c of + '?': + begin + FStack^.savedstate := xsStart; + FStack^.state := xsEatSpaces; + StackUp; + FStr.Reset; + FStack^.state := xsElementPI; + FStack^.clazz := xcProcessInst; + end; + '!': + begin + FPosition := 0; + FStack^.state := xsElementComment; + FStack^.clazz := xcComment; + end; + else + if ((c < #256) and (AnsiChar(c) in alphas)) or (c >= #256) then + begin + FStr.Reset; + FStack^.state := xsElementName; + FStack^.clazz := xcElement; + goto redo; + end else + goto err; + end; + end; + xsElementPI: + begin + if ((c < #256) and (AnsiChar(c) in alphanums)) or (c >= #256) then + FStr.Append(@c, 1) else + begin + FStack^.obj := TSuperObject.Create(stObject); + FStack^.obj.AsObject.S[xmlname] := FStr.Data; + FStack^.state := xsEatSpaces; + if FStr.Data = 'xml' then + FStack^.savedstate := xsAttributes else + begin + FValue.Reset; + FStack^.savedstate := xsElementDataPI; + end; + goto redo; + end; + end; + xsElementDataPI: + begin + case c of + '?': + begin + FStack^.obj.AsObject.S['data'] := FValue.Data; + FStack^.state := xsCloseElementPI; + end; + else + FValue.Append(@c, 1); + end; + end; + xsCloseElementPI: + begin + if (c <> '>') then goto err; + PI := FStack^.obj; + StackDown; + PIParent := FStack^.obj; + FError := xeProcessInst; + Result := read + 1; + Exit; + end; + xsElementName: + begin + if ((c < #256) and (AnsiChar(c) in alphanums)) or (c >= #256) then + FStr.Append(@c, 1) else + begin + FStack^.obj := TSuperObject.Create(stObject); + FStack^.obj.AsObject.S[xmlname] := FStr.Data; + FStack^.state := xsEatSpaces; + FStack^.savedstate := xsAttributes; + goto redo; + end; + end; + xsChildren: + begin + case c of + '<': FStack^.state := xsTryCloseElement; + else + FValue.Reset; + FStack^.state := xsElementString; + FStack^.clazz := xcString; + goto redo; + end; + end; + xsCloseEmptyElement: + begin + case c of + '>': + begin + FStack^.state := xsEatSpaces; + FStack^.savedstate := xsEnd; + end + else + goto err; + end; + end; + xsTryCloseElement: + begin + case c of + '/': begin + FStack^.state := xsCloseElementName; + FPosition := 0; + FStr.Reset; + FStr.Append(PSoChar(FStack^.obj.AsObject.S[xmlname])); + end; + '!': begin + FPosition := 0; + FStack^.state := xsElementComment; + FStack^.clazz := xcComment; + end; + '?': begin + FStack^.savedstate := xsChildren; + FStack^.state := xsEatSpaces; + StackUp; + FStr.Reset; + FStack^.state := xsElementPI; + FStack^.clazz := xcProcessInst; + end + else + FStack^.state := xsChildren; + StackUp; + if ((c < #256) and (AnsiChar(c) in alphas)) or (c >= #256) then + begin + FStr.Reset; + FStack^.state := xsElementName; + FStack^.clazz := xcElement; + goto redo; + end else + goto err; + end; + end; + xsCloseElementName: + begin + if FStr.Position = FPosition then + begin + FStack^.savedstate := xsCloseEmptyElement; + FStack^.state := xsEatSpaces; + goto redo; + end else + begin + if (c <> FStr.Data[FPosition]) then goto err; + inc(FPosition); + end; + end; + xsAttributes: + begin + case c of + '?': begin + if FStack^.clazz <> xcProcessInst then goto err; + FStack^.state := xsCloseElementPI; + end; + '/': begin + FStack^.state := xsCloseEmptyElement; + end; + '>': begin + FStack^.state := xsEatSpaces; + FStack^.savedstate := xsChildren; + end + else + if ((c < #256) and (AnsiChar(c) in alphas)) or (c >= #256) then + begin + FStr.Reset; + FStr.Append(@c, 1); + FStack^.state := xsAttributeName; + end else + goto err; + end; + end; + xsAttributeName: + begin + if ((c < #256) and (AnsiChar(c) in alphanums)) or (c >= #256) then + FStr.Append(@c, 1) else + begin + // no duplicate attribute + if FPack then + begin + if FStack^.obj.AsObject[FStr.Data] <> nil then + goto err; + end else + begin + anobject := FStack^.obj.AsObject[xmlattributes]; + if (anobject <> nil) and (anobject.AsObject[FStr.Data] <> nil) then + goto err; + end; + FStack^.state := xsEatSpaces; + FStack^.savedstate := xsEqual; + goto redo; + end; + end; + xsEqual: + begin + if c <> '=' then goto err; + FStack^.state := xsEatSpaces; + FStack^.savedstate := xsAttributeValue; + FValue.Reset; + FPosition := 0; + FAChar := #0; + end; + xsAttributeValue: + begin + if FAChar <> #0 then + begin + if (c = FAChar) then + begin + if FPack then + begin + FStack^.obj.AsObject[FStr.Data] := TSuperObject.Create(Fvalue.Data); + end else + begin + anobject := FStack^.obj.AsObject[xmlattributes]; + if anobject = nil then + begin + anobject := TSuperObject.Create(stObject); + FStack^.obj.AsObject[xmlattributes] := anobject; + end; + anobject.AsObject[FStr.Data] := TSuperObject.Create(Fvalue.Data); + end; + FStack^.savedstate := xsAttributes; + FStack^.state := xsEatSpaces; + end else + case c of + '&': + begin + FStack^.state := xsEscape; + FStack^.savedstate := xsAttributeValue; + end; + #13, #10: + begin + FValue.TrimRight; + FValue.Append(XML_SPACE, 1); + FStack^.state := xsEatSpaces; + FStack^.savedstate := xsAttributeValue; + end; + else + FValue.Append(@c, 1); + end; + + end else + begin + if (c < #256) and (AnsiChar(c) in ['"', '''']) then + begin + FAChar := c; + inc(FPosition); + + end else + goto err; + end; + end; + xsElementString: + begin + case c of + '<': begin + FValue.TrimRight; + putchildrenstr; + FStack^.state := xsTryCloseElement; + end; + #13, #10: + begin + FValue.TrimRight; + FValue.Append(XML_SPACE, 1); + FStack^.state := xsEatSpaces; + FStack^.savedstate := xsElementString; + end; + '&': + begin + FStack^.state := xsEscape; + FStack^.savedstate := xsElementString; + end + else + FValue.Append(@c, 1); + end; + end; + xsElementComment: + begin + case FPosition of + 0: + begin + case c of + '-': Inc(FPosition); + '[': + begin + FValue.Reset; + FPosition := 0; + FStack^.state := xsElementCDATA; + FStack^.clazz := xcCdata; + end; + 'D': + begin + if (FStack^.prev = nil) and (FDocType = nil) then + begin + FStack^.state := xsElementDocType; + FPosition := 0; + FStack^.clazz := xcDocType; + end else + goto err; + end; + else + goto err; + end; + end; + 1: + begin + if c <> '-' then goto err; + Inc(FPosition); + end; + else + if c = '-' then + begin + FPosition := 0; + FStack^.state := xsCloseElementComment; + end; + end; + end; + xsCloseElementComment: + begin + case FPosition of + 0: begin + if c <> '-' then + begin + FPosition := 2; + FStack^.state := xsElementComment; + end else + Inc(FPosition); + end; + 1: begin + if c <> '>' then goto err; + FStack^.state := xsEatSpaces; + if FStack^.obj <> nil then + FStack^.savedstate := xsChildren else + FStack^.savedstate := xsStart; + end; + end; + end; + xsElementCDATA: + begin + case FPosition of + 0: if (c = 'C') then inc(FPosition) else goto err; + 1: if (c = 'D') then inc(FPosition) else goto err; + 2: if (c = 'A') then inc(FPosition) else goto err; + 3: if (c = 'T') then inc(FPosition) else goto err; + 4: if (c = 'A') then inc(FPosition) else goto err; + 5: if (c = '[') then inc(FPosition) else goto err; + else + case c of + ']': begin + FPosition := 0; + FStack^.state := xsClodeElementCDATA; + end; + else + FValue.Append(@c, 1); + end; + end; + end; + xsClodeElementCDATA: + begin + case FPosition of + 0: if (c = ']') then + inc(FPosition) else + begin + FValue.Append(XML_ARR, 1); + FValue.Append(@c, 1); + FPosition := 6; + FStack^.state := xsElementCDATA; + end; + 1: case c of + '>': + begin + putchildrenstr; + FStack^.state := xsEatSpaces; + FStack^.savedstate := xsChildren; + end; + ']': + begin + FValue.Append(@c, 1); + end; + else + FValue.Append(@c, 1); + FStack^.state := xsElementCDATA; + end; + end; + end; + xsElementDocType: + begin + case FPosition of + 0: if (c = 'O') then inc(FPosition) else goto err; + 1: if (c = 'C') then inc(FPosition) else goto err; + 2: if (c = 'T') then inc(FPosition) else goto err; + 3: if (c = 'Y') then inc(FPosition) else goto err; + 4: if (c = 'P') then inc(FPosition) else goto err; + 5: if (c = 'E') then inc(FPosition) else goto err; + else + if (c < #256) and (AnsiChar(c) in spaces) then + begin + FStack^.state := xsEatSpaces; + FStack^.savedstate := xsElementDocTypeName; + FStr.Reset; + end else + goto err; + end; + end; + xsElementDocTypeName: + begin + case FStr.Position of + 0: begin + case c of + '>': + begin + FStack^.state := xsEatSpaces; + FStack^.state := xsStart; + FStack^.clazz := xcNone; + end + else + if ((c < #256) and (AnsiChar(c) in alphas)) or (c > #256) then + FStr.Append(@c, 1) else + goto err; + end; + end; + else + if ((c < #256) and (AnsiChar(c) in alphanums)) or (c > #256) then + FStr.Append(@c, 1) else + if (c < #256) and (AnsiChar(c) in spaces) then + begin + FDocType := TSuperObject.Create(stObject); + FDocType.AsObject.S[xmlname] := FStr.Data; + FStack^.state := xsEatSpaces; + FStack^.savedstate := xsElementDocTypeExternId; + end else + goto err; + end; + end; + xsElementDocTypeExternId: + begin + case c of + 'P': + begin + FPosition := 0; + FStack^.state := xsElementDocTypeExternIdPublic; + end; + 'S': + begin + FPosition := 0; + FStack^.state := xsElementDocTypeExternIdSystem; + end; + '[': + begin + FStack^.savedstate := xsElementDocTypeIntSubset; + FStack^.state := xsEatSpaces; + end; + '>': + begin + FStack^.savedstate := xsStart; + FStack^.state := xsEatSpaces + end + else + goto err; + end; + end; + xsElementDocTypeExternIdPublic: + begin + case FPosition of + 0: if (c = 'U') then inc(FPosition) else goto err; + 1: if (c = 'B') then inc(FPosition) else goto err; + 2: if (c = 'L') then inc(FPosition) else goto err; + 3: if (c = 'I') then inc(FPosition) else goto err; + 4: if (c = 'C') then inc(FPosition) else goto err; + else + if (c < #256) and (AnsiChar(c) in spaces) then + begin + FStr.Reset; + FPosition := 0; + FStack^.savedstate := xsElementDocTypePubIdLiteral; + FStack^.state := xsEatSpaces; + end else + goto err; + end; + end; + + xsElementDocTypeExternIdSystem: + begin + case FPosition of + 0: if (c = 'Y') then inc(FPosition) else goto err; + 1: if (c = 'S') then inc(FPosition) else goto err; + 2: if (c = 'T') then inc(FPosition) else goto err; + 3: if (c = 'E') then inc(FPosition) else goto err; + 4: if (c = 'M') then inc(FPosition) else goto err; + else + if (c < #256) and (AnsiChar(c) in spaces) then + begin + FStr.Reset; + FPosition := 0; + FStack^.savedstate := xsElementDocTypeSystemLiteral; + FStack^.state := xsEatSpaces; + end else + goto err; + end; + end; + xsElementDocTypePubIdLiteral: + begin + if FPosition = 0 then + case c of + '"', '''': + begin + FAChar := c; + FPosition := 1; + end + else + goto err; + end else + if c = FAChar then + begin + FDocType.AsObject.S[dtdPubidLiteral] := FStr.Data; + FStr.Reset; + FPosition := 0; + FStack^.state := xsEatSpaces; + FStack^.savedstate := xsElementDocTypeSystemLiteral; + end else + if (c < #256) and (AnsiChar(c) in publitteral) then + FStr.Append(@c, 1); + end; + xsElementDocTypeSystemLiteral: + begin + if FPosition = 0 then + case c of + '"', '''': + begin + FAChar := c; + FPosition := 1; + end + else + goto err; + end else + if c = FAChar then + begin + FDocType.AsObject.S[dtdSystemLiteral] := FStr.Data; + FStack^.state := xsEatSpaces; + FStack^.savedstate := xsElementDocTypeTryIntSubset; + end else + FStr.Append(@c, 1); + end; + + xsElementDocTypeTryIntSubset: + begin + case c of + '>': + begin + FStack^.state := xsEatSpaces; + FStack^.savedstate := xsStart; + FStack^.clazz := xcNone; + end; + '[': + begin + FStack^.state := xsEatSpaces; + FStack^.savedstate := xsElementDocTypeIntSubset; + end; + end; + end; + xsElementDocTypeIntSubset: + begin + case c of + ']': + begin + FStack^.state := xsEatSpaces; + FStack^.savedstate := xsElementDocTypeTryClose; + end; + end; + end; + xsElementDocTypeTryClose: + begin + if c = '>' then + begin + FStack^.state := xsEatSpaces; + FStack^.savedstate := xsStart; + FStack^.clazz := xcNone; + end else + goto err; + end; + xsEscape: + begin + FPosition := 0; + case c of + 'l': FStack^.state := xsEscape_lt; + 'g': FStack^.state := xsEscape_gt; + 'a': FStack^.state := xsEscape_amp; + 'q': FStack^.state := xsEscape_quot; + '#': FStack^.state := xsEscape_char; + else + goto err; + end; + end; + xsEscape_lt: + begin + case FPosition of + 0: begin + if c <> 't' then goto err; + Inc(FPosition); + end; + 1: begin + if c <> ';' then goto err; + FValue.Append(XML_LOW, 1); + FStack^.state := FStack^.savedstate; + end; + end; + end; + xsEscape_gt: + begin + case FPosition of + 0: begin + if c <> 't' then goto err; + Inc(FPosition); + end; + 1: begin + if c <> ';' then goto err; + FValue.Append(XML_BIG, 1); + FStack^.state := FStack^.savedstate; + end; + end; + end; + xsEscape_amp: + begin + case FPosition of + 0: begin + case c of + 'm': Inc(FPosition); + 'p': begin + FStack^.state := xsEscape_apos; + Inc(FPosition); + end; + else + goto err; + end; + end; + 1: begin + if c <> 'p' then goto err; + Inc(FPosition); + end; + 2: begin + if c <> ';' then goto err; + FValue.Append(XML_AMP, 1); + FStack^.state := FStack^.savedstate; + end; + end; + end; + xsEscape_apos: + begin + case FPosition of + 0: begin + case c of + 'p': Inc(FPosition); + 'm': begin + FStack^.state := xsEscape_amp; + Inc(FPosition); + end; + else + goto err; + end; + end; + 1: begin + if c <> 'o' then goto err; + Inc(FPosition); + end; + 2: begin + if c <> 's' then goto err; + Inc(FPosition); + end; + 3: begin + if c <> ';' then goto err; + FValue.Append(XML_SQU, 1); + FStack^.state := FStack^.savedstate; + end; + end; + end; + xsEscape_quot: + begin + case FPosition of + 0: begin + if c <> 'u' then goto err; + Inc(FPosition); + end; + 1: begin + if c <> 'o' then goto err; + Inc(FPosition); + end; + 2: begin + if c <> 't' then goto err; + Inc(FPosition); + end; + 3: begin + if c <> ';' then goto err; + FValue.Append(XML_DQU, 1); + FStack^.state := FStack^.savedstate; + end; + end; + end; + xsEscape_char: + begin + if (SOIChar(c) >= 256) then goto err; + case AnsiChar(c) of + '0'..'9': + begin + FPosition := SOIChar(c) - 48; + FStack^.state := xsEscape_char_num; + end; + 'x': + begin + FStack^.state := xsEscape_char_hex; + end + else + goto err; + end; + end; + xsEscape_char_num: + begin + if (SOIChar(c) >= 256) then goto err; + case AnsiChar(c) of + '0'..'9':FPosition := (FPosition * 10) + (SOIChar(c) - 48); + ';': begin + FValue.Append(@FPosition, 1); + FStack^.state := FStack^.savedstate; + end; + else + goto err; + end; + end; + xsEscape_char_hex: + begin + if (c >= #256) then goto err; + if (AnsiChar(c) in hex) then + begin + FPosition := (FPosition * 16) + SOIChar(hexdigit(c)); + end else + if c = ';' then + begin + FValue.Append(@FPosition, 1); + FStack^.state := FStack^.savedstate; + end else + goto err; + end; + xsEnd: + begin + if(FStack^.prev = nil) then Break; + if FStack^.obj <> nil then + begin + if FPack then + packend else + begin + anobject := FStack^.prev^.obj.AsObject[xmlchildren]; + if anobject = nil then + begin + anobject := TSuperObject.Create(stArray); + FStack^.prev^.obj.AsObject[xmlchildren] := anobject; + end; + anobject.AsArray.Add(FStack^.obj); + end; + end; + StackDown; + goto redo; + end; + end; + inc(p); + inc(read); + until (c = #0); + + if FStack^.state = xsEnd then + begin + if FPack then + packend; + FError := xeSuccess; + end else + FError := xeError; + Result := read; + exit; +err: + FError := xeError; + Result := read; +end; + +function XMLParseFile(const FileName: string; pack: Boolean; onpi: TOnProcessingInstruction): ISuperObject; +var + stream: TFileStream; +begin + stream := TFileStream.Create(FileName, fmOpenRead, fmShareDenyWrite); + try + Result := XMLParseStream(stream, pack, onpi); + finally + stream.Free; + end; +end; + +procedure TSuperXMLParser.StackDown; +var + prev: PSuperXMLStack; +begin + if FStack <> nil then + begin + prev := FStack^.prev; + FStack^.obj := nil; + FreeMem(FStack); + FStack := prev; + if FStack <> nil then + FStack^.next := nil; + end; +end; + +procedure TSuperXMLParser.StackUp; +var + st: PSuperXMLStack; +begin +{$IFDEF FPC} + st := nil; +{$ENDIF} + GetMem(st, SizeOf(st^)); + FillChar(st^, SizeOf(st^), 0); + st^.state := xsEatSpaces; + st^.savedstate := xsStart; + st^.prev := FStack; + if st^.prev <> nil then + st^.prev^.next := st; + st^.next := nil; + st^.obj := nil; + FStack := st; +end; + +function utf8toucs2(src: PAnsiChar; srclen: Integer; dst: PWideChar; unused: PInteger): Integer; +var + ch: Byte; + ret: Word; + min: Cardinal; + rem, com: integer; +label + redo; +begin + Result := 0; + ret := 0; + rem := 0; + min := 0; + + if unused <> nil then + unused^ := 0; + + if(src = nil) or (srclen = 0) then + begin + dst^ := #0; + Exit; + end; + + while srclen > 0 do + begin + ch := Byte(src^); + inc(src); + dec(srclen); + +redo: + if (ch and $80) = 0 then + begin + dst^ := WideChar(ch); + inc(Result); + end else + begin + if((ch and $E0) = $C0) then + begin + min := $80; + rem := 1; + ret := ch and $1F; + end else + if((ch and $F0) = $E0) then + begin + min := $800; + rem := 2; + ret := ch and $0F; + end else + // too large utf8 bloc + // ignore and continue + continue; + + com := rem; + while(rem <> 0) do + begin + dec(rem); + if(srclen = 0) then + begin + if unused <> nil then + unused^ := com; + Exit; + end; + ch := Byte(src^); + inc(src); + dec(srclen); + if((ch and $C0) = $80) then + begin + ret := ret shl 6; + ret := ret or (ch and $3F); + end else + begin + // unterminated utf8 bloc :/ + // try next one + goto redo; + end; + end; + + if (ch >= min) then + begin + dst^ := WideChar(ret); + inc(Result); + end else + begin + // too small utf8 bloc + // ignore and continue + Continue; + end; + + end; + inc(dst); + end; +end; + +function XMLParseStream(stream: TStream; pack: Boolean; onpi: TOnProcessingInstruction): ISuperObject; +const + CP_UTF8 = 65001; +var + wbuffer: array[0..1023] of SOChar; + abuffer: array[0..1023] of AnsiChar; + len, read, cursor: Integer; + PI, PIParent: ISuperObject; + bom: array[0..2] of byte; + + encoding: TSuperXMLEncoding; + encodingstr: string; + cp: Integer; + ecp: ISuperObject; + + function getbuffer: Integer; + var + size, unusued: Integer; + begin + + case encoding of +{$IFNDEF UNIX} + xnANSI: + begin + size := stream.Read(abuffer, sizeof(abuffer)); + result := MultiByteToWideChar(cp, 0, @abuffer, size, @wbuffer, sizeof(wbuffer)); + end; +{$ENDIF} + xnUTF8: + begin + size := stream.Read(abuffer, sizeof(abuffer)); + result := utf8toucs2(@abuffer, size, @wbuffer, @unusued); + if unusued > 0 then + stream.Seek(-unusued, soFromCurrent); + end; + xnUnicode: Result := stream.Read(wbuffer, sizeof(wbuffer)) div sizeof(SOChar); + else + Result := 0; + end; + end; +label + redo, retry; +begin + // init knowned code pages + ecp := so('{iso-8859-1: 28591,'+ + 'iso-8859-2: 28592,'+ + 'iso-8859-3: 28593,'+ + 'iso-8859-4: 28594,'+ + 'iso-8859-5: 28595,'+ + 'iso-8859-6: 28596,'+ + 'iso-8859-7: 28597,'+ + 'iso-8859-8: 28598,'+ + 'iso-8859-9: 28599,'+ + 'iso 8859-15: 28605,'+ + 'iso-2022-jp: 50220,'+ + 'shift_jis: 932,'+ + 'euc-jp: 20932,'+ + 'ascii: 20127,'+ + 'windows-1251: 1251,'+ + 'windows-1252: 1252}'); + + // detect bom + stream.Seek(0, soFromBeginning); + len := stream.Read(bom, sizeof(bom)); + if (len >= 2) and (bom[0] = $FF) and (bom[1] = $FE) then + begin + encoding := xnUnicode; + stream.Seek(2, soFromBeginning); + end else + if (len = 3) and (bom[0] = $EF) and (bom[1] = $BB) and (bom[2] = $BF) then + begin + encoding := xnUTF8; + cp := CP_UTF8; + end else + begin + encoding := xnUTF8; + cp := 0; + stream.Seek(0, soFromBeginning); + end; + + with TSuperXMLParser.Create(pack) do + try + len := getbuffer; + while len > 0 do + begin +retry: + read := ParseBuffer(@wbuffer, PI, PIParent, len); + cursor := 0; +redo: + case FError of + xeContinue: len := getbuffer; + xeSuccess, xeError: Break; + xeProcessInst: + begin + if (PIParent = nil) and (PI.AsObject.S[xmlname] = 'xml') then + begin + if pack then + encodingstr := LowerCase(trim(PI.S['encoding'])) else + encodingstr := LowerCase(trim(PI.S[xmlattributes + '.encoding'])); + if (encodingstr <> '') then + case encoding of + xnUTF8: if(cp = CP_UTF8) then + begin + if (encodingstr <> 'utf-8') then + begin + FError := xeError; + Break; + end; + end else + begin + cp := ecp.I[encodingstr]; + if cp > 0 then + begin +{$IFNDEF UNIX} + encoding := xnANSI; + Reset; + stream.Seek(0, soFromBeginning); + len := getbuffer; + goto retry; +{$ELSE} + raise Exception.Create('charset not implemented'); +{$ENDIF} + end; + end; + xnUnicode: + if (encodingstr <> 'utf-16') and (encodingstr <> 'unicode') then + begin + FError := xeError; + Break; + end; + end; + end else + if Assigned(onpi) then + onpi(PI, PIParent); + + inc(cursor, read); + if cursor >= len then + begin + len := getbuffer; + continue; + end; + read := ParseBuffer(@wbuffer[cursor], PI, PIParent, len - cursor); + goto redo; + end; + end; + end; + if FError = xeSuccess then + Result := FStack^.obj else + Result := nil; + finally + Free; + end; +end; + +function XMLParseString(const data: SOString; pack: Boolean; onpi: TOnProcessingInstruction): ISuperObject; +var + PI, PIParent: ISuperObject; + cursor, read: Integer; +label + redo; +begin + with TSuperXMLParser.Create(pack) do + try + cursor := 0; + read := ParseBuffer(PSOChar(data), PI, PIParent); +redo: + case FError of + xeSuccess: Result := FStack^.obj; + xeError: Result := nil; + xeProcessInst: + begin + if Assigned(onpi) then + onpi(PI, PIParent); + inc(cursor, read); + read := ParseBuffer(@data[cursor+1], PI, PIParent); + goto redo; + end; + end; + finally + Free; + end; +end; + +end. diff --git a/uROIndyHTTPWebsocketChannel.pas b/uROIndyHTTPWebsocketChannel.pas index 59e6ac8..a9debf2 100644 --- a/uROIndyHTTPWebsocketChannel.pas +++ b/uROIndyHTTPWebsocketChannel.pas @@ -405,6 +405,7 @@ procedure TROIndyHTTPSocketIOClient.AsyncDispatchEvent(const aEvent: TStream); var iEventNr: Integer; cWSNR: array[0..High(C_RO_WS_NR)] of AnsiChar; + s: string; begin if aEvent.Size > Length(C_RO_WS_NR) + SizeOf(iEventNr) then begin @@ -415,7 +416,16 @@ begin if cWSNR = C_RO_WS_NR then begin aEvent.Read(iEventNr, SizeOf(iEventNr)); - Assert(iEventNr < 0, 'must be negative number for RO events'); + if iEventNr >= 0 then + begin + aEvent.Position := 0; + with TStreamReader.Create(aEvent) do + begin + s := ReadToEnd; + Free; + end; + Assert(iEventNr < 0, 'must be negative number for RO events: ' + s); + end; //trunc aEvent.Size := aEvent.Size - Length(C_RO_WS_NR) - SizeOf(iEventNr);