diff --git a/Examples/1.HelloWorld/FMXCli/FMXClient.dproj b/Examples/1.HelloWorld/FMXCli/FMXClient.dproj index 37d5299b..fd8c24e2 100644 --- a/Examples/1.HelloWorld/FMXCli/FMXClient.dproj +++ b/Examples/1.HelloWorld/FMXCli/FMXClient.dproj @@ -575,21 +575,19 @@ true - - - Default-736h@3x.png + + true - - - FMXClient + + true - - - ic_launcher.png + + + Default-736h@3x.png true @@ -598,8 +596,9 @@ true - - + + + FMXClient true @@ -636,8 +635,9 @@ true - - + + + ic_launcher.png true diff --git a/Examples/11.ZDBDemo_SmallJson/FMXBatchDataClient/FMXBatchDataClient.dproj b/Examples/11.ZDBDemo_SmallJson/FMXBatchDataClient/FMXBatchDataClient.dproj index 767aa36b..289638d8 100644 --- a/Examples/11.ZDBDemo_SmallJson/FMXBatchDataClient/FMXBatchDataClient.dproj +++ b/Examples/11.ZDBDemo_SmallJson/FMXBatchDataClient/FMXBatchDataClient.dproj @@ -378,7 +378,7 @@ true - + true @@ -393,9 +393,9 @@ true - - - FMXBatchDataClient + + + FMXBatchDataClient.exe true @@ -459,6 +459,11 @@ true + + + true + + Default-Portrait@2x.png @@ -475,11 +480,6 @@ true - - - true - - Default.png @@ -611,14 +611,14 @@ true - + true - - - FMXBatchDataClient.exe + + + FMXBatchDataClient true diff --git a/Examples/12.ZDBDemo_PictureAndSmallJson/FMXBatchDataClient/FMXBatchPictureDataClient.dproj b/Examples/12.ZDBDemo_PictureAndSmallJson/FMXBatchDataClient/FMXBatchPictureDataClient.dproj index ead5abed..79116150 100644 --- a/Examples/12.ZDBDemo_PictureAndSmallJson/FMXBatchDataClient/FMXBatchPictureDataClient.dproj +++ b/Examples/12.ZDBDemo_PictureAndSmallJson/FMXBatchDataClient/FMXBatchPictureDataClient.dproj @@ -387,9 +387,8 @@ true - + - Default-Landscape@2x.png true @@ -403,15 +402,13 @@ true - + - Info.plist true - + - FMXBatchPictureDataClient true @@ -480,12 +477,12 @@ true - + true - + true @@ -584,50 +581,53 @@ true - + + Default-Landscape@2x.png true - - + + true - - + + true - + - Default-Portrait@2x~ipad.png + FMXBatchPictureDataClient true - + true - + - Default-736h@3x.png + Default-Portrait@2x~ipad.png true - + true - + + Info.plist true - + + Default-736h@3x.png true diff --git a/Examples/14.DM/DMDemo.dpr b/Examples/14.DM/DMDemo.dpr deleted file mode 100644 index c53c7a4c..00000000 --- a/Examples/14.DM/DMDemo.dpr +++ /dev/null @@ -1,19 +0,0 @@ -program DMDemo; - -uses - System.StartUpCopy, - FMX.Forms, - DMDemoFrm in 'DMDemoFrm.pas' {DMDemoForm}, - UserDataModuleUnit in 'UserDataModuleUnit.pas', - NumberBase in '..\..\Source\NumberBase.pas'; - -{$R *.res} - - -begin - System.ReportMemoryLeaksOnShutdown := True; - Application.Initialize; - Application.CreateForm(TDMDemoForm, DMDemoForm); - Application.Run; - -end. diff --git a/Examples/14.DM/DMDemo.dproj b/Examples/14.DM/DMDemo.dproj deleted file mode 100644 index cbe15dca..00000000 --- a/Examples/14.DM/DMDemo.dproj +++ /dev/null @@ -1,1478 +0,0 @@ - - - {911765D4-0C2E-4D12-AB7C-84B2991CEB03} - 19.2 - FMX - DMDemo.dpr - True - Release - Win32 - 37915 - Application - - - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Cfg_1 - true - true - - - true - Cfg_1 - true - true - - - true - Base - true - - - true - Cfg_2 - true - true - - - true - Cfg_2 - true - true - - - true - Cfg_2 - true - true - - - true - Cfg_2 - true - true - - - true - $(BDS)\bin\delphi_PROJECTICNS.icns - true - $(BDS)\bin\delphi_PROJECTICON.ico - System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) - DMDemo - true - true - true - true - true - true - true - true - .\$(Platform)\$(Config) - .\$(Platform)\$(Config) - false - false - false - false - false - - - $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png - $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png - $(BDS)\bin\Artwork\Android\FM_SplashImage_426x320.png - $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png - $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png - $(BDS)\bin\Artwork\Android\FM_SplashImage_960x720.png - $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png - package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=auto;largeHeap=False;theme=TitleBar;hardwareAccelerated=true;apiKey= - true - $(BDS)\bin\Artwork\Android\FM_SplashImage_470x320.png - Debug - $(BDS)\bin\Artwork\Android\FM_SplashImage_640x480.png - android-support-v4.dex.jar;cloud-messaging.dex.jar;fmx.dex.jar;google-analytics-v2.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar;google-play-services.dex.jar - DBXSqliteDriver;RESTComponents;DBXInterBaseDriver;emsclientfiredac;DataSnapFireDAC;tethering;bindcompfmx;FmxTeeUI;FireDACIBDriver;fmx;FireDACDBXDriver;dbexpress;IndyCore;dsnap;DataSnapCommon;emsclient;FireDACCommon;RESTBackendComponents;soapserver;bindengine;CloudService;FireDACCommonDriver;DataSnapClient;inet;bindcompdbx;IndyIPCommon;IndyIPServer;IndySystem;fmxFireDAC;FireDAC;FireDACSqliteDriver;ibmonitor;FMXTee;soaprtl;DbxCommonDriver;ibxpress;xmlrtl;soapmidas;DataSnapNativeClient;ibxbindings;rtl;FireDACDSDriver;DbxClientDriver;CustomIPTransport;bindcomp;IndyIPClient;dbxcds;dsnapxml;DataSnapProviderClient;dbrtl;IndyProtocols;$(DCC_UsePackage) - $(BDS)\bin\Artwork\Android\FM_NotificationIcon_24x24.png - $(BDS)\bin\Artwork\Android\FM_NotificationIcon_36x36.png - $(BDS)\bin\Artwork\Android\FM_NotificationIcon_48x48.png - $(BDS)\bin\Artwork\Android\FM_NotificationIcon_72x72.png - $(BDS)\bin\Artwork\Android\FM_NotificationIcon_96x96.png - $(BDS)\bin\Artwork\Android\FM_LauncherIcon_192x192.png - - - package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=auto;largeHeap=False;theme=TitleBar;hardwareAccelerated=true;apiKey= - Debug - true - true - Base - true - $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png - $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png - $(BDS)\bin\Artwork\Android\FM_SplashImage_426x320.png - $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png - $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png - $(BDS)\bin\Artwork\Android\FM_SplashImage_960x720.png - $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png - $(BDS)\bin\Artwork\Android\FM_SplashImage_470x320.png - $(BDS)\bin\Artwork\Android\FM_SplashImage_640x480.png - android-support-v4.dex.jar;cloud-messaging.dex.jar;fmx.dex.jar;google-analytics-v2.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar;google-play-services.dex.jar - DBXSqliteDriver;RESTComponents;DBXInterBaseDriver;emsclientfiredac;DataSnapFireDAC;tethering;bindcompfmx;FmxTeeUI;FireDACIBDriver;fmx;FireDACDBXDriver;dbexpress;IndyCore;dsnap;DataSnapCommon;emsclient;FireDACCommon;RESTBackendComponents;soapserver;bindengine;CloudService;FireDACCommonDriver;DataSnapClient;inet;bindcompdbx;IndyIPCommon;IndyIPServer;IndySystem;fmxFireDAC;FireDAC;FireDACSqliteDriver;ibmonitor;FMXTee;soaprtl;DbxCommonDriver;ibxpress;xmlrtl;soapmidas;DataSnapNativeClient;ibxbindings;rtl;FireDACDSDriver;DbxClientDriver;CustomIPTransport;bindcomp;IndyIPClient;dbxcds;dsnapxml;DataSnapProviderClient;dbrtl;IndyProtocols;$(DCC_UsePackage);$(DCC_UsePackage) - $(BDS)\bin\Artwork\Android\FM_NotificationIcon_24x24.png - $(BDS)\bin\Artwork\Android\FM_NotificationIcon_36x36.png - $(BDS)\bin\Artwork\Android\FM_NotificationIcon_48x48.png - $(BDS)\bin\Artwork\Android\FM_NotificationIcon_72x72.png - $(BDS)\bin\Artwork\Android\FM_NotificationIcon_96x96.png - $(BDS)\bin\Artwork\Android\FM_LauncherIcon_192x192.png - - - $(MSBuildProjectName) - $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png - $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_180x180.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png - $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png - iPhoneAndiPad - true - DBXSqliteDriver;RESTComponents;DBXInterBaseDriver;emsclientfiredac;DataSnapFireDAC;tethering;bindcompfmx;FmxTeeUI;FireDACIBDriver;fmx;FireDACDBXDriver;dbexpress;IndyCore;dsnap;DataSnapCommon;emsclient;FireDACCommon;RESTBackendComponents;soapserver;bindengine;CloudService;FireDACCommonDriver;DataSnapClient;inet;bindcompdbx;IndyIPCommon;IndyIPServer;IndySystem;fmxFireDAC;FireDAC;FireDACSqliteDriver;ibmonitor;FMXTee;soaprtl;DbxCommonDriver;ibxpress;xmlrtl;soapmidas;DataSnapNativeClient;ibxbindings;rtl;FireDACDSDriver;DbxClientDriver;CustomIPTransport;bindcomp;IndyIPClient;dbxcds;dsnapxml;DataSnapProviderClient;dbrtl;IndyProtocols;fmxase;$(DCC_UsePackage) - CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=7.1;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;NSLocationAlwaysUsageDescription=The reason for accessing the location information of the user;NSLocationWhenInUseUsageDescription=The reason for accessing the location information of the user;UIBackgroundModes=;NSContactsUsageDescription=The reason for accessing the contacts;NSPhotoLibraryUsageDescription=The reason for accessing the photo library;NSCameraUsageDescription=The reason for accessing the camera;CFBundleShortVersionString=1.0.0;NSPhotoLibraryAddUsageDescription=The reason for adding to the photo library;NSFaceIDUsageDescription=The reason for accessing the face id;NSLocationAlwaysAndWhenInUseUsageDescription=The reason for accessing the location information of the user;NSMicrophoneUsageDescription=The reason for accessing the microphone;NSSiriUsageDescription=The reason for accessing Siri;ITSAppUsesNonExemptEncryption=false;NSBluetoothAlwaysUsageDescription=The reason for accessing bluetooth;NSBluetoothPeripheralUsageDescription=The reason for accessing bluetooth peripherals;NSCalendarsUsageDescription=The reason for accessing the calendar data;NSRemindersUsageDescription=The reason for accessing the reminders;NSMotionUsageDescription=The reason for accessing the accelerometer;NSSpeechRecognitionUsageDescription=The reason for requesting to send user data to Apple's speech recognition servers - Debug - $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_120x120.png - $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_83.5x83.5.png - $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_167x167.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_2x.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImageDark_2x.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_3x.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImageDark_3x.png - $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImage_2x.png - $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageDark_2x.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_1024x1024.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_NotificationIcon_60x60.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_SettingIcon_87x87.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_NotificationIcon_40x40.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_SettingIcon_58x58.png - $(BDS)\bin\Artwork\iOS\iPad\FM_NotificationIcon_40x40.png - - - $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png - $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png - $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_180x180.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png - $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png - iPhoneAndiPad - true - DBXSqliteDriver;RESTComponents;DBXInterBaseDriver;emsclientfiredac;DataSnapFireDAC;tethering;bindcompfmx;FmxTeeUI;FireDACIBDriver;fmx;FireDACDBXDriver;dbexpress;IndyCore;dsnap;DataSnapCommon;emsclient;FireDACCommon;RESTBackendComponents;soapserver;bindengine;CloudService;FireDACCommonDriver;DataSnapClient;inet;bindcompdbx;IndyIPCommon;IndyIPServer;IndySystem;fmxFireDAC;FireDAC;FireDACSqliteDriver;ibmonitor;FMXTee;soaprtl;DbxCommonDriver;ibxpress;xmlrtl;soapmidas;DataSnapNativeClient;ibxbindings;rtl;FireDACDSDriver;DbxClientDriver;CustomIPTransport;bindcomp;IndyIPClient;dbxcds;dsnapxml;DataSnapProviderClient;dbrtl;IndyProtocols;fmxase;$(DCC_UsePackage) - CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=7.1;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;NSLocationAlwaysUsageDescription=The reason for accessing the location information of the user;NSLocationWhenInUseUsageDescription=The reason for accessing the location information of the user;UIBackgroundModes=;NSContactsUsageDescription=The reason for accessing the contacts;NSPhotoLibraryUsageDescription=The reason for accessing the photo library;NSCameraUsageDescription=The reason for accessing the camera;CFBundleShortVersionString=1.0.0;NSPhotoLibraryAddUsageDescription=The reason for adding to the photo library;NSFaceIDUsageDescription=The reason for accessing the face id;NSLocationAlwaysAndWhenInUseUsageDescription=The reason for accessing the location information of the user;NSMicrophoneUsageDescription=The reason for accessing the microphone;NSSiriUsageDescription=The reason for accessing Siri;ITSAppUsesNonExemptEncryption=false;NSBluetoothAlwaysUsageDescription=The reason for accessing bluetooth;NSBluetoothPeripheralUsageDescription=The reason for accessing bluetooth peripherals;NSCalendarsUsageDescription=The reason for accessing the calendar data;NSRemindersUsageDescription=The reason for accessing the reminders;NSMotionUsageDescription=The reason for accessing the accelerometer;NSSpeechRecognitionUsageDescription=The reason for requesting to send user data to Apple's speech recognition servers - $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_120x120.png - $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_83.5x83.5.png - $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_167x167.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_2x.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImageDark_2x.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_3x.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImageDark_3x.png - $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImage_2x.png - $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageDark_2x.png - 10.0 - $(BDS)\bin\Artwork\iOS\iPhone\FM_NotificationIcon_60x60.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_SettingIcon_87x87.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_NotificationIcon_40x40.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_SettingIcon_58x58.png - $(BDS)\bin\Artwork\iOS\iPad\FM_NotificationIcon_40x40.png - - - CFBundleName=$(MSBuildProjectName);CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleVersion=1.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);NSHighResolutionCapable=true;LSApplicationCategoryType=public.app-category.utilities;NSContactsUsageDescription=The reason for accessing the contacts;CFBundleShortVersionString=1.0.0;NSLocationUsageDescription=The reason for accessing the location information of the user;NSCalendarsUsageDescription=The reason for accessing the calendar data;NSRemindersUsageDescription=The reason for accessing the reminders;NSCameraUsageDescription=The reason for accessing the camera;NSMicrophoneUsageDescription=The reason for accessing the microphone;NSMotionUsageDescription=The reason for accessing the accelerometer;NSDesktopFolderUsageDescription=The reason for accessing the Desktop folder;NSDocumentsFolderUsageDescription=The reason for accessing the Documents folder;NSDownloadsFolderUsageDescription=The reason for accessing the Downloads folder;NSNetworkVolumesUsageDescription=The reason for accessing files on a network volume;NSRemovableVolumesUsageDescription=The reason for accessing files on a removable volume;NSSpeechRecognitionUsageDescription=The reason for requesting to send user data to Apple's speech recognition servers - Debug - true - true - Base - true - DBXSqliteDriver;RESTComponents;DataSnapServerMidas;DBXInterBaseDriver;emsclientfiredac;DataSnapFireDAC;tethering;FireDACMSSQLDriver;bindcompfmx;DBXOracleDriver;inetdb;FmxTeeUI;emsedge;FireDACIBDriver;fmx;fmxdae;FireDACDBXDriver;dbexpress;IndyCore;dsnap;DataSnapCommon;emsclient;FireDACCommon;RESTBackendComponents;soapserver;bindengine;DBXMySQLDriver;FireDACOracleDriver;CloudService;FireDACMySQLDriver;DBXFirebirdDriver;FireDACCommonODBC;FireDACCommonDriver;DataSnapClient;inet;bindcompdbx;IndyIPCommon;IndyIPServer;IndySystem;fmxFireDAC;FireDAC;emshosting;FireDACSqliteDriver;FireDACPgDriver;ibmonitor;FireDACASADriver;FireDACTDataDriver;FMXTee;soaprtl;DbxCommonDriver;ibxpress;DataSnapServer;xmlrtl;soapmidas;DataSnapNativeClient;fmxobj;ibxbindings;rtl;FireDACDSDriver;DbxClientDriver;DBXSybaseASADriver;CustomIPTransport;bindcomp;DBXInformixDriver;IndyIPClient;dbxcds;FireDACODBCDriver;DataSnapIndy10ServerTransport;dsnapxml;DataSnapProviderClient;dbrtl;inetdbxpress;FireDACMongoDBDriver;IndyProtocols;fmxase;$(DCC_UsePackage);$(DCC_UsePackage) - - - $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) - $(BDS)\bin\default_app.manifest - $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png - 1033 - CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= - true - DBXSqliteDriver;RESTComponents;DataSnapServerMidas;DBXDb2Driver;DBXInterBaseDriver;vclactnband;vclFireDAC;thundax.ai;emsclientfiredac;DataSnapFireDAC;svnui;tethering;FireDACADSDriver;DBXMSSQLDriver;DatasnapConnectorsFreePascal;FireDACMSSQLDriver;vcltouch;vcldb;bindcompfmx;svn;DBXOracleDriver;inetdb;FmxTeeUI;emsedge;FireDACIBDriver;fmx;fmxdae;frx24;vclib;FireDACDBXDriver;dbexpress;IndyCore;vclx;dsnap;DataSnapCommon;emsclient;FireDACCommon;RESTBackendComponents;DataSnapConnectors;VCLRESTComponents;soapserver;vclie;bindengine;DBXMySQLDriver;FireDACOracleDriver;CloudService;FireDACMySQLDriver;DBXFirebirdDriver;FireDACCommonODBC;FireDACCommonDriver;DataSnapClient;inet;bindcompdbx;IndyIPCommon;vcl;DBXSybaseASEDriver;IndyIPServer;IndySystem;FireDACDb2Driver;dsnapcon;FireDACMSAccDriver;fmxFireDAC;FireDACInfxDriver;vclimg;TeeDB;FireDAC;emshosting;FireDACSqliteDriver;FireDACPgDriver;ibmonitor;FireDACASADriver;DBXOdbcDriver;FireDACTDataDriver;FMXTee;soaprtl;DbxCommonDriver;ibxpress;Tee;DataSnapServer;xmlrtl;soapmidas;DataSnapNativeClient;fmxobj;vclwinx;ibxbindings;rtl;FireDACDSDriver;DbxClientDriver;SynEdit_RXE7;DBXSybaseASADriver;frxTee24;CustomIPTransport;vcldsnap;bindcomp;appanalytics;DBXInformixDriver;IndyIPClient;bindcompvcl;TeeUI;frxe24;dbxcds;VclSmp;adortl;FireDACODBCDriver;DataSnapIndy10ServerTransport;frxDB24;dsnapxml;DataSnapProviderClient;dbrtl;inetdbxpress;FireDACMongoDBDriver;IndyProtocols;fmxase;$(DCC_UsePackage) - Debug - - - $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) - $(BDS)\bin\default_app.manifest - $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png - 1033 - CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= - true - DBXSqliteDriver;RESTComponents;DataSnapServerMidas;DBXDb2Driver;DBXInterBaseDriver;vclactnband;vclFireDAC;emsclientfiredac;DataSnapFireDAC;tethering;FireDACADSDriver;DBXMSSQLDriver;DatasnapConnectorsFreePascal;FireDACMSSQLDriver;vcltouch;vcldb;bindcompfmx;DBXOracleDriver;inetdb;FmxTeeUI;emsedge;FireDACIBDriver;fmx;fmxdae;vclib;FireDACDBXDriver;dbexpress;IndyCore;vclx;dsnap;DataSnapCommon;emsclient;FireDACCommon;RESTBackendComponents;DataSnapConnectors;VCLRESTComponents;soapserver;vclie;bindengine;DBXMySQLDriver;FireDACOracleDriver;CloudService;FireDACMySQLDriver;DBXFirebirdDriver;FireDACCommonODBC;FireDACCommonDriver;DataSnapClient;inet;bindcompdbx;IndyIPCommon;vcl;DBXSybaseASEDriver;IndyIPServer;IndySystem;FireDACDb2Driver;dsnapcon;FireDACMSAccDriver;fmxFireDAC;FireDACInfxDriver;vclimg;TeeDB;FireDAC;emshosting;FireDACSqliteDriver;FireDACPgDriver;ibmonitor;FireDACASADriver;DBXOdbcDriver;FireDACTDataDriver;FMXTee;soaprtl;DbxCommonDriver;ibxpress;Tee;DataSnapServer;xmlrtl;soapmidas;DataSnapNativeClient;fmxobj;vclwinx;ibxbindings;rtl;FireDACDSDriver;DbxClientDriver;SynEdit_RXE7;DBXSybaseASADriver;CustomIPTransport;vcldsnap;bindcomp;appanalytics;DBXInformixDriver;IndyIPClient;bindcompvcl;TeeUI;dbxcds;VclSmp;adortl;FireDACODBCDriver;DataSnapIndy10ServerTransport;dsnapxml;DataSnapProviderClient;dbrtl;inetdbxpress;FireDACMongoDBDriver;IndyProtocols;fmxase;$(DCC_UsePackage) - Debug - - - DEBUG;$(DCC_Define) - true - false - true - true - true - - - true - false - true - 1033 - PerMonitor - - - true - PerMonitor - - - false - RELEASE;$(DCC_Define) - 0 - 0 - - - $(BDS)\bin\Artwork\iOS\iPhone\FM_NotificationIcon_60x60.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_SettingIcon_87x87.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_NotificationIcon_40x40.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_SettingIcon_58x58.png - $(BDS)\bin\Artwork\iOS\iPad\FM_NotificationIcon_40x40.png - - - $(BDS)\bin\Artwork\iOS\iPhone\FM_NotificationIcon_60x60.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_SettingIcon_87x87.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_NotificationIcon_40x40.png - $(BDS)\bin\Artwork\iOS\iPhone\FM_SettingIcon_58x58.png - $(BDS)\bin\Artwork\iOS\iPad\FM_NotificationIcon_40x40.png - - - true - PerMonitor - - - true - PerMonitor - - - - MainSource - - -
DMDemoForm
- fmx - - - - - Cfg_2 - Base - - - Base - - - Cfg_1 - Base - - - - Delphi.Personality.12 - Application - - - - DMDemo.dpr - - - Embarcadero Git Integration - Embarcadero C++Builder Office 2000 Servers Package - Embarcadero C++Builder Office XP Servers Package - Microsoft Office 2000 Sample Automation Server Wrapper Components - Microsoft Office XP Sample Automation Server Wrapper Components - - - - - - true - - - - - DMDemo.exe - true - - - - - true - - - - - true - - - - - true - - - - - true - - - - - true - - - - - 1 - - - Contents\MacOS - 1 - - - 0 - - - - - classes - 1 - - - classes - 1 - - - - - res\xml - 1 - - - res\xml - 1 - - - - - library\lib\armeabi-v7a - 1 - - - - - library\lib\armeabi - 1 - - - library\lib\armeabi - 1 - - - - - library\lib\armeabi-v7a - 1 - - - - - library\lib\mips - 1 - - - library\lib\mips - 1 - - - - - library\lib\armeabi-v7a - 1 - - - library\lib\arm64-v8a - 1 - - - - - library\lib\armeabi-v7a - 1 - - - - - res\drawable - 1 - - - res\drawable - 1 - - - - - res\values - 1 - - - res\values - 1 - - - - - res\values-v21 - 1 - - - res\values-v21 - 1 - - - - - res\values - 1 - - - res\values - 1 - - - - - res\drawable - 1 - - - res\drawable - 1 - - - - - res\drawable-xxhdpi - 1 - - - res\drawable-xxhdpi - 1 - - - - - res\drawable-xxxhdpi - 1 - - - res\drawable-xxxhdpi - 1 - - - - - res\drawable-ldpi - 1 - - - res\drawable-ldpi - 1 - - - - - res\drawable-mdpi - 1 - - - res\drawable-mdpi - 1 - - - - - res\drawable-hdpi - 1 - - - res\drawable-hdpi - 1 - - - - - res\drawable-xhdpi - 1 - - - res\drawable-xhdpi - 1 - - - - - res\drawable-mdpi - 1 - - - res\drawable-mdpi - 1 - - - - - res\drawable-hdpi - 1 - - - res\drawable-hdpi - 1 - - - - - res\drawable-xhdpi - 1 - - - res\drawable-xhdpi - 1 - - - - - res\drawable-xxhdpi - 1 - - - res\drawable-xxhdpi - 1 - - - - - res\drawable-xxxhdpi - 1 - - - res\drawable-xxxhdpi - 1 - - - - - res\drawable-small - 1 - - - res\drawable-small - 1 - - - - - res\drawable-normal - 1 - - - res\drawable-normal - 1 - - - - - res\drawable-large - 1 - - - res\drawable-large - 1 - - - - - res\drawable-xlarge - 1 - - - res\drawable-xlarge - 1 - - - - - res\values - 1 - - - res\values - 1 - - - - - 1 - - - Contents\MacOS - 1 - - - 0 - - - - - Contents\MacOS - 1 - .framework - - - Contents\MacOS - 1 - .framework - - - 0 - - - - - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 0 - .dll;.bpl - - - - - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 0 - .bpl - - - - - 0 - - - 0 - - - 0 - - - 0 - - - 0 - - - Contents\Resources\StartUp\ - 0 - - - Contents\Resources\StartUp\ - 0 - - - 0 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - 1 - - - 1 - - - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - - - 1 - - - 1 - - - - - ..\ - 1 - - - ..\ - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ..\$(PROJECTNAME).launchscreen - 64 - - - ..\$(PROJECTNAME).launchscreen - 64 - - - - - 1 - - - 1 - - - 1 - - - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - - - ..\ - 1 - - - ..\ - 1 - - - - - Contents - 1 - - - Contents - 1 - - - - - Contents\Resources - 1 - - - Contents\Resources - 1 - - - - - library\lib\armeabi-v7a - 1 - - - library\lib\arm64-v8a - 1 - - - 1 - - - 1 - - - 1 - - - 1 - - - Contents\MacOS - 1 - - - Contents\MacOS - 1 - - - 0 - - - - - library\lib\armeabi-v7a - 1 - - - - - 1 - - - 1 - - - - - Assets - 1 - - - Assets - 1 - - - - - Assets - 1 - - - Assets - 1 - - - - - - - - - - - - - - - True - True - True - True - True - True - True - - - 12 - - - - - diff --git a/Examples/14.DM/DMDemo.res b/Examples/14.DM/DMDemo.res deleted file mode 100644 index 61545412..00000000 Binary files a/Examples/14.DM/DMDemo.res and /dev/null differ diff --git a/Examples/14.DM/DMDemoFrm.fmx b/Examples/14.DM/DMDemoFrm.fmx deleted file mode 100644 index 82e140a5..00000000 --- a/Examples/14.DM/DMDemoFrm.fmx +++ /dev/null @@ -1,11 +0,0 @@ -object DMDemoForm: TDMDemoForm - Left = 0 - Top = 0 - Caption = #31070#32463#21270#25968#27169#24341#25806#28436#31034'...' - ClientHeight = 392 - ClientWidth = 643 - FormFactor.Width = 320 - FormFactor.Height = 480 - FormFactor.Devices = [Desktop] - DesignerMasterStyle = 0 -end diff --git a/Examples/14.DM/DMDemoFrm.pas b/Examples/14.DM/DMDemoFrm.pas deleted file mode 100644 index 62bd7ad9..00000000 --- a/Examples/14.DM/DMDemoFrm.pas +++ /dev/null @@ -1,24 +0,0 @@ -unit DMDemoFrm; - -interface - -uses - System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, - FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs; - -type - TDMDemoForm = class(TForm) - private - { Private declarations } - public - { Public declarations } - end; - -var - DMDemoForm: TDMDemoForm; - -implementation - -{$R *.fmx} - -end. diff --git a/Examples/14.DM/UserDataModuleUnit.pas b/Examples/14.DM/UserDataModuleUnit.pas deleted file mode 100644 index ff99eb9d..00000000 --- a/Examples/14.DM/UserDataModuleUnit.pas +++ /dev/null @@ -1,286 +0,0 @@ -unit UserDataModuleUnit; - -interface - -uses CoreClasses, Geometry2DUnit, NumberBase; - -type - TUserDM = class; - - TUserDMItem = class(TCoreClassObject) - private - FOwner: TUserDM; - FName : string; - FValue: TNumberModule; - - FIncreaseFromCoreLogic : TNumberModule; - FIncreasePercentageFromCoreLogic: TNumberModule; - FReduceFromCoreLogic : TNumberModule; - FReducePercentageFromCoreLogic : TNumberModule; - - FIncreaseFromInternal : TNumberModule; - FIncreasePercentageFromInternal: TNumberModule; - FReduceFromInternal : TNumberModule; - FReducePercentageFromInternal : TNumberModule; - - FIncreaseFromDefine : TNumberModule; - FIncreasePercentageFromDefine: TNumberModule; - FReduceFromDefine : TNumberModule; - FReducePercentageFromDefine : TNumberModule; - - FLastFinalValue : Variant; - FNeedRecalcFinalValue: Boolean; - - procedure ChangeEvent(Sender: TNumberModuleEventInterface; NewValue: Variant); - public - constructor Create(AOwner: TUserDM; AName: string); - destructor Destroy; override; - - property Owner: TUserDM read FOwner; - property name: string read FName; - - function GetFinalValue: Variant; - property FinalValue: Variant read GetFinalValue; - - property Value: TNumberModule read FValue; - - property IncreaseFromCoreLogic: TNumberModule read FIncreaseFromCoreLogic; - property IncreasePercentageFromCoreLogic: TNumberModule read FIncreasePercentageFromCoreLogic; - property ReduceFromCoreLogic: TNumberModule read FReduceFromCoreLogic; - property ReducePercentageFromCoreLogic: TNumberModule read FReducePercentageFromCoreLogic; - - property IncreaseFromInternal: TNumberModule read FIncreaseFromInternal; - property IncreasePercentageFromInternal: TNumberModule read FIncreasePercentageFromInternal; - property ReduceFromInternal: TNumberModule read FReduceFromInternal; - property ReducePercentageFromInternal: TNumberModule read FReducePercentageFromInternal; - - property IncreaseFromDefine: TNumberModule read FIncreaseFromDefine; - property IncreasePercentageFromDefine: TNumberModule read FIncreasePercentageFromDefine; - property ReduceFromDefine: TNumberModule read FReduceFromDefine; - property ReducePercentageFromDefine: TNumberModule read FReducePercentageFromDefine; - end; - - TUserDM = class(TCoreClassObject) - private - FDataItemList : TCoreClassListForObj; - FNMList : TNumberModuleList; - FNMAutomatedManager: TNMAutomatedManager; - FUpdateCounter : Integer; - protected - procedure NumberItemChange(Sender: TUserDMItem); - public - constructor Create; - destructor Destroy; override; - - procedure InitData; - - procedure Progress(deltaTime: Double); {$IFDEF INLINE_ASM} inline; {$ENDIF} - procedure BeginUpdate; {$IFDEF INLINE_ASM} inline; {$ENDIF} - procedure EndUpdate; {$IFDEF INLINE_ASM} inline; {$ENDIF} - procedure RebuildAssociate; {$IFDEF INLINE_ASM} inline; {$ENDIF} - procedure Clear; - - procedure DeletePostFlag(Flag: TCoreClassPersistent); {$IFDEF INLINE_ASM} inline; {$ENDIF} - end; - -implementation - -procedure TUserDMItem.ChangeEvent(Sender: TNumberModuleEventInterface; NewValue: Variant); -begin - FNeedRecalcFinalValue := True; - FOwner.NumberItemChange(Self); -end; - -constructor TUserDMItem.Create(AOwner: TUserDM; AName: string); -begin - Assert(not AOwner.FNMList.Exists(AName)); - inherited Create; - FOwner := AOwner; - FOwner.FDataItemList.Add(Self); - FName := AName; - FValue := FOwner.FNMList[FName]; - - FIncreaseFromCoreLogic := FOwner.FNMList[FName + '.IncreaseFromCoreLogic']; - FIncreasePercentageFromCoreLogic := FOwner.FNMList[FName + '.IncreasePercentageFromCoreLogic']; - FReduceFromCoreLogic := FOwner.FNMList[FName + '.ReduceFromCoreLogic']; - FReducePercentageFromCoreLogic := FOwner.FNMList[FName + '.ReducePercentageFromCoreLogic']; - - FIncreaseFromInternal := FOwner.FNMList[FName + '.IncreaseFromInternal']; - FIncreasePercentageFromInternal := FOwner.FNMList[FName + '.IncreasePercentageFromInternal']; - FReduceFromInternal := FOwner.FNMList[FName + '.ReduceFromInternal']; - FReducePercentageFromInternal := FOwner.FNMList[FName + '.ReducePercentageFromInternal']; - - FIncreaseFromDefine := FOwner.FNMList[FName + '.IncreaseFromDefine']; - FIncreasePercentageFromDefine := FOwner.FNMList[FName + '.IncreasePercentageFromDefine']; - FReduceFromDefine := FOwner.FNMList[FName + '.ReduceFromDefine']; - FReducePercentageFromDefine := FOwner.FNMList[FName + '.ReducePercentageFromDefine']; - - FValue.OriginValue := 0; - - FIncreaseFromCoreLogic.OriginValue := 0; - FIncreasePercentageFromCoreLogic.OriginValue := 0; - FReduceFromCoreLogic.OriginValue := 0; - FReducePercentageFromCoreLogic.OriginValue := 0; - - FIncreaseFromInternal.OriginValue := 0; - FIncreasePercentageFromInternal.OriginValue := 0; - FReduceFromInternal.OriginValue := 0; - FReducePercentageFromInternal.OriginValue := 0; - - FIncreaseFromDefine.OriginValue := 0; - FIncreasePercentageFromDefine.OriginValue := 0; - FReduceFromDefine.OriginValue := 0; - FReducePercentageFromDefine.OriginValue := 0; - - {$IFDEF FPC} - FValue.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := @ChangeEvent; - - FIncreaseFromCoreLogic.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := @ChangeEvent; - FIncreasePercentageFromCoreLogic.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := @ChangeEvent; - FReduceFromCoreLogic.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := @ChangeEvent; - FReducePercentageFromCoreLogic.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := @ChangeEvent; - - FIncreaseFromInternal.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := @ChangeEvent; - FIncreasePercentageFromInternal.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := @ChangeEvent; - FReduceFromInternal.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := @ChangeEvent; - FReducePercentageFromInternal.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := @ChangeEvent; - - FIncreaseFromDefine.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := @ChangeEvent; - FIncreasePercentageFromDefine.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := @ChangeEvent; - FReduceFromDefine.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := @ChangeEvent; - FReducePercentageFromDefine.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := @ChangeEvent; - {$ELSE} - FValue.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := ChangeEvent; - - FIncreaseFromCoreLogic.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := ChangeEvent; - FIncreasePercentageFromCoreLogic.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := ChangeEvent; - FReduceFromCoreLogic.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := ChangeEvent; - FReducePercentageFromCoreLogic.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := ChangeEvent; - - FIncreaseFromInternal.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := ChangeEvent; - FIncreasePercentageFromInternal.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := ChangeEvent; - FReduceFromInternal.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := ChangeEvent; - FReducePercentageFromInternal.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := ChangeEvent; - - FIncreaseFromDefine.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := ChangeEvent; - FIncreasePercentageFromDefine.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := ChangeEvent; - FReduceFromDefine.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := ChangeEvent; - FReducePercentageFromDefine.RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := ChangeEvent; - {$ENDIF} - FLastFinalValue := 0; - FNeedRecalcFinalValue := True; -end; - -destructor TUserDMItem.Destroy; -begin - inherited Destroy; -end; - -function TUserDMItem.GetFinalValue: Variant; -var - vInc, vDec, vIncP, vDecP, v: Variant; -begin - if FNeedRecalcFinalValue then - begin - vInc := FIncreaseFromCoreLogic.AsValue + - FIncreaseFromInternal.AsValue + - FIncreaseFromDefine.AsValue; - - vDec := FReduceFromCoreLogic.AsValue + - FReduceFromInternal.AsValue + - FReduceFromDefine.AsValue; - - vIncP := FIncreasePercentageFromCoreLogic.AsValue + - FIncreasePercentageFromInternal.AsValue + - FIncreasePercentageFromDefine.AsValue; - - vDecP := FReducePercentageFromCoreLogic.AsValue + - FReducePercentageFromInternal.AsValue + - FReducePercentageFromDefine.AsValue; - - v := FValue.AsValue + (vInc - vDec); - - FLastFinalValue := v + v * ((vIncP - vDecP) * 0.01); - - FNeedRecalcFinalValue := False; - end; - Result := FLastFinalValue; -end; - -procedure TUserDM.NumberItemChange(Sender: TUserDMItem); -begin - if FUpdateCounter > 0 then - Exit; - RebuildAssociate; -end; - -constructor TUserDM.Create; -begin - inherited Create; - FDataItemList := TCoreClassListForObj.Create; - FNMList := TNumberModuleList.Create; - FNMAutomatedManager := TNMAutomatedManager.Create; - FUpdateCounter := 0; - - InitData; - RebuildAssociate; -end; - -destructor TUserDM.Destroy; -begin - Clear; - DisposeObject(FNMAutomatedManager); - DisposeObject(FNMList); - inherited Destroy; -end; - -procedure TUserDM.InitData; -begin -end; - -procedure TUserDM.Progress(deltaTime: Double); -begin - FNMAutomatedManager.Progress(deltaTime); -end; - -procedure TUserDM.BeginUpdate; -begin - inc(FUpdateCounter); -end; - -procedure TUserDM.EndUpdate; -begin - Dec(FUpdateCounter); - if FUpdateCounter <= 0 then - begin - FUpdateCounter := 0; - RebuildAssociate; - end; -end; - -procedure TUserDM.RebuildAssociate; -var - i: Integer; -begin - for i := 0 to FDataItemList.Count - 1 do - TUserDMItem(FDataItemList[i]).FNeedRecalcFinalValue := True; -end; - -procedure TUserDM.Clear; -var - i: Integer; -begin - for i := 0 to FDataItemList.Count - 1 do - DisposeObject(FDataItemList[i]); - FDataItemList.Clear; - - FNMAutomatedManager.Clear; - FNMList.Clear; -end; - -procedure TUserDM.DeletePostFlag(Flag: TCoreClassPersistent); -begin - FNMAutomatedManager.Delete(Flag); -end; - -end. diff --git a/Examples/15.100KConnectingOnVM/VMClient/VMCliFrm.pas b/Examples/15.100KConnectingOnVM/VMClient/VMCliFrm.pas index f3fded20..622ca869 100644 --- a/Examples/15.100KConnectingOnVM/VMClient/VMCliFrm.pas +++ b/Examples/15.100KConnectingOnVM/VMClient/VMCliFrm.pas @@ -88,7 +88,6 @@ procedure TVMCliForm.CreateVMButtonClick(Sender: TObject); i: Integer; begin ClientTunnel.ClientIO.p2pVMTunnel.MaxVMFragmentSize := 8192; - ClientTunnel.ClientIO.p2pVMTunnel.MaxRealBuffer := 8 * 1024 * 1024; ClientTunnel.ClientIO.p2pVMTunnel.QuietMode := False; for i := low(ClientWithVM) to high(ClientWithVM) do diff --git a/Examples/16.DoubleTunnelAuthOnVM/VMDoubleAuthFMXClient/VMDoubleAuthFMXClient.dproj b/Examples/16.DoubleTunnelAuthOnVM/VMDoubleAuthFMXClient/VMDoubleAuthFMXClient.dproj index 53227dbf..52e20839 100644 --- a/Examples/16.DoubleTunnelAuthOnVM/VMDoubleAuthFMXClient/VMDoubleAuthFMXClient.dproj +++ b/Examples/16.DoubleTunnelAuthOnVM/VMDoubleAuthFMXClient/VMDoubleAuthFMXClient.dproj @@ -360,6 +360,12 @@ + + + ic_launcher.png + true + + VMDoubleAuthFMXClient.exe @@ -371,12 +377,6 @@ true - - - ic_launcher.png - true - - true diff --git a/Examples/2.DelayModel/FMXCli/FMXDRClient.dproj b/Examples/2.DelayModel/FMXCli/FMXDRClient.dproj index 1e526954..a9103c8d 100644 --- a/Examples/2.DelayModel/FMXCli/FMXDRClient.dproj +++ b/Examples/2.DelayModel/FMXCli/FMXDRClient.dproj @@ -372,9 +372,8 @@ true - + - ic_launcher.png true @@ -390,8 +389,9 @@ true - + + ic_launcher.png true @@ -412,20 +412,20 @@ true - + splash_image.png true - - + + + splash_image.png true - - - splash_image.png + + true diff --git a/Examples/24.XNat/FMXLanNat/XLanMobile.dproj b/Examples/24.XNat/FMXLanNat/XLanMobile.dproj index 7c29cdf7..640b90dd 100644 --- a/Examples/24.XNat/FMXLanNat/XLanMobile.dproj +++ b/Examples/24.XNat/FMXLanNat/XLanMobile.dproj @@ -371,11 +371,6 @@ true - - - true - - libMobile.so @@ -394,6 +389,17 @@ true + + + true + + + + + splash_image.png + true + + splash_image.png @@ -416,12 +422,6 @@ true - - - splash_image.png - true - - true diff --git a/Examples/25.Compressor/ARMCPUTest.dproj b/Examples/25.Compressor/ARMCPUTest.dproj index dff044c7..079660fe 100644 --- a/Examples/25.Compressor/ARMCPUTest.dproj +++ b/Examples/25.Compressor/ARMCPUTest.dproj @@ -372,17 +372,17 @@ true - + true - + true - + true diff --git a/Examples/30.XNAT virtual server/XNATMobileServer.dproj b/Examples/30.XNAT virtual server/XNATMobileServer.dproj index e55c73e3..53b9aa29 100644 --- a/Examples/30.XNAT virtual server/XNATMobileServer.dproj +++ b/Examples/30.XNAT virtual server/XNATMobileServer.dproj @@ -333,6 +333,12 @@ true + + + ic_launcher.png + true + + true @@ -384,12 +390,6 @@ true - - - ic_launcher.png - true - - true diff --git a/Examples/4.DoubleTunnelAuth/FMXDCli/FMXADClient.dproj b/Examples/4.DoubleTunnelAuth/FMXDCli/FMXADClient.dproj index 9a3237e9..2f172b09 100644 --- a/Examples/4.DoubleTunnelAuth/FMXDCli/FMXADClient.dproj +++ b/Examples/4.DoubleTunnelAuth/FMXDCli/FMXADClient.dproj @@ -360,9 +360,8 @@ - + - libFMXDClient.so true @@ -389,29 +388,24 @@ true - - - ic_launcher.png + + true - + splash_image.png true - - - true - - - - + + + ic_launcher.png true - + splash_image.png true @@ -423,6 +417,11 @@ true + + + true + + splash_image.png @@ -461,36 +460,37 @@ true - - - FMXADClient.exe + + + libFMXDClient.so true - + + libFMXADClient.so true - - - classes.dex + + + FMXADClient.exe true - + true - + + classes.dex true - + - libFMXADClient.so true diff --git a/Examples/49.AdvanceEventBridge/2.InternetServ/InternetServ.dpr b/Examples/49.AdvanceEventBridge/2.InternetServ/InternetServ.dpr index e2c00a9d..51a1fea5 100644 --- a/Examples/49.AdvanceEventBridge/2.InternetServ/InternetServ.dpr +++ b/Examples/49.AdvanceEventBridge/2.InternetServ/InternetServ.dpr @@ -94,7 +94,7 @@ begin if DatabasePhyCli.RemoteInited then exit; DatabaseConnecting := True; - ProgressCadencer.PostExecuteC_NP(2, DoDelayConnectToDatabaseService); + SysPost.PostExecuteC_NP(2, DoDelayConnectToDatabaseService); end; {$ENDREGION 'p2pVMԶ첽¼ܶʱص'} {$REGION '첽¼'} diff --git a/Examples/5.Cloud2.0/FMXClient2.0/ACFMXClient.dproj b/Examples/5.Cloud2.0/FMXClient2.0/ACFMXClient.dproj index b1f8d6c4..ee1033d5 100644 --- a/Examples/5.Cloud2.0/FMXClient2.0/ACFMXClient.dproj +++ b/Examples/5.Cloud2.0/FMXClient2.0/ACFMXClient.dproj @@ -360,15 +360,15 @@ true - + - ACFMXClient.exe + ACFMXClient.rsm true - + - ACFMXClient.rsm + ACFMXClient.exe true diff --git a/Examples/6.MyServerInMobile/FMXServer/FMXServer.dproj b/Examples/6.MyServerInMobile/FMXServer/FMXServer.dproj index 0f98d4ed..4e2070f9 100644 --- a/Examples/6.MyServerInMobile/FMXServer/FMXServer.dproj +++ b/Examples/6.MyServerInMobile/FMXServer/FMXServer.dproj @@ -360,7 +360,7 @@ - + true @@ -371,11 +371,6 @@ true - - - true - - ic_launcher.png @@ -388,6 +383,11 @@ true + + + true + + splash_image.png @@ -400,29 +400,29 @@ true + + + true + + true - + splash_image.png true - + splash_image.png true - - - true - - - + splash_image.png true @@ -466,6 +466,11 @@ true + + + true + + classes.dex @@ -489,11 +494,6 @@ true - - - true - - 1 diff --git a/Examples/7.AnonyousFunctionWorkOnClient/FMXCli/FMXAFDRClient.dproj b/Examples/7.AnonyousFunctionWorkOnClient/FMXCli/FMXAFDRClient.dproj index 181cb3fd..87e6a357 100644 --- a/Examples/7.AnonyousFunctionWorkOnClient/FMXCli/FMXAFDRClient.dproj +++ b/Examples/7.AnonyousFunctionWorkOnClient/FMXCli/FMXAFDRClient.dproj @@ -360,8 +360,9 @@ - + + ic_launcher.png true @@ -474,18 +475,18 @@ true - + - libFMXAFDRClient.so true - + + libFMXAFDRClient.so true - + true @@ -574,21 +575,20 @@ true - + - classes.dex true - + - libFMXAFDRClient.so + classes.dex true - + - ic_launcher.png + libFMXAFDRClient.so true diff --git a/Examples/Only compiler/All.groupproj b/Examples/Only compiler/All.groupproj index 8786a169..fbb3977c 100644 --- a/Examples/Only compiler/All.groupproj +++ b/Examples/Only compiler/All.groupproj @@ -15,9 +15,6 @@ - - - @@ -377,15 +374,6 @@ - - - - - - - - - @@ -1332,13 +1320,13 @@ - + - + - + diff --git a/README.md b/README.md index fde54647..2bc06f2e 100644 --- a/README.md +++ b/README.md @@ -5,6 +5,8 @@ ZSERVER4D是一套高级通讯系统的地基平台，它偏向于开发工艺 ## 功能 +**ZServer4D为SAAS自动化群集构建的基础支持库**，详见 https://github.com/PassByYou888/zCloud + 支持运行平台Android,IOS,Win32/64,Linux,OSX,物联网IOT(任意版本的linux均能支持，包括树莓1-3代，香橙，高通，三星，小序列cpu mips linux) 支持编译器：FPC3.0.4以及DelphiXE10.2和以后的版本 diff --git a/Source/CommunicationFramework.pas b/Source/CommunicationFramework.pas index 6e0c4e2f..3c23e6ab 100644 --- a/Source/CommunicationFramework.pas +++ b/Source/CommunicationFramework.pas @@ -47,15 +47,14 @@ TCommunicationFrameworkWithP2PVM_Client = class; TIPV4 = array [0 .. 3] of Byte; PIPV4 = ^TIPV4; - TIPV6 = array [0 .. 7] of Word; PIPV6 = ^TIPV6; - TConsoleMethod = procedure(Sender: TPeerIO; ResultData: SystemString) of object; - TConsoleParamMethod = procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: SystemString) of object; + TConsoleMethod = procedure(Sender: TPeerIO; Result_: SystemString) of object; + TConsoleParamMethod = procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: SystemString) of object; TConsoleFailedMethod = procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: SystemString) of object; - TStreamMethod = procedure(Sender: TPeerIO; ResultData: TDataFrameEngine) of object; - TStreamParamMethod = procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: TDataFrameEngine) of object; + TStreamMethod = procedure(Sender: TPeerIO; Result_: TDataFrameEngine) of object; + TStreamParamMethod = procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine) of object; TStreamFailedMethod = procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDataFrameEngine) of object; TStateCall = procedure(const State: Boolean); TStateMethod = procedure(const State: Boolean) of object; @@ -71,10 +70,10 @@ TCommunicationFrameworkWithP2PVM_Client = class; TIONotifyMethod = procedure(P_IO: TPeerIO) of object; TProgressBackgroundProc = procedure(); TProgressBackgroundMethod = procedure() of object; - TStreamEventBridgeEventC = procedure(Sender: TStreamEventBridge; SourceIO, BridgeIO: TPeerIO; ResultData: TDataFrameEngine); - TStreamEventBridgeEventM = procedure(Sender: TStreamEventBridge; SourceIO, BridgeIO: TPeerIO; ResultData: TDataFrameEngine) of object; - TConsoleEventBridgeEventC = procedure(Sender: TConsoleEventBridge; SourceIO, BridgeIO: TPeerIO; ResultData: SystemString); - TConsoleEventBridgeEventM = procedure(Sender: TConsoleEventBridge; SourceIO, BridgeIO: TPeerIO; ResultData: SystemString) of object; + TStreamEventBridgeEventC = procedure(Sender: TStreamEventBridge; SourceIO, BridgeIO: TPeerIO; Result_: TDataFrameEngine); + TStreamEventBridgeEventM = procedure(Sender: TStreamEventBridge; SourceIO, BridgeIO: TPeerIO; Result_: TDataFrameEngine) of object; + TConsoleEventBridgeEventC = procedure(Sender: TConsoleEventBridge; SourceIO, BridgeIO: TPeerIO; Result_: SystemString); + TConsoleEventBridgeEventM = procedure(Sender: TConsoleEventBridge; SourceIO, BridgeIO: TPeerIO; Result_: SystemString) of object; TP2PVM_CloneConnectEventC = procedure(Sender: TCommunicationFrameworkWithP2PVM_Client); TP2PVM_CloneConnectEventM = procedure(Sender: TCommunicationFrameworkWithP2PVM_Client) of object; TCommandStreamCall = procedure(Sender: TPeerIO; InData, OutData: TDataFrameEngine); @@ -91,11 +90,11 @@ TCommunicationFrameworkWithP2PVM_Client = class; TCommandCompleteBufferMethod = procedure(Sender: TPeerIO; InData: PByte; DataSize: NativeInt) of object; {$IFDEF FPC} - TConsoleProc = procedure(Sender: TPeerIO; ResultData: SystemString) is nested; - TConsoleParamProc = procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: SystemString) is nested; + TConsoleProc = procedure(Sender: TPeerIO; Result_: SystemString) is nested; + TConsoleParamProc = procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: SystemString) is nested; TConsoleFailedProc = procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: SystemString) is nested; - TStreamProc = procedure(Sender: TPeerIO; ResultData: TDataFrameEngine) is nested; - TStreamParamProc = procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: TDataFrameEngine) is nested; + TStreamProc = procedure(Sender: TPeerIO; Result_: TDataFrameEngine) is nested; + TStreamParamProc = procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine) is nested; TStreamFailedProc = procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDataFrameEngine) is nested; TStateProc = procedure(const State: Boolean) is nested; TIOStateProc = procedure(P_IO: TPeerIO; State: Boolean) is nested; @@ -103,8 +102,8 @@ TCommunicationFrameworkWithP2PVM_Client = class; TNotifyProc = procedure() is nested; TDataNotifyProc = procedure(data: TCoreClassObject) is nested; TIONotifyProc = procedure(P_IO: TPeerIO) is nested; - TStreamEventBridgeEventP = procedure(Sender: TStreamEventBridge; SourceIO, BridgeIO: TPeerIO; ResultData: TDataFrameEngine) is nested; - TConsoleEventBridgeEventP = procedure(Sender: TConsoleEventBridge; SourceIO, BridgeIO: TPeerIO; ResultData: SystemString) is nested; + TStreamEventBridgeEventP = procedure(Sender: TStreamEventBridge; SourceIO, BridgeIO: TPeerIO; Result_: TDataFrameEngine) is nested; + TConsoleEventBridgeEventP = procedure(Sender: TConsoleEventBridge; SourceIO, BridgeIO: TPeerIO; Result_: SystemString) is nested; TP2PVM_CloneConnectEventP = procedure(Sender: TCommunicationFrameworkWithP2PVM_Client) is nested; TCommandStreamProc = procedure(Sender: TPeerIO; InData, OutData: TDataFrameEngine) is nested; TCommandConsoleProc = procedure(Sender: TPeerIO; InData: SystemString; var OutData: SystemString) is nested; @@ -113,11 +112,11 @@ TCommunicationFrameworkWithP2PVM_Client = class; TCommandBigStreamProc = procedure(Sender: TPeerIO; InData: TCoreClassStream; BigStreamTotal, BigStreamCompleteSize: Int64) is nested; TCommandCompleteBufferProc = procedure(Sender: TPeerIO; InData: PByte; DataSize: NativeInt) is nested; {$ELSE FPC} - TConsoleProc = reference to procedure(Sender: TPeerIO; ResultData: SystemString); - TConsoleParamProc = reference to procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: SystemString); + TConsoleProc = reference to procedure(Sender: TPeerIO; Result_: SystemString); + TConsoleParamProc = reference to procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: SystemString); TConsoleFailedProc = reference to procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: SystemString); - TStreamProc = reference to procedure(Sender: TPeerIO; ResultData: TDataFrameEngine); - TStreamParamProc = reference to procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: TDataFrameEngine); + TStreamProc = reference to procedure(Sender: TPeerIO; Result_: TDataFrameEngine); + TStreamParamProc = reference to procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine); TStreamFailedProc = reference to procedure(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDataFrameEngine); TStateProc = reference to procedure(const State: Boolean); TIOStateProc = reference to procedure(P_IO: TPeerIO; State: Boolean); @@ -125,8 +124,8 @@ TCommunicationFrameworkWithP2PVM_Client = class; TNotifyProc = reference to procedure(); TDataNotifyProc = reference to procedure(data: TCoreClassObject); TIONotifyProc = reference to procedure(P_IO: TPeerIO); - TStreamEventBridgeEventP = reference to procedure(Sender: TStreamEventBridge; SourceIO, BridgeIO: TPeerIO; ResultData: TDataFrameEngine); - TConsoleEventBridgeEventP = reference to procedure(Sender: TConsoleEventBridge; SourceIO, BridgeIO: TPeerIO; ResultData: SystemString); + TStreamEventBridgeEventP = reference to procedure(Sender: TStreamEventBridge; SourceIO, BridgeIO: TPeerIO; Result_: TDataFrameEngine); + TConsoleEventBridgeEventP = reference to procedure(Sender: TConsoleEventBridge; SourceIO, BridgeIO: TPeerIO; Result_: SystemString); TP2PVM_CloneConnectEventP = reference to procedure(Sender: TCommunicationFrameworkWithP2PVM_Client); TCommandStreamProc = reference to procedure(Sender: TPeerIO; InData, OutData: TDataFrameEngine); TCommandConsoleProc = reference to procedure(Sender: TPeerIO; InData: SystemString; var OutData: SystemString); @@ -135,6 +134,11 @@ TCommunicationFrameworkWithP2PVM_Client = class; TCommandBigStreamProc = reference to procedure(Sender: TPeerIO; InData: TCoreClassStream; BigStreamTotal, BigStreamCompleteSize: Int64); TCommandCompleteBufferProc = reference to procedure(Sender: TPeerIO; InData: PByte; DataSize: NativeInt); {$ENDIF FPC} + TIO_ID_List_Decl = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + + TIO_ID_List = class(TIO_ID_List_Decl) + public + end; TOnStateStruct = record OnCall: TStateCall; @@ -145,6 +149,18 @@ TOnStateStruct = record POnStateStruct = ^TOnStateStruct; + TOnResultBridge = class + public + constructor Create; virtual; + destructor Destroy; override; + procedure DoConsoleEvent(Sender: TPeerIO; Result_: SystemString); virtual; + procedure DoConsoleParamEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: SystemString); virtual; + procedure DoConsoleFailedEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: SystemString); virtual; + procedure DoStreamEvent(Sender: TPeerIO; Result_: TDataFrameEngine); virtual; + procedure DoStreamParamEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine); virtual; + procedure DoStreamFailedEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDataFrameEngine); virtual; + end; + TStateParamBridge = class public OnNotifyC: TParamStateCall; @@ -153,7 +169,7 @@ TStateParamBridge = class Param1: Pointer; Param2: TObject; OnStateMethod: TStateMethod; - constructor Create; + constructor Create; virtual; destructor Destroy; override; procedure DoStateResult(const State: Boolean); end; @@ -659,8 +675,6 @@ TPeerIO = class(TCoreClassInterfacedObject) procedure P2PVMAuthSuccess(Sender: TCommunicationFrameworkWithP2PVM); protected { automated P2PVM } - FAutomatedP2PVMClient_Connection_Sequence: Integer; - FAutomatedP2PVMClient_Connection_Sequence_Successed: Integer; FOnAutomatedP2PVMClientConnectionDoneCall: TIOStateCall; FOnAutomatedP2PVMClientConnectionDoneMethod: TIOStateMethod; FOnAutomatedP2PVMClientConnectionDoneProc: TIOStateProc; @@ -690,13 +704,13 @@ TPeerIO = class(TCoreClassInterfacedObject) procedure SendByte(v: Byte); procedure SendWord(v: Word); procedure SendVerifyCode(buff: Pointer; siz: NativeInt); - procedure SendEncryptBuffer(buff: PByte; siz: NativeInt; cs: TCipherSecurity); - procedure SendEncryptMemoryStream(Stream: TMemoryStream64; cs: TCipherSecurity); + procedure SendEncryptBuffer(buff: PByte; siz: NativeInt; CS: TCipherSecurity); + procedure SendEncryptMemoryStream(Stream: TMemoryStream64; CS: TCipherSecurity); - procedure InternalSendConsoleBuff(buff: TMemoryStream64; cs: TCipherSecurity); - procedure InternalSendStreamBuff(buff: TMemoryStream64; cs: TCipherSecurity); - procedure InternalSendDirectConsoleBuff(buff: TMemoryStream64; cs: TCipherSecurity); - procedure InternalSendDirectStreamBuff(buff: TMemoryStream64; cs: TCipherSecurity); + procedure InternalSendConsoleBuff(buff: TMemoryStream64; CS: TCipherSecurity); + procedure InternalSendStreamBuff(buff: TMemoryStream64; CS: TCipherSecurity); + procedure InternalSendDirectConsoleBuff(buff: TMemoryStream64; CS: TCipherSecurity); + procedure InternalSendDirectStreamBuff(buff: TMemoryStream64; CS: TCipherSecurity); procedure InternalSendBigStreamHeader(Cmd: SystemString; streamSiz: Int64); procedure InternalSendBigStreamBuff(var Queue: TQueueData); procedure InternalSendCompleteBufferHeader(Cmd: SystemString; buffSiz, compSiz: Cardinal); @@ -764,6 +778,7 @@ TPeerIO = class(TCoreClassInterfacedObject) { p2pVM Tunnel support } property p2pVM: TCommunicationFrameworkWithP2PVM read FP2PVMTunnel; property p2pVMTunnel: TCommunicationFrameworkWithP2PVM read FP2PVMTunnel; + function p2pVMTunnelReadyOk: Boolean; { p2pVM build safe Auth token } procedure BuildP2PAuthToken; overload; procedure BuildP2PAuthTokenC(const OnResult: TNotifyCall); @@ -878,11 +893,13 @@ TPeerIO = class(TCoreClassInterfacedObject) property UserAutoFreeObjects: THashObjectList read GetUserAutoFreeObjects; property UserData: Pointer read FUserData write FUserData; property UserValue: Variant read FUserValue write FUserValue; - + { custom class } property UserDefine: TPeerIOUserDefine read FUserDefine; + property IODefine: TPeerIOUserDefine read FUserDefine; property Define: TPeerIOUserDefine read FUserDefine; - + { custom special class } property UserSpecial: TPeerIOUserSpecial read FUserSpecial; + property IOSpecial: TPeerIOUserSpecial read FUserSpecial; property Special: TPeerIOUserSpecial read FUserSpecial; { hash code } @@ -890,7 +907,7 @@ TPeerIO = class(TCoreClassInterfacedObject) function VerifyHashCode(const hs: THashSecurity; buff: Pointer; siz: Integer; var Code: TBytes): Boolean; { encrypt } - procedure Encrypt(cs: TCipherSecurity; DataPtr: Pointer; Size: Cardinal; var k: TCipherKeyBuffer; enc: Boolean); + procedure Encrypt(CS: TCipherSecurity; DataPtr: Pointer; Size: Cardinal; var k: TCipherKeyBuffer; enc: Boolean); { TimeOut Tick } function StopCommunicationTime: TTimeTick; @@ -932,7 +949,7 @@ TPeerIO = class(TCoreClassInterfacedObject) { wait send cmd } function WaitSendConsoleCmd(Cmd, ConsoleData: SystemString; Timeout: TTimeTick): SystemString; - procedure WaitSendStreamCmd(Cmd: SystemString; StreamData, ResultData: TDataFrameEngine; Timeout: TTimeTick); + procedure WaitSendStreamCmd(Cmd: SystemString; StreamData, Result_: TDataFrameEngine; Timeout: TTimeTick); { send bigstream } procedure SendBigStream(Cmd: SystemString; BigStream: TCoreClassStream; StartPos: Int64; DoneAutoFree: Boolean); overload; @@ -1022,6 +1039,7 @@ TAutomatedP2PVMClientData = record Client: TCommunicationFrameworkWithP2PVM_Client; IPV6: SystemString; Port: Word; + RequestConnecting: Boolean; end; PAutomatedP2PVMClientData = ^TAutomatedP2PVMClientData; @@ -1069,6 +1087,7 @@ TCommunicationFramework = class(TCoreClassInterfacedObject) FCipherSecurityArray: TCipherSecurityArray; FHashSecurity: THashSecurity; FMaxCompleteBufferSize: Cardinal; + FCompleteBufferCompressionCondition: Cardinal; FPrintParams: THashVariantList; FPostProgress: TNProgressPostWithCadencer; FFrameworkIsServer: Boolean; @@ -1124,7 +1143,7 @@ TCommunicationFramework = class(TCoreClassInterfacedObject) { private vm and protocol stack support } procedure BuildP2PAuthTokenResult_OnIOIDLE(Sender: TCoreClassObject); - procedure CommandResult_BuildP2PAuthToken(Sender: TPeerIO; ResultData: TDataFrameEngine); + procedure CommandResult_BuildP2PAuthToken(Sender: TPeerIO; Result_: TDataFrameEngine); procedure Command_BuildP2PAuthToken(Sender: TPeerIO; InData, OutData: TDataFrameEngine); procedure Command_InitP2PTunnel(Sender: TPeerIO; InData: SystemString); procedure Command_CloseP2PTunnel(Sender: TPeerIO; InData: SystemString); @@ -1209,12 +1228,17 @@ TCommunicationFramework = class(TCoreClassInterfacedObject) property OnAutomatedP2PVMClientConnectionDone_M: TOnAutomatedP2PVMClientConnectionDone_M read FOnAutomatedP2PVMClientConnectionDone_M write FOnAutomatedP2PVMClientConnectionDone_M; property OnAutomatedP2PVMClientConnectionDone_P: TOnAutomatedP2PVMClientConnectionDone_P read FOnAutomatedP2PVMClientConnectionDone_P write FOnAutomatedP2PVMClientConnectionDone_P; { automated P2PVM client api } - function AutomatedP2PVMClientConnectionDone(P_IO: TPeerIO): Boolean; - procedure AutomatedP2PVM_Open(P_IO: TPeerIO); + function AutomatedP2PVMClientConnectionDone(P_IO: TPeerIO): Boolean; overload; + function AutomatedP2PVMClientConnectionDone(): Boolean; overload; + procedure AutomatedP2PVM_Open(P_IO: TPeerIO); overload; + procedure AutomatedP2PVM_Open(); overload; procedure AutomatedP2PVM_Open_C(P_IO: TPeerIO; const OnResult: TIOStateCall); procedure AutomatedP2PVM_Open_M(P_IO: TPeerIO; const OnResult: TIOStateMethod); procedure AutomatedP2PVM_Open_P(P_IO: TPeerIO; const OnResult: TIOStateProc); - procedure AutomatedP2PVM_Close(P_IO: TPeerIO); + procedure AutomatedP2PVM_Close(P_IO: TPeerIO); overload; + procedure AutomatedP2PVM_Close(); overload; + function p2pVMTunnelReadyOk(P_IO: TPeerIO): Boolean; overload; + function p2pVMTunnelReadyOk(): Boolean; overload; { IO Big Stream interface } property OnBigStreamInterface: IOnBigStreamInterface read FOnBigStreamInterface write FOnBigStreamInterface; @@ -1271,8 +1295,13 @@ TCommunicationFramework = class(TCoreClassInterfacedObject) procedure Error(const v: SystemString; const Args: array of const); overload; procedure Error(const v: SystemString); overload; procedure ErrorParam(v: SystemString; Args: SystemString); + procedure PrintError(const v: SystemString; const Args: array of const); overload; + procedure PrintError(const v: SystemString); overload; + procedure PrintErrorParam(v: SystemString; Args: SystemString); procedure Warning(const v: SystemString); procedure WarningParam(v: SystemString; Args: SystemString); + procedure PrintWarning(const v: SystemString); + procedure PrintWarningParam(v: SystemString; Args: SystemString); { register command for server/client } function DeleteRegistedCMD(Cmd: SystemString): Boolean; @@ -1322,8 +1351,10 @@ TCommunicationFramework = class(TCoreClassInterfacedObject) property CompleteBufferCompressed: Boolean read FCompleteBufferCompressed write FCompleteBufferCompressed; property HashSecurity: THashSecurity read FHashSecurity; property MaxCompleteBufferSize: Cardinal read FMaxCompleteBufferSize write FMaxCompleteBufferSize; - { large-scale IO support } - property ProgressMaxDelay: TTimeTick read FProgressMaxDelay write FProgressMaxDelay; + property CompleteBufferCompressionCondition: Cardinal read FCompleteBufferCompressionCondition write FCompleteBufferCompressionCondition; + property ProgressMaxDelay: TTimeTick read FProgressMaxDelay write FProgressMaxDelay; { large-scale IO support } + procedure CopyParamFrom(Source: TCommunicationFramework); + procedure CopyParamTo(Dest: TCommunicationFramework); { state } property CMDWithThreadRuning: Integer read FCMDWithThreadRuning; @@ -1457,7 +1488,7 @@ TCommunicationFrameworkServer = class(TCommunicationFramework) { wait send } function WaitSendConsoleCmd(P_IO: TPeerIO; const Cmd, ConsoleData: SystemString; Timeout: TTimeTick): SystemString; overload; virtual; - procedure WaitSendStreamCmd(P_IO: TPeerIO; const Cmd: SystemString; StreamData, ResultData: TDataFrameEngine; Timeout: TTimeTick); overload; virtual; + procedure WaitSendStreamCmd(P_IO: TPeerIO; const Cmd: SystemString; StreamData, Result_: TDataFrameEngine; Timeout: TTimeTick); overload; virtual; { send bigstream } procedure SendBigStream(P_IO: TPeerIO; const Cmd: SystemString; BigStream: TCoreClassStream; StartPos: Int64; DoneAutoFree: Boolean); overload; @@ -1495,7 +1526,7 @@ TCommunicationFrameworkServer = class(TCommunicationFramework) { wait send } function WaitSendConsoleCmd(IO_ID: Cardinal; const Cmd, ConsoleData: SystemString; Timeout: TTimeTick): SystemString; overload; - procedure WaitSendStreamCmd(IO_ID: Cardinal; const Cmd: SystemString; StreamData, ResultData: TDataFrameEngine; Timeout: TTimeTick); overload; + procedure WaitSendStreamCmd(IO_ID: Cardinal; const Cmd: SystemString; StreamData, Result_: TDataFrameEngine; Timeout: TTimeTick); overload; { send bigstream } procedure SendBigStream(IO_ID: Cardinal; const Cmd: SystemString; BigStream: TCoreClassStream; StartPos: Int64; DoneAutoFree: Boolean); overload; @@ -1564,7 +1595,10 @@ TCommunicationFrameworkClient = class(TCommunicationFramework) FIgnoreProcessConnectedAndDisconnect: Boolean; FLastConnectIsSuccessed: Boolean; - procedure StreamResult_CipherModel(Sender: TPeerIO; ResultData: TDataFrameEngine); + FRequestTime: TTimeTick; + FReponseTime: TTimeTick; + + procedure StreamResult_CipherModel(Sender: TPeerIO; Result_: TDataFrameEngine); procedure DoConnected(Sender: TPeerIO); virtual; procedure DoDisconnect(Sender: TPeerIO); virtual; @@ -1589,16 +1623,21 @@ TCommunicationFrameworkClient = class(TCommunicationFramework) FOnWaitResultCall: TStateCall; FOnWaitResultMethod: TStateMethod; FOnWaitResultProc: TStateProc; - procedure ConsoleResult_Wait(Sender: TPeerIO; ResultData: SystemString); + procedure ConsoleResult_Wait(Sender: TPeerIO; Result_: SystemString); function GetWaitTimeout(const t: TTimeTick): TTimeTick; + private + { IO_IDLE_Trace_And_FreeSelf } + procedure Do_IO_IDLE_FreeSelf(Data_: TCoreClassObject); public constructor Create; virtual; destructor Destroy; override; + procedure DelayFreeSelf; - { IO Idle Trace } + { IO IDLE Trace } procedure IO_IDLE_TraceC(data: TCoreClassObject; const OnNotify: TDataNotifyCall); procedure IO_IDLE_TraceM(data: TCoreClassObject; const OnNotify: TDataNotifyMethod); procedure IO_IDLE_TraceP(data: TCoreClassObject; const OnNotify: TDataNotifyProc); + procedure IO_IDLE_Trace_And_FreeSelf(Additional_Object_: TCoreClassObject); { OnReceiveBuffer work on Protocol is cpCustom } procedure OnReceiveBuffer(const buffer: PByte; const Size: NativeInt; var FillDone: Boolean); virtual; @@ -1613,6 +1652,9 @@ TCommunicationFrameworkClient = class(TCommunicationFramework) { ServerState must be connected successfully. } function ServerState: PCommunicationFramework_ServerState; + { net delay time } + property ReponseTime: TTimeTick read FReponseTime; + { mainLoop } procedure Progress; override; @@ -1653,10 +1695,9 @@ TCommunicationFrameworkClient = class(TCommunicationFramework) { disconnect } procedure Disconnect; virtual; - { delay close on now } - procedure DelayClose; overload; - { delay close on custom delay of double time } - procedure DelayClose(const t: Double); overload; + { delay close IO } + procedure DelayCloseIO; overload; + procedure DelayCloseIO(const t: Double); overload; { sync wait reponse } function Wait(TimeOut_: TTimeTick): SystemString; overload; @@ -1703,7 +1744,7 @@ TCommunicationFrameworkClient = class(TCommunicationFramework) { wait send } function WaitSendConsoleCmd(Cmd, ConsoleData: SystemString; Timeout: TTimeTick): SystemString; virtual; - procedure WaitSendStreamCmd(Cmd: SystemString; StreamData, ResultData: TDataFrameEngine; Timeout: TTimeTick); virtual; + procedure WaitSendStreamCmd(Cmd: SystemString; StreamData, Result_: TDataFrameEngine; Timeout: TTimeTick); virtual; { send bigstream } procedure SendBigStream(Cmd: SystemString; BigStream: TCoreClassStream; StartPos: Int64; DoneAutoFree: Boolean); overload; @@ -1814,11 +1855,11 @@ TCommunicationFrameworkWithP2PVM_Server = class(TCommunicationFrameworkServer) { service method } procedure ProgressStopServiceWithPerVM(SenderVM: TCommunicationFrameworkWithP2PVM); procedure StopService; override; - function StartService(Host: SystemString; Port: Word): Boolean; override; + function StartService(Host_: SystemString; Port: Word): Boolean; override; { sync } function WaitSendConsoleCmd(P_IO: TPeerIO; const Cmd, ConsoleData: SystemString; Timeout: TTimeTick): SystemString; override; - procedure WaitSendStreamCmd(P_IO: TPeerIO; const Cmd: SystemString; StreamData, ResultData: TDataFrameEngine; Timeout: TTimeTick); override; + procedure WaitSendStreamCmd(P_IO: TPeerIO; const Cmd: SystemString; StreamData, Result_: TDataFrameEngine; Timeout: TTimeTick); override; end; TCommunicationFrameworkWithP2PVM_ClientList = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; @@ -1906,7 +1947,6 @@ TCommunicationFrameworkWithP2PVM = class(TCoreClassObject) FFrameworkPool: TUInt32HashObjectList; FFrameworkListenPool: TCoreClassList; FMaxVMFragmentSize: Cardinal; - FMaxRealBuffer: Cardinal; FQuietMode: Boolean; FReceiveStream: TMemoryStream64; FSendStream: TMemoryStream64; @@ -1959,7 +1999,6 @@ TCommunicationFrameworkWithP2PVM = class(TCoreClassObject) { p2p VM Peformance support } { MaxVMFragmentSize see also MTU } property MaxVMFragmentSize: Cardinal read FMaxVMFragmentSize write FMaxVMFragmentSize; - property MaxRealBuffer: Cardinal read FMaxRealBuffer write FMaxRealBuffer; property QuietMode: Boolean read FQuietMode write FQuietMode; { p2p VM safe Support } @@ -2064,7 +2103,7 @@ TCommunicationFramework_CustomStableServer = class(TCommunicationFrameworkServ procedure TriggerQueueData(v: PQueueData); override; function WaitSendConsoleCmd(P_IO: TPeerIO; const Cmd, ConsoleData: SystemString; Timeout: TTimeTick): SystemString; override; - procedure WaitSendStreamCmd(P_IO: TPeerIO; const Cmd: SystemString; StreamData, ResultData: TDataFrameEngine; Timeout: TTimeTick); override; + procedure WaitSendStreamCmd(P_IO: TPeerIO; const Cmd: SystemString; StreamData, Result_: TDataFrameEngine; Timeout: TTimeTick); override; end; TCommunicationFramework_StableServer = class(TCommunicationFramework_CustomStableServer) @@ -2112,12 +2151,12 @@ TCommunicationFramework_CustomStableClient = class(TCommunicationFrameworkClie procedure SetPhysicsClient(const Value: TCommunicationFrameworkClient); { connection } - procedure BuildStableIO_Result(Sender: TPeerIO; ResultData: TDataFrameEngine); + procedure BuildStableIO_Result(Sender: TPeerIO; Result_: TDataFrameEngine); procedure AsyncConnectResult(const cState: Boolean); procedure PostConnection(Sender: TNPostExecute); { reconnection } - procedure OpenStableIO_Result(Sender: TPeerIO; ResultData: TDataFrameEngine); + procedure OpenStableIO_Result(Sender: TPeerIO; Result_: TDataFrameEngine); procedure AsyncReconnectionResult(const cState: Boolean); procedure PostReconnection(Sender: TNPostExecute); procedure Reconnection; @@ -2349,6 +2388,7 @@ function StrToIPv6(const s: U_String; var Success: Boolean): TIPV6; overload; function IPv6ToStr(const IPv6Addr: TIPV6): U_String; function IsIPv4(const s: U_String): Boolean; function IsIPV6(const s: U_String): Boolean; +function MakeRandomIPV6(): TIPV6; function CompareIPV4(const IP1, IP2: TIPV4): Boolean; function CompareIPV6(const IP1, IP2: TIPV6): Boolean; @@ -2400,25 +2440,24 @@ procedure DoExecuteResult(c: TPeerIO; const QueuePtr: PQueueData; const AResultT C_DataTailToken: Cardinal = $F1F1F1F1; { send flush buffer } - C_SendFlushSize: NativeInt = 16 * 1024; { flush size = 16k byte } + C_SendFlushSize: NativeInt = 32 * 1024; { flush size = 32k byte } { max complete buffer } - C_MaxCompleteBufferSize: NativeInt = 64 * 1024 * 1024; { 64M, 0 = infinity } + C_MaxCompleteBufferSize: Cardinal = 64 * 1024 * 1024; { 64M, 0 = infinity } + { complete buffer compression condition } + C_CompleteBufferCompressionCondition: Cardinal = 1024; { sequence packet model Packet MTU } - C_SequencePacketMTU: Word = {$IFDEF Delphi}1536{$ELSE Delphi}20000{$ENDIF Delphi}; + C_SequencePacketMTU: Word = 1024; { P2PVM Fragment size } - C_P2PVM_MaxVMFragmentSize: Cardinal = {$IFDEF Delphi}8192{$ELSE Delphi}20000{$ENDIF Delphi}; - - { P2PVM Max Real buffer } - C_P2PVM_MaxRealBuffer: Cardinal = 2048 * 1024; + C_P2PVM_MaxVMFragmentSize: Cardinal = 1536; { DoStatus ID } C_DoStatusID: Integer = $0FFFFFFF; { vm auth token size } - C_VMAuthSize: Integer = 256; + C_VMAuthSize: Integer = 16; { BigStream fragment size } C_BigStream_ChunkSize: NativeInt = 1024 * 1024; @@ -2430,6 +2469,9 @@ procedure DoExecuteResult(c: TPeerIO; const QueuePtr: PQueueData; const AResultT ProgressBackgroundProc: TProgressBackgroundProc = nil; ProgressBackgroundMethod: TProgressBackgroundMethod = nil; + { random ipv6 seed } + V_IPV6_Seed: UInt64 = 0; + { system } C_CipherModel: SystemString = '__@CipherModel'; C_Wait: SystemString = '__@Wait'; @@ -2553,7 +2595,7 @@ TWaitSendConsoleCmdIntf = class(TCoreClassObject) Failed: Boolean; constructor Create; procedure DoConsoleFailed(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: SystemString); - procedure DoConsoleParam(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: SystemString); + procedure DoConsoleParam(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: SystemString); end; TWaitSendStreamCmdIntf = class(TCoreClassObject) @@ -2564,7 +2606,7 @@ TWaitSendStreamCmdIntf = class(TCoreClassObject) constructor Create; destructor Destroy; override; procedure DoStreamFailed(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDataFrameEngine); - procedure DoStreamParam(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: TDataFrameEngine); + procedure DoStreamParam(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine); end; constructor TWaitSendConsoleCmdIntf.Create; @@ -2581,9 +2623,9 @@ procedure TWaitSendConsoleCmdIntf.DoConsoleFailed(Sender: TPeerIO; Param1: Point Failed := True; end; -procedure TWaitSendConsoleCmdIntf.DoConsoleParam(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: SystemString); +procedure TWaitSendConsoleCmdIntf.DoConsoleParam(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: SystemString); begin - NewResult := ResultData; + NewResult := Result_; Done := True; Failed := False; end; @@ -2608,9 +2650,9 @@ procedure TWaitSendStreamCmdIntf.DoStreamFailed(Sender: TPeerIO; Param1: Pointer Failed := True; end; -procedure TWaitSendStreamCmdIntf.DoStreamParam(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: TDataFrameEngine); +procedure TWaitSendStreamCmdIntf.DoStreamParam(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine); begin - NewResult.Assign(ResultData); + NewResult.Assign(Result_); Done := True; Failed := False; end; @@ -2712,7 +2754,7 @@ function StrToIPv4(const s: U_String; var Success: Boolean): TIPV4; dotCount: Integer; NumVal: Integer; Len: Integer; - Ch: Char; + CH: SystemChar; begin FillPtrByte(@Result[0], SizeOf(Result), 0); Success := False; @@ -2724,17 +2766,17 @@ function StrToIPv4(const s: U_String; var Success: Boolean): TIPV4; NumVal := -1; for i := 1 to Len do begin - Ch := n[i]; - if CharIn(Ch, c0to9) then + CH := n[i]; + if CharIn(CH, c0to9) then begin if NumVal < 0 then - NumVal := Ord(Ch) - Ord('0') + NumVal := Ord(CH) - Ord('0') else - NumVal := NumVal * 10 + Ord(Ch) - Ord('0'); + NumVal := NumVal * 10 + Ord(CH) - Ord('0'); if NumVal > 255 then exit; end - else if Ch = '.' then + else if CH = '.' then begin if (NumVal > -1) and (dotCount < 3) then Result[dotCount] := NumVal @@ -2768,7 +2810,7 @@ function StrToIPv6(const s: U_String; var Success: Boolean; var ScopeID: Cardina ColonCnt: Integer; i: Integer; NumVal: Integer; - Ch: Char; + CH: SystemChar; SLen: Integer; OmitPos: Integer; OmitCnt: Integer; @@ -2790,7 +2832,8 @@ function StrToIPv6(const s: U_String; var Success: Boolean; var ScopeID: Cardina OmitPos := n.GetPos('::') - 1; if OmitPos > -1 then OmitCnt := 8 - ColonCnt - else begin + else + begin OmitCnt := 0; { Make the compiler happy } if (n.First = Colon) or (n.Last = Colon) then exit; @@ -2803,9 +2846,9 @@ function StrToIPv6(const s: U_String; var Success: Boolean; var ScopeID: Cardina ScopeFlag := False; while i < SLen do begin - Ch := n.buff[i]; + CH := n.buff[i]; - if Ch = Percent then + if CH = Percent then begin if ScopeFlag then exit @@ -2819,7 +2862,7 @@ function StrToIPv6(const s: U_String; var Success: Boolean; var ScopeID: Cardina NumVal := -1; end; end - else if Ch = Colon then + else if CH = Colon then begin if ScopeFlag then exit; @@ -2838,27 +2881,27 @@ function StrToIPv6(const s: U_String; var Success: Boolean; var ScopeID: Cardina if ColonCnt > 7 then exit; end - else if CharIn(Ch, c0to9) then + else if CharIn(CH, c0to9) then begin inc(PartCnt); if NumVal < 0 then - NumVal := (Ord(Ch) - Ord('0')) + NumVal := (Ord(CH) - Ord('0')) else if ScopeFlag then - NumVal := NumVal * 10 + (Ord(Ch) - Ord('0')) + NumVal := NumVal * 10 + (Ord(CH) - Ord('0')) else - NumVal := NumVal * 16 + (Ord(Ch) - Ord('0')); + NumVal := NumVal * 16 + (Ord(CH) - Ord('0')); if (NumVal > high(Word)) or (PartCnt > 4) then exit; end - else if CharIn(Ch, cAtoZ) then + else if CharIn(CH, cAtoZ) then begin if ScopeFlag then exit; inc(PartCnt); if NumVal < 0 then - NumVal := ((Ord(Ch) and 15) + 9) + NumVal := ((Ord(CH) and 15) + 9) else - NumVal := NumVal * 16 + ((Ord(Ch) and 15) + 9); + NumVal := NumVal * 16 + ((Ord(CH) and 15) + 9); if (NumVal > high(Word)) or (PartCnt > 4) then exit; end @@ -2972,7 +3015,7 @@ function IsIPv4(const s: U_String): Boolean; i: Integer; DotCnt: Integer; NumVal: Integer; - Ch: Char; + CH: SystemChar; begin n := umlDeleteChar(s, [#32, #0, #9, #13, #10]); Result := False; @@ -2980,17 +3023,17 @@ function IsIPv4(const s: U_String): Boolean; NumVal := -1; for i := 1 to n.Len do begin - Ch := n[i]; - if CharIn(Ch, c0to9) then + CH := n[i]; + if CharIn(CH, c0to9) then begin if NumVal = -1 then - NumVal := Ord(Ch) - Ord('0') + NumVal := Ord(CH) - Ord('0') else - NumVal := NumVal * 10 + Ord(Ch) - Ord('0'); + NumVal := NumVal * 10 + Ord(CH) - Ord('0'); if NumVal > 255 then exit; end - else if Ch = '.' then + else if CH = '.' then begin inc(DotCnt); if (DotCnt > 3) or (NumVal = -1) then @@ -3011,6 +3054,18 @@ function IsIPV6(const s: U_String): Boolean; StrToIPv6(s, Result, ScopeID); end; +function MakeRandomIPV6(): TIPV6; +var + tmp: array [0 .. 31] of Byte; +begin + PTimeTick(@tmp[0])^ := GetTimeTick(); + PInt64(@tmp[8])^ := MT19937Rand64($7FFFFFFFFFFFFFFF); + PDouble(@tmp[16])^ := umlNow(); + PInt64(@tmp[24])^ := V_IPV6_Seed; + AtomInc(V_IPV6_Seed); + PMD5(@Result)^ := umlMD5(@tmp[0], 32); +end; + function CompareIPV4(const IP1, IP2: TIPV4): Boolean; begin Result := PCardinal(@IP1[0])^ = PCardinal(@IP2[0])^; @@ -3044,7 +3099,7 @@ function TranslateBindAddr(addr: SystemString): SystemString; procedure ExtractHostAddress(var Host: U_String; var Port: Word); begin - if Host.Exists(':') then + if Host.GetCharCount(':') = 1 then begin Port := umlStrToInt(umlGetLastStr(Host, ':'), Port); Host := umlDeleteLastStr(Host, ':'); @@ -3650,6 +3705,46 @@ procedure TOnStateStruct.Init; OnProc := nil; end; +constructor TOnResultBridge.Create; +begin + inherited Create; +end; + +destructor TOnResultBridge.Destroy; +begin + inherited Destroy; +end; + +procedure TOnResultBridge.DoConsoleEvent(Sender: TPeerIO; Result_: SystemString); +begin + +end; + +procedure TOnResultBridge.DoConsoleParamEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: SystemString); +begin + +end; + +procedure TOnResultBridge.DoConsoleFailedEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: SystemString); +begin + +end; + +procedure TOnResultBridge.DoStreamEvent(Sender: TPeerIO; Result_: TDataFrameEngine); +begin + +end; + +procedure TOnResultBridge.DoStreamParamEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine); +begin + +end; + +procedure TOnResultBridge.DoStreamFailedEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDataFrameEngine); +begin + +end; + constructor TStateParamBridge.Create; begin inherited Create; @@ -4712,7 +4807,6 @@ function TPeerIO.FillSequencePacketTo(const buff: Pointer; siz: Int64; ExtractDe p: PSequencePacket; head: Byte; echoSiz: Word; - echoBuff: TBytes; ResendNumber, DoneNumber: Cardinal; fastSwap, n: TMemoryStream64; hashMatched: Boolean; @@ -4773,15 +4867,9 @@ function TPeerIO.FillSequencePacketTo(const buff: Pointer; siz: Int64; ExtractDe if fastSwap.Position + echoSiz > fastSwap.Size then Break; - SetLength(echoBuff, echoSiz); + DoSequencePacketEchoKeepAlive(fastSwap.PositionAsPtr(), echoSiz); if echoSiz > 0 then - begin - fastSwap.ReadPtr(@echoBuff[0], echoSiz); - DoSequencePacketEchoKeepAlive(@echoBuff[0], echoSiz); - SetLength(echoBuff, 0); - end - else - DoSequencePacketEchoKeepAlive(nil, 0); + fastSwap.Position := fastSwap.Position + echoSiz; end else if head = C_Sequence_RequestResend then begin @@ -5039,19 +5127,19 @@ procedure TPeerIO.SendVerifyCode(buff: Pointer; siz: NativeInt); Send(@Code[0], Length(Code)); end; -procedure TPeerIO.SendEncryptBuffer(buff: PByte; siz: NativeInt; cs: TCipherSecurity); +procedure TPeerIO.SendEncryptBuffer(buff: PByte; siz: NativeInt; CS: TCipherSecurity); begin - SendByte(Byte(cs)); - Encrypt(cs, buff, siz, FCipherKey, True); + SendByte(Byte(CS)); + Encrypt(CS, buff, siz, FCipherKey, True); Send(buff, siz); end; -procedure TPeerIO.SendEncryptMemoryStream(Stream: TMemoryStream64; cs: TCipherSecurity); +procedure TPeerIO.SendEncryptMemoryStream(Stream: TMemoryStream64; CS: TCipherSecurity); begin - SendEncryptBuffer(Stream.Memory, Stream.Size, cs); + SendEncryptBuffer(Stream.Memory, Stream.Size, CS); end; -procedure TPeerIO.InternalSendConsoleBuff(buff: TMemoryStream64; cs: TCipherSecurity); +procedure TPeerIO.InternalSendConsoleBuff(buff: TMemoryStream64; CS: TCipherSecurity); begin BeginSend; SendCardinal(FHeadToken); @@ -5059,12 +5147,12 @@ procedure TPeerIO.InternalSendConsoleBuff(buff: TMemoryStream64; cs: TCipherSecu SendCardinal(Cardinal(buff.Size)); SendVerifyCode(buff.Memory, buff.Size); - SendEncryptMemoryStream(buff, cs); + SendEncryptMemoryStream(buff, CS); SendCardinal(FTailToken); EndSend; end; -procedure TPeerIO.InternalSendStreamBuff(buff: TMemoryStream64; cs: TCipherSecurity); +procedure TPeerIO.InternalSendStreamBuff(buff: TMemoryStream64; CS: TCipherSecurity); begin BeginSend; SendCardinal(FHeadToken); @@ -5072,12 +5160,12 @@ procedure TPeerIO.InternalSendStreamBuff(buff: TMemoryStream64; cs: TCipherSecur SendCardinal(Cardinal(buff.Size)); SendVerifyCode(buff.Memory, buff.Size); - SendEncryptMemoryStream(buff, cs); + SendEncryptMemoryStream(buff, CS); SendCardinal(FTailToken); EndSend; end; -procedure TPeerIO.InternalSendDirectConsoleBuff(buff: TMemoryStream64; cs: TCipherSecurity); +procedure TPeerIO.InternalSendDirectConsoleBuff(buff: TMemoryStream64; CS: TCipherSecurity); begin BeginSend; SendCardinal(FHeadToken); @@ -5085,12 +5173,12 @@ procedure TPeerIO.InternalSendDirectConsoleBuff(buff: TMemoryStream64; cs: TCiph SendCardinal(Cardinal(buff.Size)); SendVerifyCode(buff.Memory, buff.Size); - SendEncryptMemoryStream(buff, cs); + SendEncryptMemoryStream(buff, CS); SendCardinal(FTailToken); EndSend; end; -procedure TPeerIO.InternalSendDirectStreamBuff(buff: TMemoryStream64; cs: TCipherSecurity); +procedure TPeerIO.InternalSendDirectStreamBuff(buff: TMemoryStream64; CS: TCipherSecurity); begin BeginSend; SendCardinal(FHeadToken); @@ -5098,7 +5186,7 @@ procedure TPeerIO.InternalSendDirectStreamBuff(buff: TMemoryStream64; cs: TCiphe SendCardinal(Cardinal(buff.Size)); SendVerifyCode(buff.Memory, buff.Size); - SendEncryptMemoryStream(buff, cs); + SendEncryptMemoryStream(buff, CS); SendCardinal(FTailToken); EndSend; end; @@ -5201,19 +5289,19 @@ procedure TPeerIO.InternalSendCompleteBufferHeader(Cmd: SystemString; buffSiz, c procedure TPeerIO.InternalSendCompleteBufferBuff(var Queue: TQueueData); var - sour, dest: TMemoryStream64; + sour, Dest: TMemoryStream64; begin BeginSend; - if FOwnerFramework.FCompleteBufferCompressed then + if FOwnerFramework.FCompleteBufferCompressed and (Queue.BufferSize > OwnerFramework.FCompleteBufferCompressionCondition) then begin sour := TMemoryStream64.Create; sour.SetPointerWithProtectedMode(Queue.buffer, Queue.BufferSize); - dest := TMemoryStream64.Create; - ParallelCompressMemory(scmZLIB_Fast, sour, dest); - InternalSendCompleteBufferHeader(Queue.Cmd, Queue.BufferSize, dest.Size); - Send(dest.Memory, dest.Size); + Dest := TMemoryStream64.Create; + ParallelCompressMemory(scmZLIB_Fast, sour, Dest); + InternalSendCompleteBufferHeader(Queue.Cmd, Queue.BufferSize, Dest.Size); + Send(Dest.Memory, Dest.Size); DisposeObject(sour); - DisposeObject(dest); + DisposeObject(Dest); end else begin @@ -5743,7 +5831,7 @@ function TPeerIO.FillCompleteBufferBuffer(CurrentActiveThread_: TCoreClassThread leftSize: Cardinal; tmpStream: TMemoryStream64; - dest: TMemoryStream64; + Dest: TMemoryStream64; begin leftSize := FCompleteBufferTotal - FCompleteBufferCompleted; if leftSize > FReceivedBuffer.Size then @@ -5772,11 +5860,11 @@ function TPeerIO.FillCompleteBufferBuffer(CurrentActiveThread_: TCoreClassThread if FCompleteBufferCompressedSize > 0 then begin - dest := TMemoryStream64.Create; - ParallelDecompressStream(FCompleteBufferReceivedStream, dest); + Dest := TMemoryStream64.Create; + ParallelDecompressStream(FCompleteBufferReceivedStream, Dest); DisposeObject(FCompleteBufferReceivedStream); - dest.Position := 0; - FCompleteBufferReceivedStream := dest; + Dest.Position := 0; + FCompleteBufferReceivedStream := Dest; end; IO_SyncMethod(CurrentActiveThread_, Sync, {$IFDEF FPC}@{$ENDIF FPC}Sync_ExecuteCompleteBuffer); @@ -6654,7 +6742,7 @@ constructor TPeerIO.Create(OwnerFramework_: TCommunicationFramework; IOInterface AtomInc(FOwnerFramework.Statistics[TStatisticsType.stTriggerConnect]); - InitSequencePacketModel(512, 1024); + InitSequencePacketModel(512, $FFFF); FP2PVMTunnel := nil; SetLength(FP2PAuthToken, $FF); @@ -6680,8 +6768,6 @@ constructor TPeerIO.Create(OwnerFramework_: TCommunicationFramework; IOInterface OnVMAuthResultIOMethod := nil; OnVMAuthResultIOProc := nil; - FAutomatedP2PVMClient_Connection_Sequence := 0; - FAutomatedP2PVMClient_Connection_Sequence_Successed := 0; FOnAutomatedP2PVMClientConnectionDoneCall := nil; FOnAutomatedP2PVMClientConnectionDoneMethod := nil; FOnAutomatedP2PVMClientConnectionDoneProc := nil; @@ -6782,7 +6868,8 @@ destructor TPeerIO.Destroy; function TPeerIO.IOBusy: Boolean; begin - Result := (IOSendBuffer.Size > 0) or + Result := + (IOSendBuffer.Size > 0) or (SendingSequencePacketHistory.Count > 0) or (SequencePacketReceivedPool.Count > 0) or (FQueueList.Count > 0) or @@ -6852,6 +6939,11 @@ procedure TPeerIO.IO_IDLE_TraceP(data: TCoreClassObject; OnNotify: TDataNotifyPr FOwnerFramework.ProgressEngine.PostExecuteM(0.1, {$IFDEF FPC}@{$ENDIF FPC}FOwnerFramework.IDLE_Trace_Execute).Data5 := p; end; +function TPeerIO.p2pVMTunnelReadyOk: Boolean; +begin + Result := (FP2PVMTunnel <> nil) and (FP2PVMTunnel.WasAuthed); +end; + procedure TPeerIO.BuildP2PAuthToken; var de: TDataFrameEngine; @@ -6860,7 +6952,7 @@ procedure TPeerIO.BuildP2PAuthToken; FSequencePacketSignal := False; de := TDataFrameEngine.Create; - de.WriteInteger(umlRandomRange(-maxInt, maxInt)); + de.WriteInteger(umlRandomRange(-MaxInt, MaxInt)); SendStreamCmdM(C_BuildP2PAuthToken, de, {$IFDEF FPC}@{$ENDIF FPC}FOwnerFramework.CommandResult_BuildP2PAuthToken); DisposeObject(de); InternalProcessAllSendCmd(nil, False, False); @@ -6948,9 +7040,9 @@ procedure TPeerIO.OpenP2PVMTunnel(vmHashPoolSize: Integer; SendRemoteRequest: Bo procedure TPeerIO.OpenP2PVMTunnel(SendRemoteRequest: Boolean; const AuthToken: SystemString); begin if FOwnerFramework.FFrameworkIsClient then - OpenP2PVMTunnel(8192, SendRemoteRequest, AuthToken) + OpenP2PVMTunnel(16384, SendRemoteRequest, AuthToken) else - OpenP2PVMTunnel(16, SendRemoteRequest, AuthToken); + OpenP2PVMTunnel(64, SendRemoteRequest, AuthToken); end; procedure TPeerIO.OpenP2PVMTunnelC(SendRemoteRequest: Boolean; const AuthToken: SystemString; const OnResult: TStateCall); @@ -7185,8 +7277,8 @@ procedure TPeerIO.Progress; DelayClose(1.0); end; - if (not FTimeOutProcessDone) and (OwnerFramework.TimeOutKeepAlive) and (IsSequencePacketModel) and (FSequencePacketSignal) and - (GetTimeTick() - LastCommunicationTick_KeepAlive > 2000) and (WriteBufferEmpty) then + if (not FTimeOutProcessDone) and (OwnerFramework.FTimeOutKeepAlive) and (IsSequencePacketModel) and (FSequencePacketSignal) and + (GetTimeTick() - LastCommunicationTick_KeepAlive > 1000) and (WriteBufferEmpty) then begin SendSequencePacketKeepAlive(nil, 0); FlushIOSendBuffer; @@ -7435,7 +7527,7 @@ function TPeerIO.VerifyHashCode(const hs: THashSecurity; buff: Pointer; siz: Int end; end; -procedure TPeerIO.Encrypt(cs: TCipherSecurity; DataPtr: Pointer; Size: Cardinal; var k: TCipherKeyBuffer; enc: Boolean); +procedure TPeerIO.Encrypt(CS: TCipherSecurity; DataPtr: Pointer; Size: Cardinal; var k: TCipherKeyBuffer; enc: Boolean); begin if Size = 0 then exit; @@ -7445,11 +7537,11 @@ procedure TPeerIO.Encrypt(cs: TCipherSecurity; DataPtr: Pointer; Size: Cardinal; if enc then begin if FEncryptInstance <> nil then - if (FEncryptInstance.CipherSecurity <> cs) or (not TCipher.CompareKey(FEncryptInstance.LastGenerateKey, k)) then + if (FEncryptInstance.CipherSecurity <> CS) or (not TCipher.CompareKey(FEncryptInstance.LastGenerateKey, k)) then DisposeObjectAndNil(FEncryptInstance); if FEncryptInstance = nil then begin - FEncryptInstance := CreateCipherClassFromBuffer(cs, k); + FEncryptInstance := CreateCipherClassFromBuffer(CS, k); FEncryptInstance.CBC := True; FEncryptInstance.ProcessTail := True; end; @@ -7458,11 +7550,11 @@ procedure TPeerIO.Encrypt(cs: TCipherSecurity; DataPtr: Pointer; Size: Cardinal; else begin if FDecryptInstance <> nil then - if (FDecryptInstance.CipherSecurity <> cs) or (not TCipher.CompareKey(FDecryptInstance.LastGenerateKey, k)) then + if (FDecryptInstance.CipherSecurity <> CS) or (not TCipher.CompareKey(FDecryptInstance.LastGenerateKey, k)) then DisposeObjectAndNil(FDecryptInstance); if FDecryptInstance = nil then begin - FDecryptInstance := CreateCipherClassFromBuffer(cs, k); + FDecryptInstance := CreateCipherClassFromBuffer(CS, k); FDecryptInstance.CBC := True; FDecryptInstance.ProcessTail := True; end; @@ -7472,12 +7564,12 @@ procedure TPeerIO.Encrypt(cs: TCipherSecurity; DataPtr: Pointer; Size: Cardinal; else begin if FOwnerFramework.FUsedParallelEncrypt then - SequEncryptCBC(cs, DataPtr, Size, k, enc, True) + SequEncryptCBC(CS, DataPtr, Size, k, enc, True) else - SequEncryptCBCWithDirect(cs, DataPtr, Size, k, enc, True); + SequEncryptCBCWithDirect(CS, DataPtr, Size, k, enc, True); end; - if cs <> TCipherSecurity.csNone then + if CS <> TCipherSecurity.csNone then AtomInc(FOwnerFramework.Statistics[TStatisticsType.stEncrypt]); end; @@ -7653,12 +7745,12 @@ function TPeerIO.WaitSendConsoleCmd(Cmd, ConsoleData: SystemString; Timeout: TTi Result := ''; end; -procedure TPeerIO.WaitSendStreamCmd(Cmd: SystemString; StreamData, ResultData: TDataFrameEngine; Timeout: TTimeTick); +procedure TPeerIO.WaitSendStreamCmd(Cmd: SystemString; StreamData, Result_: TDataFrameEngine; Timeout: TTimeTick); begin if FOwnerFramework.InheritsFrom(TCommunicationFrameworkServer) then - TCommunicationFrameworkServer(FOwnerFramework).WaitSendStreamCmd(Self, Cmd, StreamData, ResultData, Timeout) + TCommunicationFrameworkServer(FOwnerFramework).WaitSendStreamCmd(Self, Cmd, StreamData, Result_, Timeout) else if FOwnerFramework.InheritsFrom(TCommunicationFrameworkClient) then - TCommunicationFrameworkClient(FOwnerFramework).WaitSendStreamCmd(Cmd, StreamData, ResultData, Timeout); + TCommunicationFrameworkClient(FOwnerFramework).WaitSendStreamCmd(Cmd, StreamData, Result_, Timeout); end; procedure TPeerIO.SendBigStream(Cmd: SystemString; BigStream: TCoreClassStream; StartPos: Int64; DoneAutoFree: Boolean); @@ -7762,6 +7854,7 @@ procedure TAutomatedP2PVMClientBind.AddClient(Client: TCommunicationFrameworkWit p^.Client := Client; p^.IPV6 := IPV6; p^.Port := Port; + p^.RequestConnecting := False; Add(p); end; @@ -8130,12 +8223,12 @@ procedure TCommunicationFramework.BuildP2PAuthTokenResult_OnIOIDLE(Sender: TCore P_IO.OnVMBuildAuthModelResultIOProc := nil; end; -procedure TCommunicationFramework.CommandResult_BuildP2PAuthToken(Sender: TPeerIO; ResultData: TDataFrameEngine); +procedure TCommunicationFramework.CommandResult_BuildP2PAuthToken(Sender: TPeerIO; Result_: TDataFrameEngine); var i: Integer; arr: TDataFrameArrayInteger; begin - arr := ResultData.ReadArrayInteger(0); + arr := Result_.ReadArrayInteger(0); SetLength(Sender.FP2PAuthToken, arr.Count * 4); for i := 0 to arr.Count - 1 do PInteger(@Sender.FP2PAuthToken[i * 4])^ := arr[i]; @@ -8281,9 +8374,7 @@ procedure TCommunicationFramework.InitAutomatedP2PVM; procedure TCommunicationFramework.FreeAutomatedP2PVM; begin - FAutomatedP2PVMServiceBind.Clean; DisposeObject(FAutomatedP2PVMServiceBind); - FAutomatedP2PVMClientBind.Clean; DisposeObject(FAutomatedP2PVMClientBind); end; @@ -8308,11 +8399,13 @@ procedure TCommunicationFramework.DoAutomatedP2PVMClient_Request(IO_ID: Cardinal if P_IO.OwnerFramework <> Self then RaiseInfo('illegal.'); - P_IO.FAutomatedP2PVMClient_Connection_Sequence := 0; - P_IO.FAutomatedP2PVMClient_Connection_Sequence_Successed := 0; - - if FAutomatedP2PVMClient and (FAutomatedP2PVMClientBind.Count > 0) then - P_IO.BuildP2PAuthTokenIO_M({$IFDEF FPC}@{$ENDIF FPC}AutomatedP2PVMClient_BuildP2PAuthTokenResult) + if FAutomatedP2PVMClient then + begin + if P_IO.p2pVMTunnelReadyOk then + AutomatedP2PVMClient_OpenP2PVMTunnelResult(P_IO, True) + else + P_IO.BuildP2PAuthTokenIO_M({$IFDEF FPC}@{$ENDIF FPC}AutomatedP2PVMClient_BuildP2PAuthTokenResult); + end else Error('AutomatedP2PVMClient is false, on do AutomatedP2PVMClient_Request dont work.'); end; @@ -8327,6 +8420,7 @@ procedure TCommunicationFramework.AutomatedP2PVMClient_OpenP2PVMTunnelResult(P_I var p: PAutomatedP2PVMClientData; i: Integer; + IsRequestConnecting_: Boolean; begin if not VMauthState then begin @@ -8339,23 +8433,44 @@ procedure TCommunicationFramework.AutomatedP2PVMClient_OpenP2PVMTunnelResult(P_I for i := 0 to FAutomatedP2PVMClientBind.Count - 1 do P_IO.p2pVMTunnel.InstallLogicFramework(FAutomatedP2PVMClientBind[i]^.Client); - if (FAutomatedP2PVMClientBind.Count > P_IO.FAutomatedP2PVMClient_Connection_Sequence) then + for i := 0 to FAutomatedP2PVMClientBind.Count - 1 do begin - p := FAutomatedP2PVMClientBind[P_IO.FAutomatedP2PVMClient_Connection_Sequence]; - p^.Client.AsyncConnectM(p^.IPV6, p^.Port, nil, P_IO, {$IFDEF FPC}@{$ENDIF FPC}AutomatedP2PVMClient_ConnectionResult); - end - else + p := FAutomatedP2PVMClientBind[i]; + if (not p^.Client.Connected) and (not p^.RequestConnecting) then + begin + p^.Client.AsyncConnectM(p^.IPV6, p^.Port, p, P_IO, {$IFDEF FPC}@{$ENDIF FPC}AutomatedP2PVMClient_ConnectionResult); + p^.RequestConnecting := True; + end; + end; + + { check all connection done. } + IsRequestConnecting_ := False; + for i := 0 to FAutomatedP2PVMClientBind.Count - 1 do begin - { all connection done. } - AutomatedP2PVMClient_Done(P_IO); + p := FAutomatedP2PVMClientBind[i]; + if (p^.RequestConnecting) or (not p^.Client.Connected) then + IsRequestConnecting_ := True; end; + + if not IsRequestConnecting_ then + AutomatedP2PVMClient_Done(P_IO); end; procedure TCommunicationFramework.AutomatedP2PVMClient_ConnectionResult(Param1: Pointer; Param2: TObject; const ConnectionState: Boolean); var P_IO: TPeerIO; p: PAutomatedP2PVMClientData; + i: Integer; + IsRequestConnecting_: Boolean; begin + p := Param1; + p^.RequestConnecting := False; + if not ConnectionState then + begin + Error('Automated P2PVM connection failed.'); + exit; + end; + if not FPeerIO_HashPool.ExistsObject(Param2) then begin Error('Automated P2PVM IO failed.'); @@ -8363,19 +8478,27 @@ procedure TCommunicationFramework.AutomatedP2PVMClient_ConnectionResult(Param1: end; P_IO := TPeerIO(Param2); - inc(P_IO.FAutomatedP2PVMClient_Connection_Sequence); - if ConnectionState then - inc(P_IO.FAutomatedP2PVMClient_Connection_Sequence_Successed); - if (FAutomatedP2PVMClientBind.Count > P_IO.FAutomatedP2PVMClient_Connection_Sequence) then + for i := 0 to FAutomatedP2PVMClientBind.Count - 1 do begin - p := FAutomatedP2PVMClientBind[P_IO.FAutomatedP2PVMClient_Connection_Sequence]; - p^.Client.AsyncConnectM(p^.IPV6, p^.Port, nil, P_IO, {$IFDEF FPC}@{$ENDIF FPC}AutomatedP2PVMClient_ConnectionResult); - end - else + p := FAutomatedP2PVMClientBind[i]; + if (not p^.Client.Connected) and (not p^.RequestConnecting) then + begin + p^.Client.AsyncConnectM(p^.IPV6, p^.Port, p, P_IO, {$IFDEF FPC}@{$ENDIF FPC}AutomatedP2PVMClient_ConnectionResult); + p^.RequestConnecting := True; + end; + end; + + { check all connection done. } + IsRequestConnecting_ := False; + for i := 0 to FAutomatedP2PVMClientBind.Count - 1 do begin - { all connection done. } - AutomatedP2PVMClient_Done(P_IO); + p := FAutomatedP2PVMClientBind[i]; + if (p^.RequestConnecting) or (not p^.Client.Connected) then + IsRequestConnecting_ := True; end; + + if not IsRequestConnecting_ then + AutomatedP2PVMClient_Done(P_IO); end; procedure TCommunicationFramework.AutomatedP2PVMClient_Delay_Done(Sender: TNPostExecute); @@ -8492,12 +8615,13 @@ constructor TCommunicationFramework.Create(HashPoolSize: Integer); FBigStreamSwapSpaceTriggerSize := C_BigStream_SwapSpace_Trigger; FEnabledAtomicLockAndMultiThread := True; FTimeOutKeepAlive := True; - FQuietMode := False; + FQuietMode := {$IFDEF Communication_QuietMode}True{$ELSE Communication_QuietMode}False{$ENDIF Communication_QuietMode}; SetLength(FCipherSecurityArray, 0); FSendDataCompressed := False; FCompleteBufferCompressed := False; FHashSecurity := THashSecurity.hsNone; FMaxCompleteBufferSize := C_MaxCompleteBufferSize; + FCompleteBufferCompressionCondition := C_CompleteBufferCompressionCondition; FPeerIOUserDefineClass := TPeerIOUserDefine; FPeerIOUserSpecialClass := TPeerIOUserSpecial; @@ -8599,7 +8723,7 @@ procedure TCommunicationFramework.p2pVMTunnelAuth(Sender: TPeerIO; const Token: begin if FVMInterface <> nil then FVMInterface.p2pVMTunnelAuth(Sender, Token, Accept); - if (FAutomatedP2PVMService) and (FAutomatedP2PVMServiceBind.Count > 0) then + if (not Accept) and (FAutomatedP2PVMService) then Accept := CompareQuantumCryptographyPassword(FAutomatedP2PVMAuthToken, Token); end; @@ -8637,14 +8761,42 @@ procedure TCommunicationFramework.p2pVMTunnelClose(Sender: TPeerIO; p2pVMTunnel: end; function TCommunicationFramework.AutomatedP2PVMClientConnectionDone(P_IO: TPeerIO): Boolean; +var + i: Integer; + p: PAutomatedP2PVMClientData; begin - Result := (P_IO <> nil) and (P_IO.FAutomatedP2PVMClient_Connection_Sequence_Successed = FAutomatedP2PVMClientBind.Count); + Result := False; + if P_IO = nil then + exit; + if not P_IO.p2pVMTunnelReadyOk then + exit; + { check all connection done. } + for i := 0 to FAutomatedP2PVMClientBind.Count - 1 do + begin + p := FAutomatedP2PVMClientBind[i]; + if (p^.RequestConnecting) or (not p^.Client.Connected) then + exit; + end; + Result := True; +end; + +function TCommunicationFramework.AutomatedP2PVMClientConnectionDone(): Boolean; +begin + if FFrameworkIsClient and (TCommunicationFrameworkClient(Self).ClientIO <> nil) then + Result := AutomatedP2PVMClientConnectionDone(TCommunicationFrameworkClient(Self).ClientIO) + else + Result := False; end; procedure TCommunicationFramework.AutomatedP2PVM_Open(P_IO: TPeerIO); begin - if FAutomatedP2PVMClient and (FAutomatedP2PVMClientBind.Count > 0) then - FPostProgress.PostExecuteM(FAutomatedP2PVMClientDelayBoot, {$IFDEF FPC}@{$ENDIF FPC}DoAutomatedP2PVMClient_DelayRequest).Data3 := P_IO.ID; + FPostProgress.PostExecuteM(FAutomatedP2PVMClientDelayBoot, {$IFDEF FPC}@{$ENDIF FPC}DoAutomatedP2PVMClient_DelayRequest).Data3 := P_IO.ID; +end; + +procedure TCommunicationFramework.AutomatedP2PVM_Open(); +begin + if FFrameworkIsClient and (TCommunicationFrameworkClient(Self).ClientIO <> nil) then + AutomatedP2PVM_Open(TCommunicationFrameworkClient(Self).ClientIO); end; procedure TCommunicationFramework.AutomatedP2PVM_Open_C(P_IO: TPeerIO; const OnResult: TIOStateCall); @@ -8672,10 +8824,45 @@ procedure TCommunicationFramework.AutomatedP2PVM_Open_P(P_IO: TPeerIO; const OnR end; procedure TCommunicationFramework.AutomatedP2PVM_Close(P_IO: TPeerIO); +var + i: Integer; + p: PAutomatedP2PVMClientData; begin + if P_IO = nil then + exit; + + if FAutomatedP2PVMClient then + for i := 0 to FAutomatedP2PVMClientBind.Count - 1 do + begin + p := FAutomatedP2PVMClientBind[i]; + if p^.Client.Connected then + begin + p^.Client.Disconnect; + P_IO.p2pVMTunnel.UninstallLogicFramework(p^.Client); + end; + end; P_IO.CloseP2PVMTunnel; end; +procedure TCommunicationFramework.AutomatedP2PVM_Close(); +begin + if FFrameworkIsClient and (TCommunicationFrameworkClient(Self).ClientIO <> nil) then + AutomatedP2PVM_Close(TCommunicationFrameworkClient(Self).ClientIO); +end; + +function TCommunicationFramework.p2pVMTunnelReadyOk(P_IO: TPeerIO): Boolean; +begin + Result := (P_IO <> nil) and P_IO.p2pVMTunnelReadyOk; +end; + +function TCommunicationFramework.p2pVMTunnelReadyOk(): Boolean; +begin + if FFrameworkIsClient and (TCommunicationFrameworkClient(Self).ClientIO <> nil) then + Result := p2pVMTunnelReadyOk(TCommunicationFrameworkClient(Self).ClientIO) + else + Result := False; +end; + procedure TCommunicationFramework.SwitchMaxPerformance; begin FFastEncrypt := True; @@ -9040,6 +9227,25 @@ procedure TCommunicationFramework.ErrorParam(v: SystemString; Args: SystemString DoError(Format(v, [Args])); end; +procedure TCommunicationFramework.PrintError(const v: SystemString; const Args: array of const); +begin + try + Error(Format(v, Args)); + except + Error('print error. ' + v); + end; +end; + +procedure TCommunicationFramework.PrintError(const v: SystemString); +begin + DoError(v); +end; + +procedure TCommunicationFramework.PrintErrorParam(v, Args: SystemString); +begin + DoError(Format(v, [Args])); +end; + procedure TCommunicationFramework.Warning(const v: SystemString); begin DoWarning(v); @@ -9050,6 +9256,16 @@ procedure TCommunicationFramework.WarningParam(v: SystemString; Args: SystemStri DoWarning(Format(v, [Args])); end; +procedure TCommunicationFramework.PrintWarning(const v: SystemString); +begin + DoWarning(v); +end; + +procedure TCommunicationFramework.PrintWarningParam(v, Args: SystemString); +begin + DoWarning(Format(v, [Args])); +end; + function TCommunicationFramework.DeleteRegistedCMD(Cmd: SystemString): Boolean; begin Result := FCommandList.Exists(Cmd); @@ -9391,6 +9607,30 @@ function TCommunicationFramework.GetRandomCipherSecurity: TCipherSecurity; Result := csNone; end; +procedure TCommunicationFramework.CopyParamFrom(Source: TCommunicationFramework); +begin + FastEncrypt := Source.FastEncrypt; + UsedParallelEncrypt := Source.UsedParallelEncrypt; + SyncOnResult := Source.SyncOnResult; + SyncOnCompleteBuffer := Source.SyncOnCompleteBuffer; + BigStreamMemorySwapSpace := Source.BigStreamMemorySwapSpace; + BigStreamSwapSpaceTriggerSize := Source.BigStreamSwapSpaceTriggerSize; + EnabledAtomicLockAndMultiThread := Source.EnabledAtomicLockAndMultiThread; + TimeOutKeepAlive := Source.TimeOutKeepAlive; + QuietMode := Source.QuietMode; + IdleTimeOut := Source.IdleTimeOut; + SendDataCompressed := Source.SendDataCompressed; + CompleteBufferCompressed := Source.CompleteBufferCompressed; + MaxCompleteBufferSize := Source.MaxCompleteBufferSize; + CompleteBufferCompressionCondition := Source.CompleteBufferCompressionCondition; + ProgressMaxDelay := Source.ProgressMaxDelay; +end; + +procedure TCommunicationFramework.CopyParamTo(Dest: TCommunicationFramework); +begin + Dest.CopyParamFrom(Self); +end; + function TCommunicationFrameworkServer.CanExecuteCommand(Sender: TPeerIO; Cmd: SystemString): Boolean; begin if IsSystemCMD(Cmd) then @@ -10141,7 +10381,7 @@ function TCommunicationFrameworkServer.WaitSendConsoleCmd(P_IO: TPeerIO; const C P_IO.FWaitSendBusy := False; end; -procedure TCommunicationFrameworkServer.WaitSendStreamCmd(P_IO: TPeerIO; const Cmd: SystemString; StreamData, ResultData: TDataFrameEngine; Timeout: TTimeTick); +procedure TCommunicationFrameworkServer.WaitSendStreamCmd(P_IO: TPeerIO; const Cmd: SystemString; StreamData, Result_: TDataFrameEngine; Timeout: TTimeTick); var waitIntf: TWaitSendStreamCmdIntf; timetick: TTimeTick; @@ -10185,10 +10425,10 @@ procedure TCommunicationFrameworkServer.WaitSendStreamCmd(P_IO: TPeerIO; const C if waitIntf.Done then begin - if (ResultData <> nil) and (not waitIntf.Failed) then + if (Result_ <> nil) and (not waitIntf.Failed) then begin - ResultData.Assign(waitIntf.NewResult); - ResultData.Reader.index := 0; + Result_.Assign(waitIntf.NewResult); + Result_.Reader.index := 0; end; DisposeObject(waitIntf); end; @@ -10381,9 +10621,9 @@ function TCommunicationFrameworkServer.WaitSendConsoleCmd(IO_ID: Cardinal; const Result := WaitSendConsoleCmd(PeerIO[IO_ID], Cmd, ConsoleData, Timeout); end; -procedure TCommunicationFrameworkServer.WaitSendStreamCmd(IO_ID: Cardinal; const Cmd: SystemString; StreamData, ResultData: TDataFrameEngine; Timeout: TTimeTick); +procedure TCommunicationFrameworkServer.WaitSendStreamCmd(IO_ID: Cardinal; const Cmd: SystemString; StreamData, Result_: TDataFrameEngine; Timeout: TTimeTick); begin - WaitSendStreamCmd(PeerIO[IO_ID], Cmd, StreamData, ResultData, Timeout); + WaitSendStreamCmd(PeerIO[IO_ID], Cmd, StreamData, Result_, Timeout); end; procedure TCommunicationFrameworkServer.SendBigStream(IO_ID: Cardinal; const Cmd: SystemString; BigStream: TCoreClassStream; StartPos: Int64; DoneAutoFree: Boolean); @@ -10544,49 +10784,50 @@ procedure TCommunicationFramework_ServerState.Reset; ProgressMaxDelay := 0; end; -procedure TCommunicationFrameworkClient.StreamResult_CipherModel(Sender: TPeerIO; ResultData: TDataFrameEngine); +procedure TCommunicationFrameworkClient.StreamResult_CipherModel(Sender: TPeerIO; Result_: TDataFrameEngine); var arr: TDataFrameArrayByte; begin - if ResultData.Count > 0 then + if Result_.Count > 0 then begin + FReponseTime := GetTimeTick - FRequestTime; { index 0: my remote id } - Sender.ID := ResultData.Reader.ReadCardinal; + Sender.ID := Result_.Reader.ReadCardinal; { index 1: Encrypt } - Sender.SendCipherSecurity := TCipherSecurity(ResultData.Reader.ReadByte); + Sender.SendCipherSecurity := TCipherSecurity(Result_.Reader.ReadByte); { index 2: Encrypt CipherKey } - arr := ResultData.Reader.ReadArrayByte; + arr := Result_.Reader.ReadArrayByte; SetLength(Sender.FCipherKey, arr.Count); arr.GetBuff(@Sender.FCipherKey[0]); { index 3: remote inited time md5 } FServerState.Reset(); - if ResultData.Reader.IsEnd then + if Result_.Reader.IsEnd then begin Warning('protocol version upgrade zserver from https://github.com/PassByYou888/ZServer4D'); end else begin - FInitedTimeMD5 := ResultData.Reader.ReadMD5(); - if ResultData.Reader.IsEnd then + FInitedTimeMD5 := Result_.Reader.ReadMD5(); + if Result_.Reader.IsEnd then begin Warning('protocol version upgrade zserver from https://github.com/PassByYou888/ZServer4D'); end else begin - FServerState.UsedParallelEncrypt := ResultData.Reader.ReadBool(); - FServerState.SyncOnResult := ResultData.Reader.ReadBool(); - FServerState.SyncOnCompleteBuffer := ResultData.Reader.ReadBool(); - FServerState.EnabledAtomicLockAndMultiThread := ResultData.Reader.ReadBool(); - FServerState.TimeOutKeepAlive := ResultData.Reader.ReadBool(); - FServerState.QuietMode := ResultData.Reader.ReadBool(); - FServerState.IdleTimeOut := ResultData.Reader.ReadUInt64(); - FServerState.SendDataCompressed := ResultData.Reader.ReadBool(); - FServerState.CompleteBufferCompressed := ResultData.Reader.ReadBool(); - FServerState.MaxCompleteBufferSize := ResultData.Reader.ReadCardinal(); - FServerState.ProgressMaxDelay := ResultData.Reader.ReadUInt64(); + FServerState.UsedParallelEncrypt := Result_.Reader.ReadBool(); + FServerState.SyncOnResult := Result_.Reader.ReadBool(); + FServerState.SyncOnCompleteBuffer := Result_.Reader.ReadBool(); + FServerState.EnabledAtomicLockAndMultiThread := Result_.Reader.ReadBool(); + FServerState.TimeOutKeepAlive := Result_.Reader.ReadBool(); + FServerState.QuietMode := Result_.Reader.ReadBool(); + FServerState.IdleTimeOut := Result_.Reader.ReadUInt64(); + FServerState.SendDataCompressed := Result_.Reader.ReadBool(); + FServerState.CompleteBufferCompressed := Result_.Reader.ReadBool(); + FServerState.MaxCompleteBufferSize := Result_.Reader.ReadCardinal(); + FServerState.ProgressMaxDelay := Result_.Reader.ReadUInt64(); end end; @@ -10597,7 +10838,9 @@ procedure TCommunicationFrameworkClient.StreamResult_CipherModel(Sender: TPeerIO CipherModelDone; - AutomatedP2PVM_Open(Sender); + if (FAutomatedP2PVMClient and (FAutomatedP2PVMClientBind.Count > 0)) or + (FAutomatedP2PVMService and (FAutomatedP2PVMServiceBind.Count > 0)) then + AutomatedP2PVM_Open(Sender); end else begin @@ -10648,6 +10891,7 @@ procedure TCommunicationFrameworkClient.DoConnected(Sender: TPeerIO); except end; end; + FRequestTime := GetTimeTick; end else begin @@ -10724,7 +10968,7 @@ procedure TCommunicationFrameworkClient.FillCustomBuffer(Sender: TPeerIO; const end; end; -procedure TCommunicationFrameworkClient.ConsoleResult_Wait(Sender: TPeerIO; ResultData: SystemString); +procedure TCommunicationFrameworkClient.ConsoleResult_Wait(Sender: TPeerIO; Result_: SystemString); begin if FWaiting then begin @@ -10749,11 +10993,18 @@ procedure TCommunicationFrameworkClient.ConsoleResult_Wait(Sender: TPeerIO; Resu function TCommunicationFrameworkClient.GetWaitTimeout(const t: TTimeTick): TTimeTick; begin if t = 0 then - Result := 1000 * 60 * 5 + Result := 1000 * 60 * 30 else Result := t; end; +procedure TCommunicationFrameworkClient.Do_IO_IDLE_FreeSelf(Data_: TCoreClassObject); +begin + if Self is TCommunicationFrameworkWithP2PVM_Client then + TCommunicationFrameworkWithP2PVM_Client(Self).CloneClientAutoFree := False; + DelayFreeObject(1.0, Self, Data_); +end; + constructor TCommunicationFrameworkClient.Create; begin inherited Create(1); @@ -10779,6 +11030,8 @@ constructor TCommunicationFrameworkClient.Create; FIgnoreProcessConnectedAndDisconnect := False; FLastConnectIsSuccessed := False; + FRequestTime := 0; + FReponseTime := 0; FOnWaitResultCall := nil; FOnWaitResultMethod := nil; @@ -10803,6 +11056,11 @@ destructor TCommunicationFrameworkClient.Destroy; inherited Destroy; end; +procedure TCommunicationFrameworkClient.DelayFreeSelf; +begin + DelayFreeObject(1.0, Self, nil); +end; + procedure TCommunicationFrameworkClient.IO_IDLE_TraceC(data: TCoreClassObject; const OnNotify: TDataNotifyCall); begin if ClientIO = nil then @@ -10827,6 +11085,11 @@ procedure TCommunicationFrameworkClient.IO_IDLE_TraceP(data: TCoreClassObject; c ClientIO.IO_IDLE_TraceP(data, OnNotify); end; +procedure TCommunicationFrameworkClient.IO_IDLE_Trace_And_FreeSelf(Additional_Object_: TCoreClassObject); +begin + IO_IDLE_TraceM(Additional_Object_, {$IFDEF FPC}@{$ENDIF FPC}Do_IO_IDLE_FreeSelf); +end; + procedure TCommunicationFrameworkClient.OnReceiveBuffer(const buffer: PByte; const Size: NativeInt; var FillDone: Boolean); begin end; @@ -11042,7 +11305,7 @@ procedure TCommunicationFrameworkClient.Disconnect; begin end; -procedure TCommunicationFrameworkClient.DelayClose; +procedure TCommunicationFrameworkClient.DelayCloseIO; begin try if ClientIO <> nil then @@ -11051,7 +11314,7 @@ procedure TCommunicationFrameworkClient.DelayClose; end; end; -procedure TCommunicationFrameworkClient.DelayClose(const t: Double); +procedure TCommunicationFrameworkClient.DelayCloseIO(const t: Double); begin try if ClientIO <> nil then @@ -11702,7 +11965,7 @@ function TCommunicationFrameworkClient.WaitSendConsoleCmd(Cmd, ConsoleData: Syst ClientIO.FWaitSendBusy := False; end; -procedure TCommunicationFrameworkClient.WaitSendStreamCmd(Cmd: SystemString; StreamData, ResultData: TDataFrameEngine; Timeout: TTimeTick); +procedure TCommunicationFrameworkClient.WaitSendStreamCmd(Cmd: SystemString; StreamData, Result_: TDataFrameEngine; Timeout: TTimeTick); var waitIntf: TWaitSendStreamCmdIntf; timetick: TTimeTick; @@ -11755,10 +12018,10 @@ procedure TCommunicationFrameworkClient.WaitSendStreamCmd(Cmd: SystemString; Str if waitIntf.Done then begin - if (ResultData <> nil) and (not waitIntf.Failed) then + if (Result_ <> nil) and (not waitIntf.Failed) then begin - ResultData.Assign(waitIntf.NewResult); - ResultData.Reader.index := 0; + Result_.Assign(waitIntf.NewResult); + Result_.Reader.index := 0; end; DisposeObject(waitIntf); end; @@ -11931,20 +12194,24 @@ procedure TP2PVM_PeerIO.CreateAfter; FDestroySyncRemote := True; if not FOwnerFramework.FQuietMode then - Print('VM-IO Create %d', [ID]); + FOwnerFramework.Print('VM-IO Create %d', [ID]); end; destructor TP2PVM_PeerIO.Destroy; var i: Integer; c_: TCommunicationFrameworkWithP2PVM_Client; + LID: Cardinal; begin + LID := 0; if Connected then begin if (FDestroySyncRemote) and (FLinkVM <> nil) then FLinkVM.SendDisconnect(Remote_frameworkID, Remote_p2pID); + + LID := ID; if not FOwnerFramework.FQuietMode then - Print('VMClientIO %d disconnect', [ID]); + FOwnerFramework.Print('VMClientIO %d disconnect', [LID]); if FOwnerFramework is TCommunicationFrameworkWithP2PVM_Client then begin c_ := TCommunicationFrameworkWithP2PVM_Client(FOwnerFramework); @@ -11963,7 +12230,7 @@ destructor TP2PVM_PeerIO.Destroy; DisposeObject(FRealSendBuff); if not FOwnerFramework.FQuietMode then - Print('VM-IO Destroy %d', [ID]); + FOwnerFramework.Print('VM-IO Destroy %d', [LID]); inherited Destroy; end; @@ -12033,6 +12300,8 @@ procedure TP2PVM_PeerIO.WriteBufferClose; function TP2PVM_PeerIO.GetPeerIP: SystemString; begin Result := IPv6ToStr(FIP).Text; + if (FLinkVM <> nil) and (FLinkVM.FPhysicsIO <> nil) then + Result := FLinkVM.FPhysicsIO.PeerIP + '(' + Result + ')'; end; function TP2PVM_PeerIO.WriteBufferEmpty: Boolean; @@ -12281,7 +12550,7 @@ procedure TCommunicationFrameworkWithP2PVM_Server.StopService; CloseAllClient; end; -function TCommunicationFrameworkWithP2PVM_Server.StartService(Host: SystemString; Port: Word): Boolean; +function TCommunicationFrameworkWithP2PVM_Server.StartService(Host_: SystemString; Port: Word): Boolean; var IPV6: TIPV6; SI: Cardinal; @@ -12291,10 +12560,14 @@ function TCommunicationFrameworkWithP2PVM_Server.StartService(Host: SystemString begin Result := False; - IPV6 := StrToIPv6(Host, Result, SI); - - if not Result then - exit; + if umlTrimSpace(Host_).L = 0 then + IPV6 := MakeRandomIPV6() + else + begin + IPV6 := StrToIPv6(Host_, Result, SI); + if not Result then + exit; + end; LP := FindListen(IPV6, Port); if LP = nil then @@ -12336,7 +12609,7 @@ function TCommunicationFrameworkWithP2PVM_Server.WaitSendConsoleCmd(P_IO: TPeerI RaiseInfo('WaitSend no Suppport VM server'); end; -procedure TCommunicationFrameworkWithP2PVM_Server.WaitSendStreamCmd(P_IO: TPeerIO; const Cmd: SystemString; StreamData, ResultData: TDataFrameEngine; Timeout: TTimeTick); +procedure TCommunicationFrameworkWithP2PVM_Server.WaitSendStreamCmd(P_IO: TPeerIO; const Cmd: SystemString; StreamData, Result_: TDataFrameEngine; Timeout: TTimeTick); begin RaiseInfo('WaitSend no Suppport VM server'); end; @@ -12407,9 +12680,14 @@ destructor TCommunicationFrameworkWithP2PVM_Client.Destroy; while i < FP2PVM_ClonePool.Count do begin if FP2PVM_ClonePool[i].FP2PVM_CloneClientAutoFree then - DisposeObject(FP2PVM_ClonePool[i]) + begin + DisposeObject(FP2PVM_ClonePool[i]); + end else + begin + FP2PVM_ClonePool[i].FP2PVM_CloneOwner := nil; inc(i); + end; end; DisposeObject(FP2PVM_ClonePool); @@ -12432,14 +12710,7 @@ function TCommunicationFrameworkWithP2PVM_Client.CloneConnectC(OnResult: TP2PVM_ bridge_ := TP2PVM_CloneConnectEventBridge.Create(Self); bridge_.NewClient := TCommunicationFrameworkWithP2PVM_Client.Create; // copy parameter - bridge_.NewClient.FastEncrypt := FastEncrypt; - bridge_.NewClient.TimeOutKeepAlive := TimeOutKeepAlive; - bridge_.NewClient.TimeOutIDLE := TimeOutIDLE; - bridge_.NewClient.SendDataCompressed := SendDataCompressed; - bridge_.NewClient.CompleteBufferCompressed := CompleteBufferCompressed; - bridge_.NewClient.SyncOnResult := SyncOnResult; - bridge_.NewClient.SyncOnCompleteBuffer := SyncOnCompleteBuffer; - bridge_.NewClient.QuietMode := QuietMode; + bridge_.NewClient.CopyParamFrom(Self); // init event bridge_.OnResultC := OnResult; bridge_.NewClient.FP2PVM_CloneOwner := Self; @@ -12461,14 +12732,7 @@ function TCommunicationFrameworkWithP2PVM_Client.CloneConnectM(OnResult: TP2PVM_ bridge_ := TP2PVM_CloneConnectEventBridge.Create(Self); bridge_.NewClient := TCommunicationFrameworkWithP2PVM_Client.Create; // copy parameter - bridge_.NewClient.FastEncrypt := FastEncrypt; - bridge_.NewClient.TimeOutKeepAlive := TimeOutKeepAlive; - bridge_.NewClient.TimeOutIDLE := TimeOutIDLE; - bridge_.NewClient.SendDataCompressed := SendDataCompressed; - bridge_.NewClient.CompleteBufferCompressed := CompleteBufferCompressed; - bridge_.NewClient.SyncOnResult := SyncOnResult; - bridge_.NewClient.SyncOnCompleteBuffer := SyncOnCompleteBuffer; - bridge_.NewClient.QuietMode := QuietMode; + bridge_.NewClient.CopyParamFrom(Self); // init event bridge_.OnResultM := OnResult; bridge_.NewClient.FP2PVM_CloneOwner := Self; @@ -12490,14 +12754,7 @@ function TCommunicationFrameworkWithP2PVM_Client.CloneConnectP(OnResult: TP2PVM_ bridge_ := TP2PVM_CloneConnectEventBridge.Create(Self); bridge_.NewClient := TCommunicationFrameworkWithP2PVM_Client.Create; // copy parameter - bridge_.NewClient.FastEncrypt := FastEncrypt; - bridge_.NewClient.TimeOutKeepAlive := TimeOutKeepAlive; - bridge_.NewClient.TimeOutIDLE := TimeOutIDLE; - bridge_.NewClient.SendDataCompressed := SendDataCompressed; - bridge_.NewClient.CompleteBufferCompressed := CompleteBufferCompressed; - bridge_.NewClient.SyncOnResult := SyncOnResult; - bridge_.NewClient.SyncOnCompleteBuffer := SyncOnCompleteBuffer; - bridge_.NewClient.QuietMode := QuietMode; + bridge_.NewClient.CopyParamFrom(Self); // init event bridge_.OnResultP := OnResult; bridge_.NewClient.FP2PVM_CloneOwner := Self; @@ -12580,7 +12837,9 @@ procedure TCommunicationFrameworkWithP2PVM_Client.Progress; for i := 0 to FP2PVM_ClonePool.Count - 1 do begin if FP2PVM_ClonePool[i].FP2PVM_CloneClientAutoProgress then + begin FP2PVM_ClonePool[i].Progress; + end; end; end; @@ -12614,16 +12873,14 @@ procedure TCommunicationFrameworkWithP2PVM_Client.AsyncConnect(addr: SystemStrin FOnP2PVMAsyncConnectNotifyProc := nil; if (FLinkVM = nil) or (FLinkVM.FPhysicsIO = nil) then begin - if not FQuietMode then - Error('no VM connect'); + Error('no VM connect'); TriggerDoConnectFailed; exit; end; if not FLinkVM.WasAuthed then begin - if not FQuietMode then - Error('VM no auth'); + Error('VM no auth'); TriggerDoConnectFailed; exit; end; @@ -12632,8 +12889,7 @@ procedure TCommunicationFrameworkWithP2PVM_Client.AsyncConnect(addr: SystemStrin if not r then begin - if not FQuietMode then - Error('ipv6 format error! %s', [addr]); + Error('ipv6 format error! %s', [addr]); TriggerDoConnectFailed; exit; end; @@ -12641,8 +12897,7 @@ procedure TCommunicationFrameworkWithP2PVM_Client.AsyncConnect(addr: SystemStrin p := FLinkVM.FindListen(IPV6, Port); if p = nil then begin - if not FQuietMode then - Error('no remote listen %s port:%d', [IPv6ToStr(IPV6).Text, Port]); + Error('no remote listen %s port:%d', [IPv6ToStr(IPV6).Text, Port]); TriggerDoConnectFailed; exit; end; @@ -12672,16 +12927,14 @@ procedure TCommunicationFrameworkWithP2PVM_Client.AsyncConnectC(addr: SystemStri FOnP2PVMAsyncConnectNotifyProc := nil; if (FLinkVM = nil) or (FLinkVM.FPhysicsIO = nil) then begin - if not FQuietMode then - Error('no VM connect'); + Error('no VM connect'); TriggerDoConnectFailed; exit; end; if not FLinkVM.WasAuthed then begin - if not FQuietMode then - Error('VM no auth'); + Error('VM no auth'); TriggerDoConnectFailed; exit; end; @@ -12690,8 +12943,7 @@ procedure TCommunicationFrameworkWithP2PVM_Client.AsyncConnectC(addr: SystemStri if not r then begin - if not FQuietMode then - Error('ipv6 format error! %s', [addr]); + Error('ipv6 format error! %s', [addr]); TriggerDoConnectFailed; exit; end; @@ -12699,8 +12951,7 @@ procedure TCommunicationFrameworkWithP2PVM_Client.AsyncConnectC(addr: SystemStri p := FLinkVM.FindListen(IPV6, Port); if p = nil then begin - if not FQuietMode then - Error('no remote listen %s port:%d', [IPv6ToStr(IPV6).Text, Port]); + Error('no remote listen %s port:%d', [IPv6ToStr(IPV6).Text, Port]); TriggerDoConnectFailed; exit; end; @@ -12731,16 +12982,14 @@ procedure TCommunicationFrameworkWithP2PVM_Client.AsyncConnectM(addr: SystemStri if (FLinkVM = nil) or (FLinkVM.FPhysicsIO = nil) then begin - if not FQuietMode then - Error('no VM connect'); + Error('no VM connect'); TriggerDoConnectFailed; exit; end; if not FLinkVM.WasAuthed then begin - if not FQuietMode then - Error('VM no auth'); + Error('VM no auth'); TriggerDoConnectFailed; exit; end; @@ -12749,8 +12998,7 @@ procedure TCommunicationFrameworkWithP2PVM_Client.AsyncConnectM(addr: SystemStri if not r then begin - if not FQuietMode then - Error('ipv6 format error! %s', [addr]); + Error('ipv6 format error! %s', [addr]); TriggerDoConnectFailed; exit; end; @@ -12758,8 +13006,7 @@ procedure TCommunicationFrameworkWithP2PVM_Client.AsyncConnectM(addr: SystemStri p := FLinkVM.FindListen(IPV6, Port); if p = nil then begin - if not FQuietMode then - Error('no remote listen %s port:%d', [IPv6ToStr(IPV6).Text, Port]); + Error('no remote listen %s port:%d', [IPv6ToStr(IPV6).Text, Port]); TriggerDoConnectFailed; exit; end; @@ -12790,16 +13037,14 @@ procedure TCommunicationFrameworkWithP2PVM_Client.AsyncConnectP(addr: SystemStri if (FLinkVM = nil) or (FLinkVM.FPhysicsIO = nil) then begin - if not FQuietMode then - Error('no VM connect'); + Error('no VM connect'); TriggerDoConnectFailed; exit; end; if not FLinkVM.WasAuthed then begin - if not FQuietMode then - Error('VM no auth'); + Error('VM no auth'); TriggerDoConnectFailed; exit; end; @@ -12808,8 +13053,7 @@ procedure TCommunicationFrameworkWithP2PVM_Client.AsyncConnectP(addr: SystemStri if not r then begin - if not FQuietMode then - Error('ipv6 format error! %s', [addr]); + Error('ipv6 format error! %s', [addr]); TriggerDoConnectFailed; exit; end; @@ -12817,8 +13061,7 @@ procedure TCommunicationFrameworkWithP2PVM_Client.AsyncConnectP(addr: SystemStri p := FLinkVM.FindListen(IPV6, Port); if p = nil then begin - if not FQuietMode then - Error('no remote listen %s port:%d', [IPv6ToStr(IPV6).Text, Port]); + Error('no remote listen %s port:%d', [IPv6ToStr(IPV6).Text, Port]); TriggerDoConnectFailed; exit; end; @@ -12849,15 +13092,13 @@ function TCommunicationFrameworkWithP2PVM_Client.Connect(addr: SystemString; Por FOnP2PVMAsyncConnectNotifyProc := nil; if (FLinkVM = nil) or (FLinkVM.FPhysicsIO = nil) then begin - if not FQuietMode then - Error('no VM connect'); + Error('no VM connect'); exit; end; if not FLinkVM.WasAuthed then begin - if not FQuietMode then - Error('VM no auth'); + Error('VM no auth'); exit; end; @@ -12865,16 +13106,14 @@ function TCommunicationFrameworkWithP2PVM_Client.Connect(addr: SystemString; Por if not Result then begin - if not FQuietMode then - Error('ipv6 format error! %s', [addr]); + Error('ipv6 format error! %s', [addr]); exit; end; p := FLinkVM.FindListen(IPV6, Port); if p = nil then begin - if not FQuietMode then - Error('no remote listen %s port:%d', [IPv6ToStr(IPV6).Text, Port]); + Error('no remote listen %s port:%d', [IPv6ToStr(IPV6).Text, Port]); exit; end; @@ -13041,7 +13280,7 @@ procedure TCommunicationFrameworkWithP2PVM.SyncProcessReceiveBuff; FReceiveStream := sourStream; if not FQuietMode then - DoStatus('VM Authentication Success'); + FPhysicsIO.Print('VM Authentication Success'); end else if FAuthWaiting then exit @@ -13101,9 +13340,9 @@ procedure TCommunicationFrameworkWithP2PVM.SyncProcessReceiveBuff; ReceivedLogicFragmentData(fPk.FrameworkID, fPk.p2pID, fPk.buff, fPk.buffSiz) else if fPk.pkType = C_p2pVM_PhysicsFragmentData then ReceivedPhysicsFragmentData(fPk.FrameworkID, fPk.p2pID, fPk.buff, fPk.buffSiz) - else if not FQuietMode then + else begin - DoStatus('VM protocol header errror'); + FPhysicsIO.PrintError('VM protocol header errror'); DoStatus(@fPk, SizeOf(fPk), 40); end; @@ -13124,7 +13363,7 @@ procedure TCommunicationFrameworkWithP2PVM.SyncProcessReceiveBuff; if p64 > 0 then begin - sourStream := TMemoryStream64.Create; + sourStream := TMemoryStream64.CustomCreate(8192); FReceiveStream.Position := p64; if FReceiveStream.Size - FReceiveStream.Position > 0 then sourStream.CopyFrom(FReceiveStream, FReceiveStream.Size - FReceiveStream.Position); @@ -13171,8 +13410,7 @@ procedure TCommunicationFrameworkWithP2PVM.ReceivedEcho(const FrameworkID, p2pID begin if siz <> SizeOf(TBuf) then begin - if not FQuietMode then - DoStatus('echoing protocol with buffer error!'); + FPhysicsIO.PrintError('echoing protocol with buffer error!'); if buff <> nil then if not FQuietMode then DoStatus(buff, siz, 40); @@ -13223,8 +13461,7 @@ procedure TCommunicationFrameworkWithP2PVM.ReceivedListen(const FrameworkID, p2p begin if siz <> SizeOf(TBuf) then begin - if not FQuietMode then - DoStatus('listen protocol with buffer error!'); + FPhysicsIO.PrintError('listen protocol with buffer error!'); if buff <> nil then if not FQuietMode then DoStatus(buff, siz, 40); @@ -13237,8 +13474,7 @@ procedure TCommunicationFrameworkWithP2PVM.ReceivedListen(const FrameworkID, p2p if p2pID <> 0 then begin - if not FQuietMode then - DoStatus('listen protocol error! IO ID:%d', [p2pID]); + FPhysicsIO.PrintError('listen protocol error! IO ID:%d', [p2pID]); exit; end; @@ -13282,8 +13518,7 @@ procedure TCommunicationFrameworkWithP2PVM.ReceivedListenState(const FrameworkID begin if siz <> SizeOf(TBuf) then begin - if not FQuietMode then - DoStatus('Virtual listen state protocol with buffer error!'); + FPhysicsIO.PrintError('Virtual listen state protocol with buffer error!'); if buff <> nil then if not FQuietMode then DoStatus(buff, siz, 40); @@ -13296,8 +13531,7 @@ procedure TCommunicationFrameworkWithP2PVM.ReceivedListenState(const FrameworkID if p2pID <> 0 then begin - if not FQuietMode then - DoStatus('Virtual listen state protocol error! IO ID:%d', [p2pID]); + FPhysicsIO.PrintError('Virtual listen state protocol error! IO ID:%d', [p2pID]); exit; end; @@ -13318,13 +13552,13 @@ procedure TCommunicationFrameworkWithP2PVM.ReceivedListenState(const FrameworkID LP^.Listening := True; end; if not FQuietMode then - DoStatus('Virtual Remote Listen state Activted "%s port:%d"', [IPv6ToStr(IPV6).Text, Port]); + FPhysicsIO.Print('Virtual Remote Listen state Activted "%s port:%d"', [IPv6ToStr(IPV6).Text, Port]); end else begin DeleteListen(IPV6, Port); if not FQuietMode then - DoStatus('Virtual Remote Listen state Close "%s port:%d"', [IPv6ToStr(IPV6).Text, Port]); + FPhysicsIO.Print('Virtual Remote Listen state Close "%s port:%d"', [IPv6ToStr(IPV6).Text, Port]); end; c := TCommunicationFramework(FFrameworkPool[FrameworkID]); @@ -13350,12 +13584,9 @@ procedure TCommunicationFrameworkWithP2PVM.ReceivedConnecting(const FrameworkID, begin if siz <> SizeOf(TBuf) then begin - if not FQuietMode then - begin - DoStatus('connect request with buffer error!'); - if buff <> nil then - DoStatus(buff, siz, 40); - end; + FPhysicsIO.PrintError('connect request with buffer error!'); + if buff <> nil then + DoStatus(buff, siz, 40); exit; end; p := @buff^; @@ -13367,8 +13598,7 @@ procedure TCommunicationFrameworkWithP2PVM.ReceivedConnecting(const FrameworkID, if p2pID <> 0 then begin SendDisconnect(Remote_frameworkID, Remote_p2pID); - if not FQuietMode then - DoStatus('connect request with protocol error! IO ID:%d', [p2pID]); + FPhysicsIO.PrintError('connect request with protocol error! IO ID:%d', [p2pID]); exit; end; @@ -13402,12 +13632,9 @@ procedure TCommunicationFrameworkWithP2PVM.ReceivedConnectedReponse(const Framew begin if siz <> SizeOf(TBuf) then begin - if not FQuietMode then - begin - DoStatus('connect request with buffer error!'); - if buff <> nil then - DoStatus(buff, siz, 40); - end; + FPhysicsIO.PrintError('connect request with buffer error!'); + if buff <> nil then + DoStatus(buff, siz, 40); exit; end; @@ -13422,7 +13649,7 @@ procedure TCommunicationFrameworkWithP2PVM.ReceivedConnectedReponse(const Framew TCommunicationFrameworkWithP2PVM_Client(c).VMConnectSuccessed(Self, Remote_frameworkID, Remote_p2pID, FrameworkID); if not FQuietMode then - DoStatus('connecting reponse from frameworkID: %d p2pID: %d', [Remote_frameworkID, Remote_p2pID]); + FPhysicsIO.Print('connecting reponse from frameworkID: %d p2pID: %d', [Remote_frameworkID, Remote_p2pID]); end; end; @@ -13444,14 +13671,14 @@ procedure TCommunicationFrameworkWithP2PVM.ReceivedDisconnect(const FrameworkID, if LocalVMc = nil then begin if not FQuietMode then - DoStatus('disconnect protocol no p2pID:%d', [p2pID]); + FPhysicsIO.Print('disconnect protocol no p2pID:%d', [p2pID]); exit; end; LocalVMc.FDestroySyncRemote := False; LocalVMc.Disconnect; end else if not FQuietMode then - DoStatus('disconnect protocol no frameworkID: %d', [FrameworkID]); + FPhysicsIO.Print('disconnect protocol no frameworkID: %d', [FrameworkID]); end; procedure TCommunicationFrameworkWithP2PVM.ReceivedLogicFragmentData(const FrameworkID, p2pID: Cardinal; const buff: PByte; const siz: Cardinal); @@ -13469,9 +13696,9 @@ procedure TCommunicationFrameworkWithP2PVM.ReceivedLogicFragmentData(const Frame LocalVMc.SaveReceiveBuffer(buff, siz); LocalVMc.FillRecvBuffer(nil, False, False); end - else if not FQuietMode then + else begin - DoStatus('fragment Data p2pID error: p2pID:%d buffer size:%d', [p2pID, siz]); + FPhysicsIO.PrintError('fragment Data p2pID error: p2pID:%d buffer size:%d', [p2pID, siz]); DoStatus(buff, umlMin(siz, 164), 40); end; end @@ -13483,14 +13710,14 @@ procedure TCommunicationFrameworkWithP2PVM.ReceivedLogicFragmentData(const Frame LocalVMc.SaveReceiveBuffer(buff, siz); LocalVMc.FillRecvBuffer(nil, False, False); end - else if not FQuietMode then + else begin - DoStatus('LocalVM [%d] error: no interface', [FrameworkID]); + FPhysicsIO.PrintError('LocalVM [%d] error: no interface', [FrameworkID]); end; end - else if not FQuietMode then + else begin - DoStatus('fragment Data frameworkID error: frameworkID:%d buffer size:%d', [FrameworkID, siz]); + FPhysicsIO.PrintError('fragment Data frameworkID error: frameworkID:%d buffer size:%d', [FrameworkID, siz]); DoStatus(buff, umlMin(siz, 164), 40); end; end; @@ -13532,27 +13759,18 @@ constructor TCommunicationFrameworkWithP2PVM.Create(HashPoolSize: Integer); inherited Create; FCritical := TCritical.Create; FPhysicsIO := nil; - FAuthWaiting := False; FAuthed := False; FAuthSending := False; - FFrameworkPool := TUInt32HashObjectList.CustomCreate(HashPoolSize); FFrameworkPool.AutoFreeData := False; FFrameworkPool.AccessOptimization := False; - FFrameworkListenPool := TCoreClassList.Create; - FMaxVMFragmentSize := C_P2PVM_MaxVMFragmentSize; - FMaxRealBuffer := C_P2PVM_MaxRealBuffer; - - FQuietMode := False; - - FReceiveStream := TMemoryStream64.Create; - FSendStream := TMemoryStream64.Create; - + FQuietMode := {$IFDEF Communication_QuietMode}True{$ELSE Communication_QuietMode}False{$ENDIF Communication_QuietMode}; + FReceiveStream := TMemoryStream64.CustomCreate(8192); + FSendStream := TMemoryStream64.CustomCreate(8192); FWaitEchoList := TCoreClassList.Create; - FVMID := 0; OnAuthSuccessOnesNotify := nil; end; @@ -13568,12 +13786,9 @@ destructor TCommunicationFrameworkWithP2PVM.Destroy; Dispose(OnEchoPtr); end; FWaitEchoList.Clear; - if FPhysicsIO <> nil then CloseP2PVMTunnel; - ClearListen; - DisposeObject(FWaitEchoList); DisposeObject(FReceiveStream); DisposeObject(FSendStream); @@ -13638,26 +13853,31 @@ procedure TCommunicationFrameworkWithP2PVM.Progress; exit; { fragment Packet } - repeat - lsiz := FSendStream.Size; - if (FFrameworkPool.Count > 0) then - begin - i := 0; - p := FFrameworkPool.FirstPtr; - while i < FFrameworkPool.Count do + while True do + begin + repeat + lsiz := FSendStream.Size; + if (FFrameworkPool.Count > 0) then begin - TCommunicationFramework(p^.data).FastProgressPeerIOM({$IFDEF FPC}@{$ENDIF FPC}DoProcessPerClientFragmentSend); - inc(i); - p := p^.Next; + i := 0; + p := FFrameworkPool.FirstPtr; + while i < FFrameworkPool.Count do + begin + TCommunicationFramework(p^.data).FastProgressPeerIOM({$IFDEF FPC}@{$ENDIF FPC}DoProcessPerClientFragmentSend); + inc(i); + p := p^.Next; + end; end; - end; - until (FSendStream.Size = lsiz) or (FSendStream.Size > FMaxRealBuffer); + until (FSendStream.Size = lsiz); - if FSendStream.Size > 0 then - begin - SendVMBuffer(FSendStream.Memory, FSendStream.Size); - FSendStream.Clear; - end + if FSendStream.Size > 0 then + begin + SendVMBuffer(FSendStream.Memory, FSendStream.Size); + FSendStream.Clear; + end + else + Break; + end; end; procedure TCommunicationFrameworkWithP2PVM.ProgressCommunicationFrameworkC(const OnBackcall: TCommunicationFrameworkListCall); @@ -13742,7 +13962,7 @@ procedure TCommunicationFrameworkWithP2PVM.OpenP2PVMTunnel(c: TPeerIO); end; if not FQuietMode then - DoStatus('Open VM P2P Tunnel ' + FPhysicsIO.PeerIP); + FPhysicsIO.Print('Open VM P2P Tunnel ' + FPhysicsIO.PeerIP); end; procedure TCommunicationFrameworkWithP2PVM.CloseP2PVMTunnel; @@ -13796,7 +14016,7 @@ procedure TCommunicationFrameworkWithP2PVM.CloseP2PVMTunnel; end; if not FQuietMode then - DoStatus('Close VM P2P Tunnel ' + FPhysicsIO.PeerIP); + FPhysicsIO.Print('Close VM P2P Tunnel ' + FPhysicsIO.PeerIP); FPhysicsIO := nil; end; @@ -13822,7 +14042,7 @@ procedure TCommunicationFrameworkWithP2PVM.InstallLogicFramework(c: TCommunicati if TCommunicationFrameworkWithP2PVM_Server(c).FFrameworkWithVM_ID <> 0 then begin if FFrameworkPool.Exists(TCommunicationFrameworkWithP2PVM_Server(c).FFrameworkWithVM_ID) then - RaiseInfo('P2PVM server is installed'); + exit; end else begin @@ -13847,7 +14067,7 @@ procedure TCommunicationFrameworkWithP2PVM.InstallLogicFramework(c: TCommunicati if TCommunicationFrameworkWithP2PVM_Client(c).FFrameworkWithVM_ID <> 0 then begin if FFrameworkPool.Exists(TCommunicationFrameworkWithP2PVM_Client(c).FFrameworkWithVM_ID) then - RaiseInfo('P2PVM client is installed'); + exit; end else begin @@ -14615,7 +14835,7 @@ function TCommunicationFramework_CustomStableServer.WaitSendConsoleCmd(P_IO: TPe end; procedure TCommunicationFramework_CustomStableServer.WaitSendStreamCmd(P_IO: TPeerIO; - const Cmd: SystemString; StreamData, ResultData: TDataFrameEngine; Timeout: TTimeTick); + const Cmd: SystemString; StreamData, Result_: TDataFrameEngine; Timeout: TTimeTick); begin RaiseInfo('WaitSend no Suppport'); end; @@ -14740,7 +14960,7 @@ procedure TCommunicationFramework_CustomStableClient.SetPhysicsClient(const Valu end; end; -procedure TCommunicationFramework_CustomStableClient.BuildStableIO_Result(Sender: TPeerIO; ResultData: TDataFrameEngine); +procedure TCommunicationFramework_CustomStableClient.BuildStableIO_Result(Sender: TPeerIO; Result_: TDataFrameEngine); var r_token, r_id: Cardinal; cSec: TCipherSecurity; @@ -14748,12 +14968,12 @@ procedure TCommunicationFramework_CustomStableClient.BuildStableIO_Result(Sender i: Integer; k: TCipherKeyBuffer; begin - if ResultData.Reader.ReadBool then + if Result_.Reader.ReadBool then begin - r_token := ResultData.Reader.ReadCardinal; - r_id := ResultData.Reader.ReadCardinal; - cSec := TCipherSecurity(ResultData.Reader.ReadByte); - arry := ResultData.Reader.ReadArrayByte; + r_token := Result_.Reader.ReadCardinal; + r_id := Result_.Reader.ReadCardinal; + cSec := TCipherSecurity(Result_.Reader.ReadByte); + arry := Result_.Reader.ReadArrayByte; SetLength(k, arry.Count); for i := 0 to arry.Count - 1 do k[i] := arry[i]; @@ -14788,7 +15008,7 @@ procedure TCommunicationFramework_CustomStableClient.BuildStableIO_Result(Sender end else begin - Sender.PrintError(ResultData.Reader.ReadString); + Sender.PrintError(Result_.Reader.ReadString); TriggerDoConnectFailed; end; end; @@ -14823,19 +15043,19 @@ procedure TCommunicationFramework_CustomStableClient.PostConnection(Sender: TNPo FPhysicsClient.AsyncConnectM(FConnection_Addr, FConnection_Port, {$IFDEF FPC}@{$ENDIF FPC}AsyncConnectResult); end; -procedure TCommunicationFramework_CustomStableClient.OpenStableIO_Result(Sender: TPeerIO; ResultData: TDataFrameEngine); +procedure TCommunicationFramework_CustomStableClient.OpenStableIO_Result(Sender: TPeerIO; Result_: TDataFrameEngine); var r_token, r_id: Cardinal; cSec: TCipherSecurity; arry: TDataFrameArrayByte; k: TCipherKeyBuffer; begin - if ResultData.Reader.ReadBool then + if Result_.Reader.ReadBool then begin - r_token := ResultData.Reader.ReadCardinal; - r_id := ResultData.Reader.ReadCardinal; - cSec := TCipherSecurity(ResultData.Reader.ReadByte); - arry := ResultData.Reader.ReadArrayByte; + r_token := Result_.Reader.ReadCardinal; + r_id := Result_.Reader.ReadCardinal; + cSec := TCipherSecurity(Result_.Reader.ReadByte); + arry := Result_.Reader.ReadArrayByte; SetLength(k, arry.Count); arry.GetBuff(@k[0]); @@ -14866,7 +15086,7 @@ procedure TCommunicationFramework_CustomStableClient.OpenStableIO_Result(Sender: end else begin - Sender.PrintError(ResultData.Reader.ReadString); + Sender.PrintError(Result_.Reader.ReadString); FStableClientIO.WaitConnecting := False; diff --git a/Source/CommunicationFrameworkDoubleTunnelIO.pas b/Source/CommunicationFrameworkDoubleTunnelIO.pas index 706d2122..e89a5d39 100644 --- a/Source/CommunicationFrameworkDoubleTunnelIO.pas +++ b/Source/CommunicationFrameworkDoubleTunnelIO.pas @@ -88,6 +88,7 @@ TPeerClientUserDefineForRecvTunnel = class(TPeerIOUserDefine) TDTService = class(TCoreClassInterfacedObject) protected FRecvTunnel, FSendTunnel: TCommunicationFrameworkServer; + FFileSystem: Boolean; FRootPath, FPublicPath: SystemString; FUserDB: THashTextEngine; FAllowRegisterNewUser: Boolean; @@ -121,28 +122,21 @@ TDTService = class(TCoreClassInterfacedObject) procedure Command_GetPublicFileList(Sender: TPeerIO; InData, OutData: TDataFrameEngine); virtual; procedure Command_GetPrivateFileList(Sender: TPeerIO; InData, OutData: TDataFrameEngine); virtual; procedure Command_GetPrivateDirectoryList(Sender: TPeerIO; InData, OutData: TDataFrameEngine); virtual; - procedure Command_CreatePrivateDirectory(Sender: TPeerIO; InData, OutData: TDataFrameEngine); virtual; - procedure Command_GetPublicFileInfo(Sender: TPeerIO; InData, OutData: TDataFrameEngine); virtual; procedure Command_GetPrivateFileInfo(Sender: TPeerIO; InData, OutData: TDataFrameEngine); virtual; - procedure Command_GetPublicFileMD5(Sender: TPeerIO; InData, OutData: TDataFrameEngine); virtual; procedure Command_GetPrivateFileMD5(Sender: TPeerIO; InData, OutData: TDataFrameEngine); virtual; - procedure Command_GetPublicFile(Sender: TPeerIO; InData, OutData: TDataFrameEngine); virtual; procedure Command_GetPrivateFile(Sender: TPeerIO; InData, OutData: TDataFrameEngine); virtual; procedure Command_GetUserPrivateFile(Sender: TPeerIO; InData, OutData: TDataFrameEngine); virtual; - procedure Command_GetPublicFileAs(Sender: TPeerIO; InData, OutData: TDataFrameEngine); virtual; procedure Command_GetPrivateFileAs(Sender: TPeerIO; InData, OutData: TDataFrameEngine); virtual; procedure Command_GetUserPrivateFileAs(Sender: TPeerIO; InData, OutData: TDataFrameEngine); virtual; - procedure Command_PostPublicFileInfo(Sender: TPeerIO; InData: TDataFrameEngine); virtual; procedure Command_PostPrivateFileInfo(Sender: TPeerIO; InData: TDataFrameEngine); virtual; procedure Command_PostFile(Sender: TPeerIO; InData: TCoreClassStream; BigStreamTotal, BigStreamCompleteSize: Int64); virtual; procedure Command_PostFileOver(Sender: TPeerIO; InData: TDataFrameEngine); virtual; - procedure Command_GetPublicFileFragmentData(Sender: TPeerIO; InData, OutData: TDataFrameEngine); virtual; procedure Command_GetPrivateFileFragmentData(Sender: TPeerIO; InData, OutData: TDataFrameEngine); virtual; @@ -213,6 +207,7 @@ TDTService = class(TCoreClassInterfacedObject) property AllowRegisterNewUser: Boolean read FAllowRegisterNewUser write FAllowRegisterNewUser; property AllowSaveUserInfo: Boolean read FAllowSaveUserInfo write FAllowSaveUserInfo; + property FileSystem: Boolean read FFileSystem write FFileSystem; { private store space } property RootPath: SystemString read FRootPath write FRootPath; { public store space } @@ -295,6 +290,7 @@ TClientUserDefineForSendTunnel = class(TPeerIOUserDefine) TDTClient = class(TCoreClassInterfacedObject, ICommunicationFrameworkClientInterface) protected FSendTunnel, FRecvTunnel: TCommunicationFrameworkClient; + FFileSystem: Boolean; FCurrentStream: TCoreClassStream; FCurrentReceiveStreamFileName: SystemString; FAutoFreeTunnel: Boolean; @@ -317,20 +313,20 @@ TDTClient = class(TCoreClassInterfacedObject, ICommunicationFrameworkClientInt procedure Command_PostFileOver(Sender: TPeerIO; InData: TDataFrameEngine); virtual; procedure Command_PostFileFragmentData(Sender: TPeerIO; InData: PByte; DataSize: NativeInt); virtual; - procedure GetPublicFileInfo_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); virtual; - procedure GetPrivateFileInfo_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); virtual; + procedure GetPublicFileInfo_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); virtual; + procedure GetPrivateFileInfo_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); virtual; - procedure GetPublicFileMD5_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); virtual; - procedure GetPrivateFileMD5_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); virtual; + procedure GetPublicFileMD5_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); virtual; + procedure GetPrivateFileMD5_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); virtual; - procedure GetPublicFile_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); virtual; - procedure GetPrivateFile_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); virtual; + procedure GetPublicFile_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); virtual; + procedure GetPrivateFile_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); virtual; { Downloading file fragment data from the server asynchronously and triggering notifications when completed } - procedure GetFileFragmentData_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); virtual; + procedure GetFileFragmentData_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); virtual; { GetCurrentCadencer result proc } - procedure GetCurrentCadencer_StreamResult(Sender: TPeerIO; ResultData: TDataFrameEngine); virtual; + procedure GetCurrentCadencer_StreamResult(Sender: TPeerIO; Result_: TDataFrameEngine); virtual; { batch stream suppport } procedure Command_NewBatchStream(Sender: TPeerIO; InData: TDataFrameEngine); virtual; @@ -351,11 +347,11 @@ TDTClient = class(TCoreClassInterfacedObject, ICommunicationFrameworkClientInt FAsyncOnResultProc: TStateProc; procedure AsyncSendConnectResult(const cState: Boolean); procedure AsyncRecvConnectResult(const cState: Boolean); - procedure UserLogin_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: TDataFrameEngine); + procedure UserLogin_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine); procedure UserLogin_OnFailed(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDataFrameEngine); - procedure RegisterUser_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: TDataFrameEngine); + procedure RegisterUser_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine); procedure RegisterUser_OnFailed(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDataFrameEngine); - procedure TunnelLink_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: TDataFrameEngine); + procedure TunnelLink_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine); procedure TunnelLink_OnFailed(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDataFrameEngine); public constructor Create(RecvTunnel_, SendTunnel_: TCommunicationFrameworkClient); virtual; @@ -567,7 +563,7 @@ TDTClient = class(TCoreClassInterfacedObject, ICommunicationFrameworkClientInt procedure GetBatchStreamStateM(Param1: Pointer; Param2: TObject; OnResult: TStreamParamMethod); overload; procedure GetBatchStreamStateP(OnResult: TStreamProc); overload; procedure GetBatchStreamStateP(Param1: Pointer; Param2: TObject; OnResult: TStreamParamProc); overload; - function GetBatchStreamState(ResultData: TDataFrameEngine; TimeOut_: TTimeTick): Boolean; overload; + function GetBatchStreamState(Result_: TDataFrameEngine; TimeOut_: TTimeTick): Boolean; overload; procedure RegisterCommand; virtual; procedure UnRegisterCommand; virtual; @@ -655,6 +651,9 @@ TDT_P2PVM_Client = class(TCoreClassObject) TDT_P2PVM_ClientPool = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + TDT_P2PVM_Custom_Service = class; + TDT_P2PVM_Custom_Service_Class = class of TDT_P2PVM_Custom_Service; + TDT_P2PVM_Custom_Service = class(TCoreClassInterfacedObject) private function GetQuietMode: Boolean; @@ -672,23 +671,26 @@ TDT_P2PVM_Custom_Service = class(TCoreClassInterfacedObject) constructor Create(ServiceClass_: TDTServiceClass; PhysicsTunnel_: TCommunicationFrameworkServer; P2PVM_Recv_Name_, P2PVM_Recv_IP6_, P2PVM_Recv_Port_, - P2PVM_Send_Name_, P2PVM_Send_IP6_, P2PVM_Send_Port_: SystemString); + P2PVM_Send_Name_, P2PVM_Send_IP6_, P2PVM_Send_Port_: SystemString); virtual; destructor Destroy; override; procedure Progress; virtual; - procedure StartService(); - procedure StopService(); + procedure StartService(); virtual; + procedure StopService(); virtual; property QuietMode: Boolean read GetQuietMode write SetQuietMode; end; TDT_P2PVM_Custom_ServicePool = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + TDT_P2PVM_Custom_Client = class; + TDT_P2PVM_Custom_Client_Class = class of TDT_P2PVM_Custom_Client; + TOn_DT_P2PVM_Custom_Client_TunnelLink = procedure(Sender: TDT_P2PVM_Custom_Client) of object; + TDT_P2PVM_Custom_Client = class(TCoreClassInterfacedObject) private OnConnectResultState: TDT_P2PVM_OnState; Connecting: Boolean; Reconnection: Boolean; procedure DoLoginResult(const state: Boolean); - procedure DoTunnelLinkResult(const state: Boolean); function GetQuietMode: Boolean; procedure SetQuietMode(const Value: Boolean); @@ -704,17 +706,19 @@ TDT_P2PVM_Custom_Client = class(TCoreClassInterfacedObject) DTClient: TDTClient; LastUser, LastPasswd: SystemString; AutomatedConnection: Boolean; + OnTunnelLink: TOn_DT_P2PVM_Custom_Client_TunnelLink; constructor Create(ClientClass_: TDTClientClass; PhysicsTunnel_: TCommunicationFrameworkClient; P2PVM_Recv_Name_, P2PVM_Recv_IP6_, P2PVM_Recv_Port_, - P2PVM_Send_Name_, P2PVM_Send_IP6_, P2PVM_Send_Port_: SystemString); + P2PVM_Send_Name_, P2PVM_Send_IP6_, P2PVM_Send_Port_: SystemString); virtual; destructor Destroy; override; procedure Progress; virtual; - procedure Connect(User, passwd: SystemString); - procedure Connect_C(User, passwd: SystemString; OnResult: TStateCall); - procedure Connect_M(User, passwd: SystemString; OnResult: TStateMethod); - procedure Connect_P(User, passwd: SystemString; OnResult: TStateProc); - procedure Disconnect; + procedure DoTunnelLinkResult(const state: Boolean); virtual; + procedure Connect(User, passwd: SystemString); virtual; + procedure Connect_C(User, passwd: SystemString; OnResult: TStateCall); virtual; + procedure Connect_M(User, passwd: SystemString; OnResult: TStateMethod); virtual; + procedure Connect_P(User, passwd: SystemString; OnResult: TStateProc); virtual; + procedure Disconnect; virtual; property QuietMode: Boolean read GetQuietMode write SetQuietMode; end; @@ -1242,8 +1246,11 @@ procedure TDTService.UserLoginSuccess(UserDefineIO: TPeerClientUserDefineForRecv procedure TDTService.UserLinkSuccess(UserDefineIO: TPeerClientUserDefineForRecvTunnel); begin - if Assigned(FOnLinkSuccess) then - FOnLinkSuccess(Self, UserDefineIO); + try + if Assigned(FOnLinkSuccess) then + FOnLinkSuccess(Self, UserDefineIO); + except + end; end; procedure TDTService.UserCreateDirectorySuccess(UserDefineIO: TPeerClientUserDefineForRecvTunnel; dn: SystemString); @@ -1256,8 +1263,11 @@ procedure TDTService.UserPostFileSuccess(UserDefineIO: TPeerClientUserDefineForR procedure TDTService.UserOut(UserDefineIO: TPeerClientUserDefineForRecvTunnel); begin - if Assigned(FOnUserOut) then - FOnUserOut(Self, UserDefineIO); + try + if Assigned(FOnUserOut) then + FOnUserOut(Self, UserDefineIO); + except + end; end; procedure TDTService.Command_UserLogin(Sender: TPeerIO; InData, OutData: TDataFrameEngine); @@ -1424,6 +1434,7 @@ procedure TDTService.Command_TunnelLink(Sender: TPeerIO; InData, OutData: TDataF begin OutData.WriteBool(False); OutData.WriteString(Format('need login or register', [])); + OutData.WriteBool(FFileSystem); Exit; end; @@ -1431,6 +1442,7 @@ procedure TDTService.Command_TunnelLink(Sender: TPeerIO; InData, OutData: TDataF begin OutData.WriteBool(False); OutData.WriteString(Format('send tunnel Illegal:%d', [SendID])); + OutData.WriteBool(FFileSystem); Exit; end; @@ -1438,6 +1450,7 @@ procedure TDTService.Command_TunnelLink(Sender: TPeerIO; InData, OutData: TDataF begin OutData.WriteBool(False); OutData.WriteString(Format('recv tunnel Illegal:%d', [RecvID])); + OutData.WriteBool(FFileSystem); Exit; end; @@ -1445,6 +1458,7 @@ procedure TDTService.Command_TunnelLink(Sender: TPeerIO; InData, OutData: TDataF begin OutData.WriteBool(False); OutData.WriteString(Format('recv tunnel Illegal:%d-%d', [Sender.ID, RecvID])); + OutData.WriteBool(FFileSystem); Exit; end; @@ -1456,6 +1470,7 @@ procedure TDTService.Command_TunnelLink(Sender: TPeerIO; InData, OutData: TDataF OutData.WriteBool(True); OutData.WriteString(Format('tunnel link success! recv:%d <-> send:%d', [RecvID, SendID])); + OutData.WriteBool(FFileSystem); UserLinkSuccess(UserDefineIO); end; @@ -1564,6 +1579,8 @@ procedure TDTService.Command_GetPublicFileList(Sender: TPeerIO; InData, OutData: i: Integer; n: SystemString; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then Exit; @@ -1589,6 +1606,8 @@ procedure TDTService.Command_GetPrivateFileList(Sender: TPeerIO; InData, OutData i: Integer; n: SystemString; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then Exit; @@ -1615,6 +1634,8 @@ procedure TDTService.Command_GetPrivateDirectoryList(Sender: TPeerIO; InData, Ou i: Integer; n: SystemString; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then Exit; @@ -1638,6 +1659,8 @@ procedure TDTService.Command_CreatePrivateDirectory(Sender: TPeerIO; InData, Out UserDefineIO: TPeerClientUserDefineForRecvTunnel; dn, fulldn: SystemString; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then Exit; @@ -1669,6 +1692,8 @@ procedure TDTService.Command_GetPublicFileInfo(Sender: TPeerIO; InData, OutData: UserDefineIO: TPeerClientUserDefineForRecvTunnel; fullfn, fileName: SystemString; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then Exit; @@ -1694,6 +1719,8 @@ procedure TDTService.Command_GetPrivateFileInfo(Sender: TPeerIO; InData, OutData UserDefineIO: TPeerClientUserDefineForRecvTunnel; fullfn, fileName, dn: SystemString; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then Exit; @@ -1723,6 +1750,8 @@ procedure TDTService.Command_GetPublicFileMD5(Sender: TPeerIO; InData, OutData: fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then Exit; @@ -1768,6 +1797,8 @@ procedure TDTService.Command_GetPrivateFileMD5(Sender: TPeerIO; InData, OutData: fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then Exit; @@ -1816,6 +1847,8 @@ procedure TDTService.Command_GetPublicFile(Sender: TPeerIO; InData, OutData: TDa fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then Exit; @@ -1874,6 +1907,8 @@ procedure TDTService.Command_GetPrivateFile(Sender: TPeerIO; InData, OutData: TD fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then Exit; @@ -1933,6 +1968,8 @@ procedure TDTService.Command_GetUserPrivateFile(Sender: TPeerIO; InData, OutData fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then Exit; @@ -1996,6 +2033,8 @@ procedure TDTService.Command_GetPublicFileAs(Sender: TPeerIO; InData, OutData: T fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then Exit; @@ -2055,6 +2094,8 @@ procedure TDTService.Command_GetPrivateFileAs(Sender: TPeerIO; InData, OutData: fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then Exit; @@ -2115,6 +2156,8 @@ procedure TDTService.Command_GetUserPrivateFileAs(Sender: TPeerIO; InData, OutDa fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then Exit; @@ -2177,6 +2220,8 @@ procedure TDTService.Command_PostPublicFileInfo(Sender: TPeerIO; InData: TDataFr FSize: Int64; fullfn: SystemString; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then begin @@ -2230,6 +2275,8 @@ procedure TDTService.Command_PostPrivateFileInfo(Sender: TPeerIO; InData: TDataF FSize: Int64; fullfn: SystemString; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then begin @@ -2287,6 +2334,8 @@ procedure TDTService.Command_PostFile(Sender: TPeerIO; InData: TCoreClassStream; var UserDefineIO: TPeerClientUserDefineForRecvTunnel; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then begin @@ -2313,6 +2362,8 @@ procedure TDTService.Command_PostFileOver(Sender: TPeerIO; InData: TDataFrameEng ClientMD5, MD5: TMD5; fn: SystemString; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LoginSuccessed then begin @@ -2357,6 +2408,8 @@ procedure TDTService.Command_GetPublicFileFragmentData(Sender: TPeerIO; InData, mem_: TMemoryStream64; MD5: TMD5; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then Exit; @@ -2424,6 +2477,8 @@ procedure TDTService.Command_GetPrivateFileFragmentData(Sender: TPeerIO; InData, mem_: TMemoryStream64; MD5: TMD5; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then Exit; @@ -2622,6 +2677,7 @@ constructor TDTService.Create(RecvTunnel_, SendTunnel_: TCommunicationFrameworkS FRecvTunnel.DoubleChannelFramework := Self; FSendTunnel.DoubleChannelFramework := Self; + FFileSystem := True; FRootPath := umlCurrentPath; FPublicPath := FRootPath; FUserDB := THashTextEngine.Create(20 * 10000); @@ -3357,15 +3413,15 @@ procedure TDTClient.Command_PostFileFragmentData(Sender: TPeerIO; InData: PByte; end; end; -procedure TDTClient.GetPublicFileInfo_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); +procedure TDTClient.GetPublicFileInfo_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); var p: PGetFileInfoStruct; Existed: Boolean; fSiz: Int64; begin p := PGetFileInfoStruct(Param1); - Existed := ResultData.Reader.ReadBool; - fSiz := ResultData.Reader.ReadInt64; + Existed := Result_.Reader.ReadBool; + fSiz := Result_.Reader.ReadInt64; if p <> nil then begin if Assigned(p^.OnCompleteCall) then @@ -3379,15 +3435,15 @@ procedure TDTClient.GetPublicFileInfo_StreamParamResult(Sender: TPeerIO; Param1: end; end; -procedure TDTClient.GetPrivateFileInfo_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); +procedure TDTClient.GetPrivateFileInfo_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); var p: PGetFileInfoStruct; Existed: Boolean; fSiz: Int64; begin p := PGetFileInfoStruct(Param1); - Existed := ResultData.Reader.ReadBool; - fSiz := ResultData.Reader.ReadInt64; + Existed := Result_.Reader.ReadBool; + fSiz := Result_.Reader.ReadInt64; if p <> nil then begin if Assigned(p^.OnCompleteCall) then @@ -3401,16 +3457,16 @@ procedure TDTClient.GetPrivateFileInfo_StreamParamResult(Sender: TPeerIO; Param1 end; end; -procedure TDTClient.GetPublicFileMD5_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); +procedure TDTClient.GetPublicFileMD5_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); var p: PFileMD5Struct; successed: Boolean; MD5: TMD5; begin p := PFileMD5Struct(Param1); - successed := ResultData.Reader.ReadBool; + successed := Result_.Reader.ReadBool; if successed then - MD5 := ResultData.Reader.ReadMD5 + MD5 := Result_.Reader.ReadMD5 else MD5 := NullMD5; if p <> nil then @@ -3426,16 +3482,16 @@ procedure TDTClient.GetPublicFileMD5_StreamParamResult(Sender: TPeerIO; Param1: end; end; -procedure TDTClient.GetPrivateFileMD5_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); +procedure TDTClient.GetPrivateFileMD5_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); var p: PFileMD5Struct; successed: Boolean; MD5: TMD5; begin p := PFileMD5Struct(Param1); - successed := ResultData.Reader.ReadBool; + successed := Result_.Reader.ReadBool; if successed then - MD5 := ResultData.Reader.ReadMD5 + MD5 := Result_.Reader.ReadMD5 else MD5 := NullMD5; if p <> nil then @@ -3451,51 +3507,51 @@ procedure TDTClient.GetPrivateFileMD5_StreamParamResult(Sender: TPeerIO; Param1: end; end; -procedure TDTClient.GetPublicFile_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); +procedure TDTClient.GetPublicFile_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); var p: PRemoteFileBackcall; begin - if ResultData.Count > 0 then + if Result_.Count > 0 then begin - if ResultData.Reader.ReadBool then + if Result_.Reader.ReadBool then begin FRecvFileing := True; FRecvFileName := InData.ReadString(0); Exit; end; - Sender.Print('GetPublicFile failed:%s', [ResultData.Reader.ReadString]); + Sender.Print('GetPublicFile failed:%s', [Result_.Reader.ReadString]); end; p := Param1; Dispose(p); end; -procedure TDTClient.GetPrivateFile_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); +procedure TDTClient.GetPrivateFile_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); var p: PRemoteFileBackcall; begin - if ResultData.Count > 0 then + if Result_.Count > 0 then begin - if ResultData.Reader.ReadBool then + if Result_.Reader.ReadBool then begin FRecvFileing := True; FRecvFileName := InData.ReadString(0); Exit; end; - Sender.Print('GetPrivateFile failed:%s', [ResultData.Reader.ReadString]); + Sender.Print('GetPrivateFile failed:%s', [Result_.Reader.ReadString]); end; p := Param1; Dispose(p); end; -procedure TDTClient.GetFileFragmentData_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); +procedure TDTClient.GetFileFragmentData_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); var p: PFileFragmentDataBackcall; begin - if ResultData.Count > 0 then + if Result_.Count > 0 then begin - if ResultData.Reader.ReadBool then + if Result_.Reader.ReadBool then Exit; end; @@ -3503,11 +3559,11 @@ procedure TDTClient.GetFileFragmentData_StreamParamResult(Sender: TPeerIO; Param Dispose(p); end; -procedure TDTClient.GetCurrentCadencer_StreamResult(Sender: TPeerIO; ResultData: TDataFrameEngine); +procedure TDTClient.GetCurrentCadencer_StreamResult(Sender: TPeerIO; Result_: TDataFrameEngine); var servTime: Double; begin - servTime := ResultData.Reader.ReadDouble; + servTime := Result_.Reader.ReadDouble; FCadencerEngine.Progress; FServerDelay := FCadencerEngine.CurrentTime - FLastCadencerTime; @@ -3698,17 +3754,17 @@ procedure TDTClient.AsyncRecvConnectResult(const cState: Boolean); FAsyncOnResultProc := nil; end; -procedure TDTClient.UserLogin_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: TDataFrameEngine); +procedure TDTClient.UserLogin_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine); var r: Boolean; p: POnStateStruct; begin p := Param1; r := False; - if ResultData.Count > 0 then + if Result_.Count > 0 then begin - r := ResultData.ReadBool(0); - FSendTunnel.ClientIO.Print(ResultData.ReadString(1)); + r := Result_.ReadBool(0); + FSendTunnel.ClientIO.Print(Result_.ReadString(1)); end; if Assigned(p^.OnCall) then @@ -3736,17 +3792,17 @@ procedure TDTClient.UserLogin_OnFailed(Sender: TPeerIO; Param1: Pointer; Param2: Dispose(p); end; -procedure TDTClient.RegisterUser_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: TDataFrameEngine); +procedure TDTClient.RegisterUser_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine); var r: Boolean; p: POnStateStruct; begin p := Param1; r := False; - if ResultData.Count > 0 then + if Result_.Count > 0 then begin - r := ResultData.ReadBool(0); - FSendTunnel.ClientIO.Print(ResultData.ReadString(1)); + r := Result_.ReadBool(0); + FSendTunnel.ClientIO.Print(Result_.ReadString(1)); end; if Assigned(p^.OnCall) then @@ -3774,20 +3830,24 @@ procedure TDTClient.RegisterUser_OnFailed(Sender: TPeerIO; Param1: Pointer; Para Dispose(p); end; -procedure TDTClient.TunnelLink_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: TDataFrameEngine); +procedure TDTClient.TunnelLink_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine); var r: Boolean; p: POnStateStruct; begin p := Param1; r := False; - if ResultData.Count > 0 then + if Result_.Count > 0 then begin - r := ResultData.ReadBool(0); - FSendTunnel.ClientIO.Print(ResultData.ReadString(1)); + r := Result_.ReadBool(0); + FSendTunnel.ClientIO.Print(Result_.ReadString(1)); if r then begin + if Result_.Count >= 2 then + FFileSystem := Result_.ReadBool(2) + else + FFileSystem := True; TClientUserDefineForSendTunnel(FSendTunnel.ClientIO.UserDefine).Client := Self; TClientUserDefineForSendTunnel(FSendTunnel.ClientIO.UserDefine).RecvTunnel := TClientUserDefineForRecvTunnel(FRecvTunnel.ClientIO.UserDefine); @@ -3837,6 +3897,7 @@ constructor TDTClient.Create(RecvTunnel_, SendTunnel_: TCommunicationFrameworkCl FRecvTunnel.DoubleChannelFramework := Self; FSendTunnel.DoubleChannelFramework := Self; + FFileSystem := False; FCurrentStream := nil; FCurrentReceiveStreamFileName := ''; @@ -4145,6 +4206,10 @@ function TDTClient.TunnelLink: Boolean; if Result then begin + if resDE.Count >= 2 then + FFileSystem := resDE.ReadBool(2) + else + FFileSystem := True; TClientUserDefineForSendTunnel(FSendTunnel.ClientIO.UserDefine).Client := Self; TClientUserDefineForSendTunnel(FSendTunnel.ClientIO.UserDefine).RecvTunnel := TClientUserDefineForRecvTunnel(FRecvTunnel.ClientIO.UserDefine); @@ -4453,6 +4518,8 @@ procedure TDTClient.GetPublicFileList(Filter: SystemString; lst: TCoreClassStrin var sendDE, resDE: TDataFrameEngine; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4475,6 +4542,8 @@ procedure TDTClient.GetPrivateFileList(Filter, RemoteDirectory: SystemString; ls var sendDE, resDE: TDataFrameEngine; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4503,6 +4572,8 @@ procedure TDTClient.GetPrivateDirectoryList(Filter, RemoteDirectory: SystemStrin var sendDE, resDE: TDataFrameEngine; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4532,6 +4603,8 @@ function TDTClient.CreatePrivateDirectory(RemoteDirectory: SystemString): Boolea sendDE, resDE: TDataFrameEngine; begin Result := False; + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4559,6 +4632,8 @@ procedure TDTClient.GetPublicFileInfoC(fileName: SystemString; const UserData: P sendDE: TDataFrameEngine; p: PGetFileInfoStruct; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4583,6 +4658,8 @@ procedure TDTClient.GetPublicFileInfoM(fileName: SystemString; const UserData: P sendDE: TDataFrameEngine; p: PGetFileInfoStruct; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4607,6 +4684,8 @@ procedure TDTClient.GetPublicFileInfoP(fileName: SystemString; const UserData: P sendDE: TDataFrameEngine; p: PGetFileInfoStruct; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4631,6 +4710,8 @@ procedure TDTClient.GetPrivateFileInfoC(fileName, RemoteDirectory: SystemString; sendDE: TDataFrameEngine; p: PGetFileInfoStruct; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4656,6 +4737,8 @@ procedure TDTClient.GetPrivateFileInfoM(fileName, RemoteDirectory: SystemString; sendDE: TDataFrameEngine; p: PGetFileInfoStruct; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4681,6 +4764,8 @@ procedure TDTClient.GetPrivateFileInfoP(fileName, RemoteDirectory: SystemString; sendDE: TDataFrameEngine; p: PGetFileInfoStruct; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4708,6 +4793,8 @@ procedure TDTClient.GetPublicFileMD5C(fileName: SystemString; const StartPos, En sendDE: TDataFrameEngine; p: PFileMD5Struct; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4737,6 +4824,8 @@ procedure TDTClient.GetPublicFileMD5M(fileName: SystemString; const StartPos, En sendDE: TDataFrameEngine; p: PFileMD5Struct; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4766,6 +4855,8 @@ procedure TDTClient.GetPublicFileMD5P(fileName: SystemString; const StartPos, En sendDE: TDataFrameEngine; p: PFileMD5Struct; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4796,6 +4887,8 @@ procedure TDTClient.GetPrivateFileMD5C(fileName, RemoteDirectory: SystemString; sendDE: TDataFrameEngine; p: PFileMD5Struct; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4826,6 +4919,8 @@ procedure TDTClient.GetPrivateFileMD5M(fileName, RemoteDirectory: SystemString; sendDE: TDataFrameEngine; p: PFileMD5Struct; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4856,6 +4951,8 @@ procedure TDTClient.GetPrivateFileMD5P(fileName, RemoteDirectory: SystemString; sendDE: TDataFrameEngine; p: PFileMD5Struct; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4909,6 +5006,8 @@ function TDTClient.GetPublicFile(fileName: SystemString; StartPos: Int64; saveTo sendDE, resDE: TDataFrameEngine; begin Result := False; + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4945,6 +5044,8 @@ procedure TDTClient.GetPublicFileC(fileName: SystemString; StartPos: Int64; save sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4971,6 +5072,8 @@ procedure TDTClient.GetPublicFileM(fileName: SystemString; StartPos: Int64; save sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -4997,6 +5100,8 @@ procedure TDTClient.GetPublicFileP(fileName: SystemString; StartPos: Int64; save sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5023,6 +5128,8 @@ procedure TDTClient.GetPublicFileAsC(fileName, saveFileName: SystemString; Start sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5050,6 +5157,8 @@ procedure TDTClient.GetPublicFileAsM(fileName, saveFileName: SystemString; Start sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5077,6 +5186,8 @@ procedure TDTClient.GetPublicFileAsP(fileName, saveFileName: SystemString; Start sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5133,6 +5244,8 @@ function TDTClient.GetPrivateFile(fileName: SystemString; StartPos: Int64; Remot sendDE, resDE: TDataFrameEngine; begin Result := False; + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5174,6 +5287,8 @@ procedure TDTClient.GetPrivateFileC(fileName: SystemString; StartPos: Int64; Rem sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5201,6 +5316,8 @@ procedure TDTClient.GetPrivateFileM(fileName: SystemString; StartPos: Int64; Rem sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5228,6 +5345,8 @@ procedure TDTClient.GetPrivateFileP(fileName: SystemString; StartPos: Int64; Rem sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5255,6 +5374,8 @@ procedure TDTClient.GetPrivateFileAsC(fileName, saveFileName: SystemString; Star sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5283,6 +5404,8 @@ procedure TDTClient.GetPrivateFileAsM(fileName, saveFileName: SystemString; Star sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5311,6 +5434,8 @@ procedure TDTClient.GetPrivateFileAsP(fileName, saveFileName: SystemString; Star sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5368,6 +5493,8 @@ function TDTClient.GetUserPrivateFile(UserID, fileName: SystemString; StartPos: sendDE, resDE: TDataFrameEngine; begin Result := False; + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5411,6 +5538,8 @@ procedure TDTClient.GetUserPrivateFileC(UserID, fileName: SystemString; StartPos sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5440,6 +5569,8 @@ procedure TDTClient.GetUserPrivateFileM(UserID, fileName: SystemString; StartPos sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5469,6 +5600,8 @@ procedure TDTClient.GetUserPrivateFileP(UserID, fileName: SystemString; StartPos sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5498,6 +5631,8 @@ procedure TDTClient.GetUserPrivateFileAsC(UserID, fileName, saveFileName: System sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5528,6 +5663,8 @@ procedure TDTClient.GetUserPrivateFileAsM(UserID, fileName, saveFileName: System sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5558,6 +5695,8 @@ procedure TDTClient.GetUserPrivateFileAsP(UserID, fileName, saveFileName: System sendDE: TDataFrameEngine; p: PRemoteFileBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5588,6 +5727,8 @@ procedure TDTClient.GetPublicFileFragmentDataC(fileName: SystemString; StartPos, sendDE: TDataFrameEngine; p: PFileFragmentDataBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5620,6 +5761,8 @@ procedure TDTClient.GetPublicFileFragmentDataM(fileName: SystemString; StartPos, sendDE: TDataFrameEngine; p: PFileFragmentDataBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5652,6 +5795,8 @@ procedure TDTClient.GetPublicFileFragmentDataP(fileName: SystemString; StartPos, sendDE: TDataFrameEngine; p: PFileFragmentDataBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5684,6 +5829,8 @@ procedure TDTClient.GetPrivateFileFragmentDataC(fileName: SystemString; StartPos sendDE: TDataFrameEngine; p: PFileFragmentDataBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5716,6 +5863,8 @@ procedure TDTClient.GetPrivateFileFragmentDataM(fileName: SystemString; StartPos sendDE: TDataFrameEngine; p: PFileFragmentDataBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5748,6 +5897,8 @@ procedure TDTClient.GetPrivateFileFragmentDataP(fileName: SystemString; StartPos sendDE: TDataFrameEngine; p: PFileFragmentDataBackcall; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -5778,6 +5929,8 @@ procedure TDTClient.AutomatedDownloadPublicFileC(remoteFile, localFile: U_String var tmp: TAutomatedDownloadPublicFile_Struct; begin + if not FFileSystem then + Exit; tmp := TAutomatedDownloadPublicFile_Struct.Create; tmp.remoteFile := remoteFile; tmp.localFile := localFile; @@ -5791,6 +5944,8 @@ procedure TDTClient.AutomatedDownloadPublicFileM(remoteFile, localFile: U_String var tmp: TAutomatedDownloadPublicFile_Struct; begin + if not FFileSystem then + Exit; tmp := TAutomatedDownloadPublicFile_Struct.Create; tmp.remoteFile := remoteFile; tmp.localFile := localFile; @@ -5804,6 +5959,8 @@ procedure TDTClient.AutomatedDownloadPublicFileP(remoteFile, localFile: U_String var tmp: TAutomatedDownloadPublicFile_Struct; begin + if not FFileSystem then + Exit; tmp := TAutomatedDownloadPublicFile_Struct.Create; tmp.remoteFile := remoteFile; tmp.localFile := localFile; @@ -5817,6 +5974,8 @@ procedure TDTClient.AutomatedDownloadPrivateFileC(remoteFile, RemoteDirectory, l var tmp: TAutomatedDownloadPrivateFile_Struct; begin + if not FFileSystem then + Exit; tmp := TAutomatedDownloadPrivateFile_Struct.Create; tmp.remoteFile := remoteFile; tmp.RemoteDirectory := RemoteDirectory; @@ -5831,6 +5990,8 @@ procedure TDTClient.AutomatedDownloadPrivateFileM(remoteFile, RemoteDirectory, l var tmp: TAutomatedDownloadPrivateFile_Struct; begin + if not FFileSystem then + Exit; tmp := TAutomatedDownloadPrivateFile_Struct.Create; tmp.remoteFile := remoteFile; tmp.RemoteDirectory := RemoteDirectory; @@ -5845,6 +6006,8 @@ procedure TDTClient.AutomatedDownloadPrivateFileP(remoteFile, RemoteDirectory, l var tmp: TAutomatedDownloadPrivateFile_Struct; begin + if not FFileSystem then + Exit; tmp := TAutomatedDownloadPrivateFile_Struct.Create; tmp.remoteFile := remoteFile; tmp.RemoteDirectory := RemoteDirectory; @@ -5866,6 +6029,8 @@ procedure TDTClient.PostFileToPublic(fileName: SystemString; StartPos: Int64); fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + Exit; if not umlFileExists(fileName) then Exit; if not FSendTunnel.Connected then @@ -5908,6 +6073,8 @@ procedure TDTClient.PostFileToPrivate(fileName, RemoteDirectory: SystemString; S fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + Exit; if not umlFileExists(fileName) then Exit; if not FSendTunnel.Connected then @@ -5950,6 +6117,12 @@ procedure TDTClient.PostStreamToPrivate(RemoteFileName, RemoteDirectory: SystemS sendDE: TDataFrameEngine; MD5: TMD5; begin + if not FFileSystem then + begin + if doneFreeStream then + DisposeObject(stream); + Exit; + end; if not FSendTunnel.Connected then begin if doneFreeStream then @@ -5985,6 +6158,8 @@ procedure TDTClient.AutomatedUploadFileToPublic(localFile: U_String); var tmp: TAutomatedUploadPublicFile_Struct; begin + if not FFileSystem then + Exit; tmp := TAutomatedUploadPublicFile_Struct.Create; tmp.localFile := localFile; tmp.Client := Self; @@ -5996,6 +6171,8 @@ procedure TDTClient.AutomatedUploadFileToPrivate(localFile, RemoteDirectory: U_S var tmp: TAutomatedUploadPrivateFile_Struct; begin + if not FFileSystem then + Exit; tmp := TAutomatedUploadPrivateFile_Struct.Create; tmp.localFile := localFile; tmp.RemoteDirectory := RemoteDirectory; @@ -6136,13 +6313,13 @@ procedure TDTClient.GetBatchStreamStateP(Param1: Pointer; Param2: TObject; OnRes DisposeObject(de); end; -function TDTClient.GetBatchStreamState(ResultData: TDataFrameEngine; TimeOut_: TTimeTick): Boolean; +function TDTClient.GetBatchStreamState(Result_: TDataFrameEngine; TimeOut_: TTimeTick): Boolean; var de: TDataFrameEngine; begin de := TDataFrameEngine.Create; - SendTunnel.WaitSendStreamCmd(C_GetBatchStreamState, de, ResultData, TimeOut_); - Result := ResultData.Count > 0; + SendTunnel.WaitSendStreamCmd(C_GetBatchStreamState, de, Result_, TimeOut_); + Result := Result_.Count > 0; DisposeObject(de); end; @@ -6218,9 +6395,9 @@ constructor TDT_P2PVM_Service.Create(ServiceClass_: TDTServiceClass); PhysicsTunnel.AutomatedP2PVMService := True; RecvTunnel.PrefixName := 'DT'; - RecvTunnel.Name := 'Recv'; + RecvTunnel.Name := 'R'; SendTunnel.PrefixName := 'DT'; - SendTunnel.Name := 'Send'; + SendTunnel.Name := 'S'; PhysicsTunnel.PrefixName := 'Physics'; PhysicsTunnel.Name := 'p2pVM'; end; @@ -6366,9 +6543,9 @@ constructor TDT_P2PVM_Client.Create(ClientClass_: TDTClientClass); AutomatedConnection := True; RecvTunnel.PrefixName := 'DT'; - RecvTunnel.Name := 'Recv'; + RecvTunnel.Name := 'R'; SendTunnel.PrefixName := 'DT'; - SendTunnel.Name := 'Send'; + SendTunnel.Name := 'S'; PhysicsTunnel.PrefixName := 'Physics'; PhysicsTunnel.Name := 'p2pVM'; end; @@ -6505,12 +6682,12 @@ constructor TDT_P2PVM_Custom_Service.Create(ServiceClass_: TDTServiceClass; Phys Bind_P2PVM_Send_Port := umlStrToInt(P2PVM_Send_Port_); RecvTunnel := TCommunicationFrameworkWithP2PVM_Server.Create; - RecvTunnel.QuietMode := True; + RecvTunnel.QuietMode := PhysicsTunnel_.QuietMode; RecvTunnel.PrefixName := 'DT'; RecvTunnel.Name := P2PVM_Recv_Name_; SendTunnel := TCommunicationFrameworkWithP2PVM_Server.Create; - SendTunnel.QuietMode := True; + SendTunnel.QuietMode := PhysicsTunnel_.QuietMode; SendTunnel.PrefixName := 'DT'; SendTunnel.Name := P2PVM_Send_Name_; @@ -6520,6 +6697,7 @@ constructor TDT_P2PVM_Custom_Service.Create(ServiceClass_: TDTServiceClass; Phys Bind_PhysicsTunnel.AutomatedP2PVMServiceBind.AddService(RecvTunnel); Bind_PhysicsTunnel.AutomatedP2PVMServiceBind.AddService(SendTunnel); + Bind_PhysicsTunnel.AutomatedP2PVMService := True; StartService(); end; @@ -6570,24 +6748,6 @@ procedure TDT_P2PVM_Custom_Client.DoLoginResult(const state: Boolean); DTClient.TunnelLinkM({$IFDEF FPC}@{$ENDIF FPC}DoTunnelLinkResult); end; -procedure TDT_P2PVM_Custom_Client.DoTunnelLinkResult(const state: Boolean); -begin - if Assigned(OnConnectResultState.OnCall) then - OnConnectResultState.OnCall(state); - if Assigned(OnConnectResultState.OnMethod) then - OnConnectResultState.OnMethod(state); - if Assigned(OnConnectResultState.OnProc) then - OnConnectResultState.OnProc(state); - OnConnectResultState.Init; - Connecting := False; - - if state then - begin - if AutomatedConnection then - Reconnection := True; - end; -end; - function TDT_P2PVM_Custom_Client.GetQuietMode: Boolean; begin Result := RecvTunnel.QuietMode and SendTunnel.QuietMode; @@ -6618,11 +6778,11 @@ constructor TDT_P2PVM_Custom_Client.Create(ClientClass_: TDTClientClass; Physics // local RecvTunnel := TCommunicationFrameworkWithP2PVM_Client.Create; - RecvTunnel.QuietMode := True; + RecvTunnel.QuietMode := PhysicsTunnel_.QuietMode; RecvTunnel.PrefixName := 'DT'; RecvTunnel.Name := P2PVM_Recv_Name_; SendTunnel := TCommunicationFrameworkWithP2PVM_Client.Create; - SendTunnel.QuietMode := True; + SendTunnel.QuietMode := PhysicsTunnel_.QuietMode; SendTunnel.PrefixName := 'DT'; SendTunnel.Name := P2PVM_Send_Name_; DTClient := ClientClass_.Create(RecvTunnel, SendTunnel); @@ -6631,6 +6791,7 @@ constructor TDT_P2PVM_Custom_Client.Create(ClientClass_: TDTClientClass; Physics LastUser := ''; LastPasswd := ''; AutomatedConnection := True; + OnTunnelLink := nil; // automated p2pVM Bind_PhysicsTunnel.AutomatedP2PVMBindClient.AddClient(RecvTunnel, Bind_P2PVM_Recv_IP6, Bind_P2PVM_Recv_Port); @@ -6657,6 +6818,27 @@ procedure TDT_P2PVM_Custom_Client.Progress; Connect(LastUser, LastPasswd); end; +procedure TDT_P2PVM_Custom_Client.DoTunnelLinkResult(const state: Boolean); +begin + if Assigned(OnConnectResultState.OnCall) then + OnConnectResultState.OnCall(state); + if Assigned(OnConnectResultState.OnMethod) then + OnConnectResultState.OnMethod(state); + if Assigned(OnConnectResultState.OnProc) then + OnConnectResultState.OnProc(state); + OnConnectResultState.Init; + Connecting := False; + + if state then + begin + if AutomatedConnection then + Reconnection := True; + + if Assigned(OnTunnelLink) then + OnTunnelLink(Self); + end; +end; + procedure TDT_P2PVM_Custom_Client.Connect(User, passwd: SystemString); begin if Connecting then diff --git a/Source/CommunicationFrameworkDoubleTunnelIO_NoAuth.pas b/Source/CommunicationFrameworkDoubleTunnelIO_NoAuth.pas index daeb23ce..bf37418b 100644 --- a/Source/CommunicationFrameworkDoubleTunnelIO_NoAuth.pas +++ b/Source/CommunicationFrameworkDoubleTunnelIO_NoAuth.pas @@ -77,6 +77,7 @@ TDTService_NoAuth = class(TCoreClassInterfacedObject) FRecvTunnel, FSendTunnel: TCommunicationFrameworkServer; FCadencerEngine: TCadencer; FProgressEngine: TNProgressPost; + FFileSystem: Boolean; FFileReceiveDirectory: SystemString; { event } FOnLinkSuccess: TNoAuth_OnLinkSuccess; @@ -142,6 +143,7 @@ TDTService_NoAuth = class(TCoreClassInterfacedObject) property PostRun: TNProgressPost read FProgressEngine; property PostExecute: TNProgressPost read FProgressEngine; + property FileSystem: Boolean read FFileSystem write FFileSystem; property FileReceiveDirectory: SystemString read FFileReceiveDirectory write FFileReceiveDirectory; property PublicFileDirectory: SystemString read FFileReceiveDirectory write FFileReceiveDirectory; @@ -214,6 +216,7 @@ TClientUserDefineForSendTunnel_NoAuth = class(TPeerIOUserDefine) TDTClient_NoAuth = class(TCoreClassInterfacedObject, ICommunicationFrameworkClientInterface) protected FSendTunnel, FRecvTunnel: TCommunicationFrameworkClient; + FFileSystem: Boolean; FAutoFreeTunnel: Boolean; FLinkOk: Boolean; FWaitCommandTimeout: Cardinal; @@ -237,16 +240,16 @@ TDTClient_NoAuth = class(TCoreClassInterfacedObject, ICommunicationFrameworkCl procedure Command_PostFileOver(Sender: TPeerIO; InData: TDataFrameEngine); virtual; procedure Command_PostFileFragmentData(Sender: TPeerIO; InData: PByte; DataSize: NativeInt); virtual; - procedure GetCurrentCadencer_StreamResult(Sender: TPeerIO; ResultData: TDataFrameEngine); virtual; + procedure GetCurrentCadencer_StreamResult(Sender: TPeerIO; Result_: TDataFrameEngine); virtual; - procedure GetFileInfo_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); virtual; - procedure GetFileMD5_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); virtual; + procedure GetFileInfo_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); virtual; + procedure GetFileMD5_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); virtual; { Downloading files from the server asynchronously and triggering notifications when completed } - procedure GetFile_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); virtual; + procedure GetFile_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); virtual; { Downloading file fragment data from the server asynchronously and triggering notifications when completed } - procedure GetFileFragmentData_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); virtual; + procedure GetFileFragmentData_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); virtual; { batch stream suppport } procedure Command_NewBatchStream(Sender: TPeerIO; InData: TDataFrameEngine); virtual; @@ -263,12 +266,13 @@ TDTClient_NoAuth = class(TCoreClassInterfacedObject, ICommunicationFrameworkCl FAsyncOnResultProc: TStateProc; procedure AsyncSendConnectResult(const cState: Boolean); procedure AsyncRecvConnectResult(const cState: Boolean); - procedure TunnelLink_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: TDataFrameEngine); + procedure TunnelLink_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine); procedure TunnelLink_OnFailed(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDataFrameEngine); public constructor Create(RecvTunnel_, SendTunnel_: TCommunicationFrameworkClient); virtual; destructor Destroy; override; + property FileSystem: Boolean read FFileSystem; // free recveive+send tunnel from destroy, default is false property AutoFreeTunnel: Boolean read FAutoFreeTunnel write FAutoFreeTunnel; @@ -375,7 +379,7 @@ TDTClient_NoAuth = class(TCoreClassInterfacedObject, ICommunicationFrameworkCl procedure GetBatchStreamStateM(Param1: Pointer; Param2: TObject; OnResult: TStreamParamMethod); overload; procedure GetBatchStreamStateP(OnResult: TStreamProc); overload; procedure GetBatchStreamStateP(Param1: Pointer; Param2: TObject; OnResult: TStreamParamProc); overload; - function GetBatchStreamState(ResultData: TDataFrameEngine; ATimeOut: TTimeTick): Boolean; overload; + function GetBatchStreamState(Result_: TDataFrameEngine; ATimeOut: TTimeTick): Boolean; overload; procedure RegisterCommand; virtual; procedure UnRegisterCommand; virtual; @@ -459,6 +463,9 @@ TDT_P2PVM_NoAuth_Client = class(TCoreClassObject) TDT_P2PVM_NoAuth_ClientPool = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + TDT_P2PVM_NoAuth_Custom_Service = class; + TDT_P2PVM_NoAuth_Custom_Service_Class = class of TDT_P2PVM_NoAuth_Custom_Service; + TDT_P2PVM_NoAuth_Custom_Service = class(TCoreClassInterfacedObject) private function GetQuietMode: Boolean; @@ -476,22 +483,25 @@ TDT_P2PVM_NoAuth_Custom_Service = class(TCoreClassInterfacedObject) constructor Create(ServiceClass_: TDTService_NoAuthClass; PhysicsTunnel_: TCommunicationFrameworkServer; P2PVM_Recv_Name_, P2PVM_Recv_IP6_, P2PVM_Recv_Port_, - P2PVM_Send_Name_, P2PVM_Send_IP6_, P2PVM_Send_Port_: SystemString); + P2PVM_Send_Name_, P2PVM_Send_IP6_, P2PVM_Send_Port_: SystemString); virtual; destructor Destroy; override; procedure Progress; virtual; - procedure StartService(); - procedure StopService(); + procedure StartService(); virtual; + procedure StopService(); virtual; property QuietMode: Boolean read GetQuietMode write SetQuietMode; end; TDT_P2PVM_NoAuth_Custom_ServicePool = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + TDT_P2PVM_NoAuth_Custom_Client = class; + TDT_P2PVM_NoAuth_Custom_Client_Class = class of TDT_P2PVM_NoAuth_Custom_Client; + TOn_DT_P2PVM_NoAuth_Custom_Client_TunnelLink = procedure(Sender: TDT_P2PVM_NoAuth_Custom_Client) of object; + TDT_P2PVM_NoAuth_Custom_Client = class(TCoreClassInterfacedObject) private OnConnectResultState: TDT_P2PVM_NoAuth_OnState; Connecting: Boolean; Reconnection: Boolean; - procedure DoTunnelLinkResult(const state: Boolean); function GetQuietMode: Boolean; procedure SetQuietMode(const Value: Boolean); @@ -506,17 +516,20 @@ TDT_P2PVM_NoAuth_Custom_Client = class(TCoreClassInterfacedObject) RecvTunnel, SendTunnel: TCommunicationFrameworkWithP2PVM_Client; DTClient: TDTClient_NoAuth; AutomatedConnection: Boolean; + OnTunnelLink: TOn_DT_P2PVM_NoAuth_Custom_Client_TunnelLink; constructor Create(ClientClass_: TDTClient_NoAuthClass; PhysicsTunnel_: TCommunicationFrameworkClient; P2PVM_Recv_Name_, P2PVM_Recv_IP6_, P2PVM_Recv_Port_, - P2PVM_Send_Name_, P2PVM_Send_IP6_, P2PVM_Send_Port_: SystemString); + P2PVM_Send_Name_, P2PVM_Send_IP6_, P2PVM_Send_Port_: SystemString); virtual; destructor Destroy; override; procedure Progress; virtual; - procedure Connect(); - procedure Connect_C(OnResult: TStateCall); - procedure Connect_M(OnResult: TStateMethod); - procedure Connect_P(OnResult: TStateProc); - procedure Disconnect; + procedure DoTunnelLinkResult(const state: Boolean); virtual; + procedure AutoCheckPhysicsTunnelAndConnect; + procedure Connect(); virtual; + procedure Connect_C(OnResult: TStateCall); virtual; + procedure Connect_M(OnResult: TStateMethod); virtual; + procedure Connect_P(OnResult: TStateProc); virtual; + procedure Disconnect; virtual; property QuietMode: Boolean read GetQuietMode write SetQuietMode; end; @@ -797,14 +810,20 @@ function TPeerClientUserDefineForRecvTunnel_NoAuth.LinkOk: Boolean; procedure TDTService_NoAuth.UserLinkSuccess(UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth); begin - if Assigned(FOnLinkSuccess) then - FOnLinkSuccess(Self, UserDefineIO); + try + if Assigned(FOnLinkSuccess) then + FOnLinkSuccess(Self, UserDefineIO); + except + end; end; procedure TDTService_NoAuth.UserOut(UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth); begin - if Assigned(FOnUserOut) then - FOnUserOut(Self, UserDefineIO); + try + if Assigned(FOnUserOut) then + FOnUserOut(Self, UserDefineIO); + except + end; end; procedure TDTService_NoAuth.UserPostFileSuccess(UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth; fn: SystemString); @@ -825,6 +844,7 @@ procedure TDTService_NoAuth.Command_TunnelLink(Sender: TPeerIO; InData, OutData: begin OutData.WriteBool(False); OutData.WriteString(Format('send tunnel Illegal:%d', [SendID])); + OutData.WriteBool(FFileSystem); Exit; end; @@ -832,6 +852,7 @@ procedure TDTService_NoAuth.Command_TunnelLink(Sender: TPeerIO; InData, OutData: begin OutData.WriteBool(False); OutData.WriteString(Format('recv tunnel Illegal:%d', [RecvID])); + OutData.WriteBool(FFileSystem); Exit; end; @@ -839,6 +860,7 @@ procedure TDTService_NoAuth.Command_TunnelLink(Sender: TPeerIO; InData, OutData: begin OutData.WriteBool(False); OutData.WriteString(Format('recv tunnel Illegal:%d-%d', [Sender.ID, RecvID])); + OutData.WriteBool(FFileSystem); Exit; end; @@ -852,6 +874,7 @@ procedure TDTService_NoAuth.Command_TunnelLink(Sender: TPeerIO; InData, OutData: OutData.WriteBool(True); OutData.WriteString(Format('tunnel link success! recv:%d <-> send:%d', [RecvID, SendID])); + OutData.WriteBool(FFileSystem); UserLinkSuccess(UserDefineIO); end; @@ -867,6 +890,8 @@ procedure TDTService_NoAuth.Command_GetFileTime(Sender: TPeerIO; InData, OutData UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth; fullfn, fileName: SystemString; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then Exit; @@ -888,6 +913,8 @@ procedure TDTService_NoAuth.Command_GetFileInfo(Sender: TPeerIO; InData, OutData UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth; fullfn, fileName: SystemString; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then Exit; @@ -915,6 +942,8 @@ procedure TDTService_NoAuth.Command_GetFileMD5(Sender: TPeerIO; InData, OutData: fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then Exit; @@ -961,6 +990,8 @@ procedure TDTService_NoAuth.Command_GetFile(Sender: TPeerIO; InData, OutData: TD fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then Exit; @@ -1017,6 +1048,8 @@ procedure TDTService_NoAuth.Command_GetFileAs(Sender: TPeerIO; InData, OutData: fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then Exit; @@ -1072,6 +1105,8 @@ procedure TDTService_NoAuth.Command_PostFileInfo(Sender: TPeerIO; InData: TDataF FSize: Int64; fullfn: SystemString; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then begin @@ -1116,6 +1151,8 @@ procedure TDTService_NoAuth.Command_PostFile(Sender: TPeerIO; InData: TCoreClass var UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then begin @@ -1137,6 +1174,8 @@ procedure TDTService_NoAuth.Command_PostFileOver(Sender: TPeerIO; InData: TDataF ClientMD5, MD5: TMD5; fn: SystemString; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then begin @@ -1176,6 +1215,8 @@ procedure TDTService_NoAuth.Command_GetFileFragmentData(Sender: TPeerIO; InData, mem_: TMemoryStream64; MD5: TMD5; begin + if not FFileSystem then + Exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then Exit; @@ -1372,6 +1413,7 @@ constructor TDTService_NoAuth.Create(RecvTunnel_, SendTunnel_: TCommunicationFra FCadencerEngine.OnProgress := {$IFDEF FPC}@{$ENDIF FPC}CadencerProgress; FProgressEngine := TNProgressPost.Create; + FFileSystem := True; FFileReceiveDirectory := umlCurrentPath; if not umlDirectoryExists(FFileReceiveDirectory) then @@ -1784,11 +1826,11 @@ procedure TDTClient_NoAuth.Command_PostFileFragmentData(Sender: TPeerIO; InData: end; end; -procedure TDTClient_NoAuth.GetCurrentCadencer_StreamResult(Sender: TPeerIO; ResultData: TDataFrameEngine); +procedure TDTClient_NoAuth.GetCurrentCadencer_StreamResult(Sender: TPeerIO; Result_: TDataFrameEngine); var servTime: Double; begin - servTime := ResultData.Reader.ReadDouble; + servTime := Result_.Reader.ReadDouble; FCadencerEngine.Progress; FServerDelay := FCadencerEngine.CurrentTime - FLastCadencerTime; @@ -1797,15 +1839,15 @@ procedure TDTClient_NoAuth.GetCurrentCadencer_StreamResult(Sender: TPeerIO; Resu FCadencerEngine.Progress; end; -procedure TDTClient_NoAuth.GetFileInfo_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); +procedure TDTClient_NoAuth.GetFileInfo_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); var p: PGetFileInfoStruct_NoAuth; Existed: Boolean; fSiz: Int64; begin p := PGetFileInfoStruct_NoAuth(Param1); - Existed := ResultData.Reader.ReadBool; - fSiz := ResultData.Reader.ReadInt64; + Existed := Result_.Reader.ReadBool; + fSiz := Result_.Reader.ReadInt64; if p <> nil then begin if Assigned(p^.OnCompleteCall) then @@ -1819,16 +1861,16 @@ procedure TDTClient_NoAuth.GetFileInfo_StreamParamResult(Sender: TPeerIO; Param1 end; end; -procedure TDTClient_NoAuth.GetFileMD5_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); +procedure TDTClient_NoAuth.GetFileMD5_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); var p: PFileMD5Struct_NoAuth; successed: Boolean; MD5: TMD5; begin p := PFileMD5Struct_NoAuth(Param1); - successed := ResultData.Reader.ReadBool; + successed := Result_.Reader.ReadBool; if successed then - MD5 := ResultData.Reader.ReadMD5 + MD5 := Result_.Reader.ReadMD5 else MD5 := NullMD5; if p <> nil then @@ -1844,28 +1886,28 @@ procedure TDTClient_NoAuth.GetFileMD5_StreamParamResult(Sender: TPeerIO; Param1: end; end; -procedure TDTClient_NoAuth.GetFile_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); +procedure TDTClient_NoAuth.GetFile_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); var p: PRemoteFileBackcall_NoAuth; begin - if ResultData.Count > 0 then + if Result_.Count > 0 then begin - if ResultData.Reader.ReadBool then + if Result_.Reader.ReadBool then Exit; - Sender.Print('get file failed:%s', [ResultData.Reader.ReadString]); + Sender.Print('get file failed:%s', [Result_.Reader.ReadString]); end; p := Param1; Dispose(p); end; -procedure TDTClient_NoAuth.GetFileFragmentData_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); +procedure TDTClient_NoAuth.GetFileFragmentData_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); var p: PFileFragmentDataBackcall_NoAuth; begin - if ResultData.Count > 0 then + if Result_.Count > 0 then begin - if ResultData.Reader.ReadBool then + if Result_.Reader.ReadBool then Exit; end; @@ -2047,20 +2089,24 @@ procedure TDTClient_NoAuth.AsyncRecvConnectResult(const cState: Boolean); FAsyncOnResultProc := nil; end; -procedure TDTClient_NoAuth.TunnelLink_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: TDataFrameEngine); +procedure TDTClient_NoAuth.TunnelLink_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine); var r: Boolean; p: POnStateStruct; begin p := Param1; r := False; - if ResultData.Count > 0 then + if Result_.Count > 0 then begin - r := ResultData.ReadBool(0); - FSendTunnel.ClientIO.Print(ResultData.ReadString(1)); + r := Result_.ReadBool(0); + FSendTunnel.ClientIO.Print(Result_.ReadString(1)); if r then begin + if Result_.Count >= 2 then + FFileSystem := Result_.ReadBool(2) + else + FFileSystem := True; TClientUserDefineForSendTunnel_NoAuth(FSendTunnel.ClientIO.UserDefine).Client := Self; TClientUserDefineForSendTunnel_NoAuth(FSendTunnel.ClientIO.UserDefine).RecvTunnel := TClientUserDefineForRecvTunnel_NoAuth(FRecvTunnel.ClientIO.UserDefine); @@ -2110,6 +2156,8 @@ constructor TDTClient_NoAuth.Create(RecvTunnel_, SendTunnel_: TCommunicationFram FRecvTunnel.DoubleChannelFramework := Self; FSendTunnel.DoubleChannelFramework := Self; + FFileSystem := False; + FAutoFreeTunnel := False; FLinkOk := False; @@ -2357,6 +2405,10 @@ function TDTClient_NoAuth.TunnelLink: Boolean; if Result then begin + if resDE.Count >= 2 then + FFileSystem := resDE.ReadBool(2) + else + FFileSystem := True; TClientUserDefineForSendTunnel_NoAuth(FSendTunnel.ClientIO.UserDefine).Client := Self; TClientUserDefineForSendTunnel_NoAuth(FSendTunnel.ClientIO.UserDefine).RecvTunnel := TClientUserDefineForRecvTunnel_NoAuth(FRecvTunnel.ClientIO.UserDefine); @@ -2470,6 +2522,8 @@ procedure TDTClient_NoAuth.GetFileTimeM(RemoteFilename: SystemString; OnCallResu var sendDE: TDataFrameEngine; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2485,6 +2539,8 @@ procedure TDTClient_NoAuth.GetFileTimeP(RemoteFilename: SystemString; OnCallResu var sendDE: TDataFrameEngine; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2502,6 +2558,8 @@ procedure TDTClient_NoAuth.GetFileInfoC(fileName: SystemString; const UserData: sendDE: TDataFrameEngine; p: PGetFileInfoStruct_NoAuth; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2527,6 +2585,8 @@ procedure TDTClient_NoAuth.GetFileInfoM(fileName: SystemString; const UserData: sendDE: TDataFrameEngine; p: PGetFileInfoStruct_NoAuth; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2552,6 +2612,8 @@ procedure TDTClient_NoAuth.GetFileInfoP(fileName: SystemString; const UserData: sendDE: TDataFrameEngine; p: PGetFileInfoStruct_NoAuth; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2579,6 +2641,8 @@ procedure TDTClient_NoAuth.GetFileMD5C(fileName: SystemString; const StartPos, E sendDE: TDataFrameEngine; p: PFileMD5Struct_NoAuth; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2609,6 +2673,8 @@ procedure TDTClient_NoAuth.GetFileMD5M(fileName: SystemString; const StartPos, E sendDE: TDataFrameEngine; p: PFileMD5Struct_NoAuth; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2639,6 +2705,8 @@ procedure TDTClient_NoAuth.GetFileMD5P(fileName: SystemString; const StartPos, E sendDE: TDataFrameEngine; p: PFileMD5Struct_NoAuth; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2707,6 +2775,8 @@ procedure TDTClient_NoAuth.GetFileC(fileName: SystemString; StartPos: Int64; sav sendDE: TDataFrameEngine; p: PRemoteFileBackcall_NoAuth; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2734,6 +2804,8 @@ procedure TDTClient_NoAuth.GetFileM(fileName: SystemString; StartPos: Int64; sav sendDE: TDataFrameEngine; p: PRemoteFileBackcall_NoAuth; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2761,6 +2833,8 @@ procedure TDTClient_NoAuth.GetFileP(fileName: SystemString; StartPos: Int64; sav sendDE: TDataFrameEngine; p: PRemoteFileBackcall_NoAuth; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2788,6 +2862,8 @@ procedure TDTClient_NoAuth.GetFileAsC(fileName, saveFileName: SystemString; Star sendDE: TDataFrameEngine; p: PRemoteFileBackcall_NoAuth; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2816,6 +2892,8 @@ procedure TDTClient_NoAuth.GetFileAsM(fileName, saveFileName: SystemString; Star sendDE: TDataFrameEngine; p: PRemoteFileBackcall_NoAuth; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2844,6 +2922,8 @@ procedure TDTClient_NoAuth.GetFileAsP(fileName, saveFileName: SystemString; Star sendDE: TDataFrameEngine; p: PRemoteFileBackcall_NoAuth; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2873,6 +2953,8 @@ function TDTClient_NoAuth.GetFile(fileName: SystemString; StartPos: Int64; saveT sendDE, resDE: TDataFrameEngine; begin Result := False; + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2904,6 +2986,8 @@ procedure TDTClient_NoAuth.GetFileFragmentDataC(fileName: SystemString; StartPos sendDE: TDataFrameEngine; p: PFileFragmentDataBackcall_NoAuth; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2936,6 +3020,8 @@ procedure TDTClient_NoAuth.GetFileFragmentDataM(fileName: SystemString; StartPos sendDE: TDataFrameEngine; p: PFileFragmentDataBackcall_NoAuth; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2968,6 +3054,8 @@ procedure TDTClient_NoAuth.GetFileFragmentDataP(fileName: SystemString; StartPos sendDE: TDataFrameEngine; p: PFileFragmentDataBackcall_NoAuth; begin + if not FFileSystem then + Exit; if not FSendTunnel.Connected then Exit; if not FRecvTunnel.Connected then @@ -2998,6 +3086,8 @@ procedure TDTClient_NoAuth.AutomatedDownloadFileC(remoteFile, localFile: U_Strin var tmp: TAutomatedDownloadFile_Struct_NoAuth; begin + if not FFileSystem then + Exit; tmp := TAutomatedDownloadFile_Struct_NoAuth.Create; tmp.remoteFile := remoteFile; tmp.localFile := localFile; @@ -3011,6 +3101,8 @@ procedure TDTClient_NoAuth.AutomatedDownloadFileM(remoteFile, localFile: U_Strin var tmp: TAutomatedDownloadFile_Struct_NoAuth; begin + if not FFileSystem then + Exit; tmp := TAutomatedDownloadFile_Struct_NoAuth.Create; tmp.remoteFile := remoteFile; tmp.localFile := localFile; @@ -3024,6 +3116,8 @@ procedure TDTClient_NoAuth.AutomatedDownloadFileP(remoteFile, localFile: U_Strin var tmp: TAutomatedDownloadFile_Struct_NoAuth; begin + if not FFileSystem then + Exit; tmp := TAutomatedDownloadFile_Struct_NoAuth.Create; tmp.remoteFile := remoteFile; tmp.localFile := localFile; @@ -3039,6 +3133,8 @@ procedure TDTClient_NoAuth.PostFile(fileName: SystemString); fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + Exit; if not umlFileExists(fileName) then Exit; if not FSendTunnel.Connected then @@ -3072,6 +3168,8 @@ procedure TDTClient_NoAuth.PostFile(fileName: SystemString; StartPos: Int64); fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + Exit; if not umlFileExists(fileName) then Exit; if not FSendTunnel.Connected then @@ -3104,9 +3202,10 @@ procedure TDTClient_NoAuth.PostFile(fn: SystemString; stream: TCoreClassStream; sendDE: TDataFrameEngine; MD5: TMD5; begin - if (not FSendTunnel.Connected) or (not FRecvTunnel.Connected) then + if (not FSendTunnel.Connected) or (not FRecvTunnel.Connected) or (not FFileSystem) then begin - DisposeObject(stream); + if doneFreeStream then + DisposeObject(stream); Exit; end; @@ -3134,9 +3233,10 @@ procedure TDTClient_NoAuth.PostFile(fn: SystemString; stream: TCoreClassStream; sendDE: TDataFrameEngine; MD5: TMD5; begin - if (not FSendTunnel.Connected) or (not FRecvTunnel.Connected) then + if (not FSendTunnel.Connected) or (not FRecvTunnel.Connected) or (not FFileSystem) then begin - DisposeObject(stream); + if doneFreeStream then + DisposeObject(stream); Exit; end; @@ -3163,6 +3263,8 @@ procedure TDTClient_NoAuth.AutomatedUploadFile(localFile: U_String); var tmp: TAutomatedUploadFile_Struct_NoAuth; begin + if not FFileSystem then + Exit; tmp := TAutomatedUploadFile_Struct_NoAuth.Create; tmp.localFile := localFile; tmp.Client := Self; @@ -3302,13 +3404,13 @@ procedure TDTClient_NoAuth.GetBatchStreamStateP(Param1: Pointer; Param2: TObject DisposeObject(de); end; -function TDTClient_NoAuth.GetBatchStreamState(ResultData: TDataFrameEngine; ATimeOut: TTimeTick): Boolean; +function TDTClient_NoAuth.GetBatchStreamState(Result_: TDataFrameEngine; ATimeOut: TTimeTick): Boolean; var de: TDataFrameEngine; begin de := TDataFrameEngine.Create; - SendTunnel.WaitSendStreamCmd(C_GetBatchStreamState, de, ResultData, ATimeOut); - Result := ResultData.Count > 0; + SendTunnel.WaitSendStreamCmd(C_GetBatchStreamState, de, Result_, ATimeOut); + Result := Result_.Count > 0; DisposeObject(de); end; @@ -3383,10 +3485,10 @@ constructor TDT_P2PVM_NoAuth_Service.Create(ServiceClass_: TDTService_NoAuthClas PhysicsTunnel.AutomatedP2PVMBindService.AddService(SendTunnel); PhysicsTunnel.AutomatedP2PVMService := True; - RecvTunnel.PrefixName := 'DTNoAuth'; - RecvTunnel.Name := 'Recv'; - SendTunnel.PrefixName := 'DTNoAuth'; - SendTunnel.Name := 'Send'; + RecvTunnel.PrefixName := 'NA'; + RecvTunnel.Name := 'R'; + SendTunnel.PrefixName := 'NA'; + SendTunnel.Name := 'S'; PhysicsTunnel.PrefixName := 'Physics'; PhysicsTunnel.Name := 'p2pVM'; end; @@ -3510,10 +3612,10 @@ constructor TDT_P2PVM_NoAuth_Client.Create(ClientClass_: TDTClient_NoAuthClass); AutomatedConnection := True; - RecvTunnel.PrefixName := 'DTNoAuth'; - RecvTunnel.Name := 'Recv'; - SendTunnel.PrefixName := 'DTNoAuth'; - SendTunnel.Name := 'Send'; + RecvTunnel.PrefixName := 'NA'; + RecvTunnel.Name := 'R'; + SendTunnel.PrefixName := 'NA'; + SendTunnel.Name := 'S'; PhysicsTunnel.PrefixName := 'Physics'; PhysicsTunnel.Name := 'p2pVM'; end; @@ -3642,13 +3744,13 @@ constructor TDT_P2PVM_NoAuth_Custom_Service.Create(ServiceClass_: TDTService_NoA Bind_P2PVM_Send_Port := umlStrToInt(P2PVM_Send_Port_); RecvTunnel := TCommunicationFrameworkWithP2PVM_Server.Create; - RecvTunnel.QuietMode := True; - RecvTunnel.PrefixName := 'DTNoAuth'; + RecvTunnel.QuietMode := PhysicsTunnel_.QuietMode; + RecvTunnel.PrefixName := 'NA'; RecvTunnel.Name := P2PVM_Recv_Name_; SendTunnel := TCommunicationFrameworkWithP2PVM_Server.Create; - SendTunnel.QuietMode := True; - SendTunnel.PrefixName := 'DTNoAuth'; + SendTunnel.QuietMode := PhysicsTunnel_.QuietMode; + SendTunnel.PrefixName := 'NA'; SendTunnel.Name := P2PVM_Send_Name_; DTService := ServiceClass_.Create(RecvTunnel, SendTunnel); @@ -3657,6 +3759,7 @@ constructor TDT_P2PVM_NoAuth_Custom_Service.Create(ServiceClass_: TDTService_NoA Bind_PhysicsTunnel.AutomatedP2PVMServiceBind.AddService(RecvTunnel); Bind_PhysicsTunnel.AutomatedP2PVMServiceBind.AddService(SendTunnel); + Bind_PhysicsTunnel.AutomatedP2PVMService := True; StartService(); end; @@ -3689,24 +3792,6 @@ procedure TDT_P2PVM_NoAuth_Custom_Service.StopService; RecvTunnel.StopService; end; -procedure TDT_P2PVM_NoAuth_Custom_Client.DoTunnelLinkResult(const state: Boolean); -begin - if Assigned(OnConnectResultState.OnCall) then - OnConnectResultState.OnCall(state); - if Assigned(OnConnectResultState.OnMethod) then - OnConnectResultState.OnMethod(state); - if Assigned(OnConnectResultState.OnProc) then - OnConnectResultState.OnProc(state); - OnConnectResultState.Init; - Connecting := False; - - if state then - begin - if AutomatedConnection then - Reconnection := True; - end; -end; - function TDT_P2PVM_NoAuth_Custom_Client.GetQuietMode: Boolean; begin Result := RecvTunnel.QuietMode and SendTunnel.QuietMode; @@ -3737,17 +3822,18 @@ constructor TDT_P2PVM_NoAuth_Custom_Client.Create(ClientClass_: TDTClient_NoAuth // local RecvTunnel := TCommunicationFrameworkWithP2PVM_Client.Create; - RecvTunnel.QuietMode := True; - RecvTunnel.PrefixName := 'DTNoAuth'; + RecvTunnel.QuietMode := PhysicsTunnel_.QuietMode; + RecvTunnel.PrefixName := 'NA'; RecvTunnel.Name := P2PVM_Recv_Name_; SendTunnel := TCommunicationFrameworkWithP2PVM_Client.Create; - SendTunnel.QuietMode := True; - SendTunnel.PrefixName := 'DTNoAuth'; + SendTunnel.QuietMode := PhysicsTunnel_.QuietMode; + SendTunnel.PrefixName := 'NA'; SendTunnel.Name := P2PVM_Send_Name_; DTClient := ClientClass_.Create(RecvTunnel, SendTunnel); DTClient.RegisterCommand; DTClient.SwitchAsDefaultPerformance; AutomatedConnection := True; + OnTunnelLink := nil; // automated p2pVM Bind_PhysicsTunnel.AutomatedP2PVMBindClient.AddClient(RecvTunnel, Bind_P2PVM_Recv_IP6, Bind_P2PVM_Recv_Port); @@ -3774,6 +3860,33 @@ procedure TDT_P2PVM_NoAuth_Custom_Client.Progress; Connect(); end; +procedure TDT_P2PVM_NoAuth_Custom_Client.DoTunnelLinkResult(const state: Boolean); +begin + if Assigned(OnConnectResultState.OnCall) then + OnConnectResultState.OnCall(state); + if Assigned(OnConnectResultState.OnMethod) then + OnConnectResultState.OnMethod(state); + if Assigned(OnConnectResultState.OnProc) then + OnConnectResultState.OnProc(state); + OnConnectResultState.Init; + Connecting := False; + + if state then + begin + if AutomatedConnection then + Reconnection := True; + + if Assigned(OnTunnelLink) then + OnTunnelLink(Self); + end; +end; + +procedure TDT_P2PVM_NoAuth_Custom_Client.AutoCheckPhysicsTunnelAndConnect; +begin + AutomatedConnection := True; + Reconnection := True; +end; + procedure TDT_P2PVM_NoAuth_Custom_Client.Connect; begin if Connecting then diff --git a/Source/CommunicationFrameworkDoubleTunnelIO_ServMan.pas b/Source/CommunicationFrameworkDoubleTunnelIO_ServMan.pas index b4365c8e..5035d957 100644 --- a/Source/CommunicationFrameworkDoubleTunnelIO_ServMan.pas +++ b/Source/CommunicationFrameworkDoubleTunnelIO_ServMan.pas @@ -312,7 +312,7 @@ procedure TServerManager_Client.AntiIdle(WorkLoad: Word); function TServerManager_Client.EnabledServer(const Regname, ManServAddr, RegAddr: SystemString; const RegRecvPort, RegSendPort: Word; ServerType: TServerType): Boolean; var - SendData, ResultData: TDataFrameEngine; + SendData, Result_: TDataFrameEngine; begin ConnectInfo.Regname := Regname; ConnectInfo.ManServAddr := ManServAddr; @@ -324,7 +324,7 @@ function TServerManager_Client.EnabledServer(const Regname, ManServAddr, RegAddr Result := False; SendData := TDataFrameEngine.Create; - ResultData := TDataFrameEngine.Create; + Result_ := TDataFrameEngine.Create; SendData.WriteString(ManServAddr); SendData.WriteString(Regname); @@ -336,16 +336,16 @@ function TServerManager_Client.EnabledServer(const Regname, ManServAddr, RegAddr DoStatus('send enabled cmd:%s %s [n:%s][addr:%s][r:%d][s:%d][w:%d]', [ManServAddr, serverType2Str(ServerType), Regname, RegAddr, RegRecvPort, RegSendPort, 0]); - SendTunnel.WaitSendStreamCmd(C_EnabledServer, SendData, ResultData, 5000); + SendTunnel.WaitSendStreamCmd(C_EnabledServer, SendData, Result_, 5000); - if ResultData.Count = 2 then + if Result_.Count = 2 then begin - Result := ResultData.Reader.ReadBool; - DoStatus(ResultData.Reader.ReadString); + Result := Result_.Reader.ReadBool; + DoStatus(Result_.Reader.ReadString); end; DisposeObject(SendData); - DisposeObject(ResultData); + DisposeObject(Result_); end; function TServerManager_ClientPool.GetItems(index: Integer): TServerManager_Client; diff --git a/Source/CommunicationFrameworkDoubleTunnelIO_VirtualAuth.pas b/Source/CommunicationFrameworkDoubleTunnelIO_VirtualAuth.pas index e6426f96..5e4c2397 100644 --- a/Source/CommunicationFrameworkDoubleTunnelIO_VirtualAuth.pas +++ b/Source/CommunicationFrameworkDoubleTunnelIO_VirtualAuth.pas @@ -97,6 +97,7 @@ TDTService_VirtualAuth = class(TCoreClassInterfacedObject) FLoginUserDefineIOList: THashObjectList; FCadencerEngine: TCadencer; FProgressEngine: TNProgressPost; + FFileSystem: Boolean; FFileReceiveDirectory: SystemString; { event } FOnUserAuth: TVirtualAuth_OnAuth; @@ -169,6 +170,7 @@ TDTService_VirtualAuth = class(TCoreClassInterfacedObject) property PostRun: TNProgressPost read FProgressEngine; property PostExecute: TNProgressPost read FProgressEngine; + property FileSystem: Boolean read FFileSystem write FFileSystem; property FileReceiveDirectory: SystemString read FFileReceiveDirectory write FFileReceiveDirectory; property PublicFileDirectory: SystemString read FFileReceiveDirectory write FFileReceiveDirectory; @@ -242,6 +244,7 @@ TClientUserDefineForSendTunnel_VirtualAuth = class(TPeerIOUserDefine) TDTClient_VirtualAuth = class(TCoreClassInterfacedObject, ICommunicationFrameworkClientInterface) protected FSendTunnel, FRecvTunnel: TCommunicationFrameworkClient; + FFileSystem: Boolean; FAutoFreeTunnel: Boolean; FLinkOk: Boolean; FWaitCommandTimeout: Cardinal; @@ -265,16 +268,16 @@ TDTClient_VirtualAuth = class(TCoreClassInterfacedObject, ICommunicationFramew procedure Command_PostFileOver(Sender: TPeerIO; InData: TDataFrameEngine); virtual; procedure Command_PostFileFragmentData(Sender: TPeerIO; InData: PByte; DataSize: NativeInt); virtual; - procedure GetCurrentCadencer_StreamResult(Sender: TPeerIO; ResultData: TDataFrameEngine); virtual; + procedure GetCurrentCadencer_StreamResult(Sender: TPeerIO; Result_: TDataFrameEngine); virtual; - procedure GetFileInfo_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); virtual; - procedure GetFileMD5_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); virtual; + procedure GetFileInfo_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); virtual; + procedure GetFileMD5_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); virtual; { Downloading files from the server asynchronously and triggering notifications when completed } - procedure GetFile_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); virtual; + procedure GetFile_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); virtual; { Downloading file fragment data from the server asynchronously and triggering notifications when completed } - procedure GetFileFragmentData_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); virtual; + procedure GetFileFragmentData_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); virtual; { batch stream suppport } procedure Command_NewBatchStream(Sender: TPeerIO; InData: TDataFrameEngine); virtual; @@ -291,9 +294,9 @@ TDTClient_VirtualAuth = class(TCoreClassInterfacedObject, ICommunicationFramew FAsyncOnResultProc: TStateProc; procedure AsyncSendConnectResult(const cState: Boolean); procedure AsyncRecvConnectResult(const cState: Boolean); - procedure UserLogin_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: TDataFrameEngine); + procedure UserLogin_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine); procedure UserLogin_OnFailed(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDataFrameEngine); - procedure TunnelLink_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: TDataFrameEngine); + procedure TunnelLink_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine); procedure TunnelLink_OnFailed(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDataFrameEngine); public constructor Create(RecvTunnel_, SendTunnel_: TCommunicationFrameworkClient); virtual; @@ -408,7 +411,7 @@ TDTClient_VirtualAuth = class(TCoreClassInterfacedObject, ICommunicationFramew procedure GetBatchStreamStateM(Param1: Pointer; Param2: TObject; OnResult: TStreamParamMethod); overload; procedure GetBatchStreamStateP(OnResult: TStreamProc); overload; procedure GetBatchStreamStateP(Param1: Pointer; Param2: TObject; OnResult: TStreamParamProc); overload; - function GetBatchStreamState(ResultData: TDataFrameEngine; ATimeOut: TTimeTick): Boolean; overload; + function GetBatchStreamState(Result_: TDataFrameEngine; ATimeOut: TTimeTick): Boolean; overload; procedure RegisterCommand; virtual; procedure UnRegisterCommand; virtual; @@ -494,6 +497,9 @@ TDT_P2PVM_VirtualAuth_Client = class(TCoreClassObject) TDT_P2PVM_VirtualAuth_ClientPool = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + TDT_P2PVM_VirtualAuth_Custom_Service = class; + TDT_P2PVM_VirtualAuth_Custom_Service_Class = class of TDT_P2PVM_VirtualAuth_Custom_Service; + TDT_P2PVM_VirtualAuth_Custom_Service = class(TCoreClassInterfacedObject) private function GetQuietMode: Boolean; @@ -511,23 +517,26 @@ TDT_P2PVM_VirtualAuth_Custom_Service = class(TCoreClassInterfacedObject) constructor Create(ServiceClass_: TDTService_VirtualAuthClass; PhysicsTunnel_: TCommunicationFrameworkServer; P2PVM_Recv_Name_, P2PVM_Recv_IP6_, P2PVM_Recv_Port_, - P2PVM_Send_Name_, P2PVM_Send_IP6_, P2PVM_Send_Port_: SystemString); + P2PVM_Send_Name_, P2PVM_Send_IP6_, P2PVM_Send_Port_: SystemString); virtual; destructor Destroy; override; procedure Progress; virtual; - procedure StartService(); - procedure StopService(); + procedure StartService(); virtual; + procedure StopService(); virtual; property QuietMode: Boolean read GetQuietMode write SetQuietMode; end; TDT_P2PVM_VirtualAuth_Custom_ServicePool = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + TDT_P2PVM_VirtualAuth_Custom_Client = class; + TDT_P2PVM_VirtualAuth_Custom_Client_Class = class of TDT_P2PVM_VirtualAuth_Custom_Client; + TOn_DT_P2PVM_VirtualAuth_Custom_Client_TunnelLink = procedure(Sender: TDT_P2PVM_VirtualAuth_Custom_Client) of object; + TDT_P2PVM_VirtualAuth_Custom_Client = class(TCoreClassInterfacedObject) private OnConnectResultState: TDT_P2PVM_VirtualAuth_OnState; Connecting: Boolean; Reconnection: Boolean; procedure DoLoginResult(const state: Boolean); - procedure DoTunnelLinkResult(const state: Boolean); function GetQuietMode: Boolean; procedure SetQuietMode(const Value: Boolean); @@ -543,17 +552,19 @@ TDT_P2PVM_VirtualAuth_Custom_Client = class(TCoreClassInterfacedObject) DTClient: TDTClient_VirtualAuth; LastUser, LastPasswd: SystemString; AutomatedConnection: Boolean; + OnTunnelLink: TOn_DT_P2PVM_VirtualAuth_Custom_Client_TunnelLink; constructor Create(ClientClass_: TDTClient_VirtualAuthClass; PhysicsTunnel_: TCommunicationFrameworkClient; P2PVM_Recv_Name_, P2PVM_Recv_IP6_, P2PVM_Recv_Port_, - P2PVM_Send_Name_, P2PVM_Send_IP6_, P2PVM_Send_Port_: SystemString); + P2PVM_Send_Name_, P2PVM_Send_IP6_, P2PVM_Send_Port_: SystemString); virtual; destructor Destroy; override; procedure Progress; virtual; - procedure Connect(User, Passwd: SystemString); - procedure Connect_C(User, Passwd: SystemString; OnResult: TStateCall); - procedure Connect_M(User, Passwd: SystemString; OnResult: TStateMethod); - procedure Connect_P(User, Passwd: SystemString; OnResult: TStateProc); - procedure Disconnect; + procedure DoTunnelLinkResult(const state: Boolean); virtual; + procedure Connect(User, Passwd: SystemString); virtual; + procedure Connect_C(User, Passwd: SystemString; OnResult: TStateCall); virtual; + procedure Connect_M(User, Passwd: SystemString; OnResult: TStateMethod); virtual; + procedure Connect_P(User, Passwd: SystemString; OnResult: TStateProc); virtual; + procedure Disconnect; virtual; property QuietMode: Boolean read GetQuietMode write SetQuietMode; end; @@ -945,8 +956,11 @@ function TPeerClientUserDefineForRecvTunnel_VirtualAuth.LinkOk: Boolean; procedure TDTService_VirtualAuth.UserAuth(Sender: TVirtualAuthIO); begin - if Assigned(FOnUserAuth) then - FOnUserAuth(Self, Sender); + try + if Assigned(FOnUserAuth) then + FOnUserAuth(Self, Sender); + except + end; end; procedure TDTService_VirtualAuth.UserLoginSuccess(UserDefineIO: TPeerClientUserDefineForRecvTunnel_VirtualAuth); @@ -955,14 +969,20 @@ procedure TDTService_VirtualAuth.UserLoginSuccess(UserDefineIO: TPeerClientUserD procedure TDTService_VirtualAuth.UserLinkSuccess(UserDefineIO: TPeerClientUserDefineForRecvTunnel_VirtualAuth); begin - if Assigned(FOnLinkSuccess) then - FOnLinkSuccess(Self, UserDefineIO); + try + if Assigned(FOnLinkSuccess) then + FOnLinkSuccess(Self, UserDefineIO); + except + end; end; procedure TDTService_VirtualAuth.UserOut(UserDefineIO: TPeerClientUserDefineForRecvTunnel_VirtualAuth); begin - if Assigned(FOnUserOut) then - FOnUserOut(Self, UserDefineIO); + try + if Assigned(FOnUserOut) then + FOnUserOut(Self, UserDefineIO); + except + end; end; procedure TDTService_VirtualAuth.UserPostFileSuccess(UserDefineIO: TPeerClientUserDefineForRecvTunnel_VirtualAuth; fn: SystemString); @@ -1030,6 +1050,7 @@ procedure TDTService_VirtualAuth.Command_TunnelLink(Sender: TPeerIO; InData, Out begin OutData.WriteBool(False); OutData.WriteString(Format('need login or register', [])); + OutData.WriteBool(FFileSystem); exit; end; @@ -1037,6 +1058,7 @@ procedure TDTService_VirtualAuth.Command_TunnelLink(Sender: TPeerIO; InData, Out begin OutData.WriteBool(False); OutData.WriteString(Format('send tunnel Illegal:%d', [SendID])); + OutData.WriteBool(FFileSystem); exit; end; @@ -1044,6 +1066,7 @@ procedure TDTService_VirtualAuth.Command_TunnelLink(Sender: TPeerIO; InData, Out begin OutData.WriteBool(False); OutData.WriteString(Format('recv tunnel Illegal:%d', [RecvID])); + OutData.WriteBool(FFileSystem); exit; end; @@ -1051,6 +1074,7 @@ procedure TDTService_VirtualAuth.Command_TunnelLink(Sender: TPeerIO; InData, Out begin OutData.WriteBool(False); OutData.WriteString(Format('recv tunnel Illegal:%d-%d', [Sender.ID, RecvID])); + OutData.WriteBool(FFileSystem); exit; end; @@ -1064,6 +1088,7 @@ procedure TDTService_VirtualAuth.Command_TunnelLink(Sender: TPeerIO; InData, Out OutData.WriteBool(True); OutData.WriteString(Format('tunnel link success! recv:%d <-> send:%d', [RecvID, SendID])); + OutData.WriteBool(FFileSystem); UserLinkSuccess(UserDefineIO); end; @@ -1079,6 +1104,8 @@ procedure TDTService_VirtualAuth.Command_GetFileTime(Sender: TPeerIO; InData, Ou UserDefineIO: TPeerClientUserDefineForRecvTunnel_VirtualAuth; fullfn, fileName: SystemString; begin + if not FFileSystem then + exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then exit; @@ -1100,6 +1127,8 @@ procedure TDTService_VirtualAuth.Command_GetFileInfo(Sender: TPeerIO; InData, Ou UserDefineIO: TPeerClientUserDefineForRecvTunnel_VirtualAuth; fullfn, fileName: SystemString; begin + if not FFileSystem then + exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then exit; @@ -1127,6 +1156,8 @@ procedure TDTService_VirtualAuth.Command_GetFileMD5(Sender: TPeerIO; InData, Out fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then exit; @@ -1172,6 +1203,8 @@ procedure TDTService_VirtualAuth.Command_GetFile(Sender: TPeerIO; InData, OutDat fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then exit; @@ -1228,6 +1261,8 @@ procedure TDTService_VirtualAuth.Command_GetFileAs(Sender: TPeerIO; InData, OutD fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then exit; @@ -1283,6 +1318,8 @@ procedure TDTService_VirtualAuth.Command_PostFileInfo(Sender: TPeerIO; InData: T FSize: Int64; fullfn: SystemString; begin + if not FFileSystem then + exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then begin @@ -1327,6 +1364,8 @@ procedure TDTService_VirtualAuth.Command_PostFile(Sender: TPeerIO; InData: TCore var UserDefineIO: TPeerClientUserDefineForRecvTunnel_VirtualAuth; begin + if not FFileSystem then + exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then begin @@ -1348,6 +1387,8 @@ procedure TDTService_VirtualAuth.Command_PostFileOver(Sender: TPeerIO; InData: T ClientMD5, MD5: TMD5; fn: SystemString; begin + if not FFileSystem then + exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then begin @@ -1387,6 +1428,8 @@ procedure TDTService_VirtualAuth.Command_GetFileFragmentData(Sender: TPeerIO; In mem_: TMemoryStream64; MD5: TMD5; begin + if not FFileSystem then + exit; UserDefineIO := GetUserDefineRecvTunnel(Sender); if not UserDefineIO.LinkOk then exit; @@ -1585,6 +1628,7 @@ constructor TDTService_VirtualAuth.Create(RecvTunnel_, SendTunnel_: TCommunicati FCadencerEngine.OnProgress := {$IFDEF FPC}@{$ENDIF FPC}CadencerProgress; FProgressEngine := TNProgressPost.Create; + FFileSystem := True; FFileReceiveDirectory := umlCurrentPath; if not umlDirectoryExists(FFileReceiveDirectory) then @@ -2011,11 +2055,11 @@ procedure TDTClient_VirtualAuth.Command_PostFileFragmentData(Sender: TPeerIO; In end; end; -procedure TDTClient_VirtualAuth.GetCurrentCadencer_StreamResult(Sender: TPeerIO; ResultData: TDataFrameEngine); +procedure TDTClient_VirtualAuth.GetCurrentCadencer_StreamResult(Sender: TPeerIO; Result_: TDataFrameEngine); var servTime: Double; begin - servTime := ResultData.Reader.ReadDouble; + servTime := Result_.Reader.ReadDouble; FCadencerEngine.Progress; FServerDelay := FCadencerEngine.CurrentTime - FLastCadencerTime; @@ -2024,15 +2068,15 @@ procedure TDTClient_VirtualAuth.GetCurrentCadencer_StreamResult(Sender: TPeerIO; FCadencerEngine.Progress; end; -procedure TDTClient_VirtualAuth.GetFileInfo_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); +procedure TDTClient_VirtualAuth.GetFileInfo_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); var p: PGetFileInfoStruct_VirtualAuth; Existed: Boolean; fSiz: Int64; begin p := PGetFileInfoStruct_VirtualAuth(Param1); - Existed := ResultData.Reader.ReadBool; - fSiz := ResultData.Reader.ReadInt64; + Existed := Result_.Reader.ReadBool; + fSiz := Result_.Reader.ReadInt64; if p <> nil then begin if Assigned(p^.OnCompleteCall) then @@ -2046,16 +2090,16 @@ procedure TDTClient_VirtualAuth.GetFileInfo_StreamParamResult(Sender: TPeerIO; P end; end; -procedure TDTClient_VirtualAuth.GetFileMD5_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); +procedure TDTClient_VirtualAuth.GetFileMD5_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); var p: PFileMD5Struct_VirtualAuth; successed: Boolean; MD5: TMD5; begin p := PFileMD5Struct_VirtualAuth(Param1); - successed := ResultData.Reader.ReadBool; + successed := Result_.Reader.ReadBool; if successed then - MD5 := ResultData.Reader.ReadMD5 + MD5 := Result_.Reader.ReadMD5 else MD5 := NullMD5; if p <> nil then @@ -2071,28 +2115,28 @@ procedure TDTClient_VirtualAuth.GetFileMD5_StreamParamResult(Sender: TPeerIO; Pa end; end; -procedure TDTClient_VirtualAuth.GetFile_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); +procedure TDTClient_VirtualAuth.GetFile_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); var p: PRemoteFileBackcall_VirtualAuth; begin - if ResultData.Count > 0 then + if Result_.Count > 0 then begin - if ResultData.Reader.ReadBool then + if Result_.Reader.ReadBool then exit; - Sender.Print('get file failed:%s', [ResultData.Reader.ReadString]); + Sender.Print('get file failed:%s', [Result_.Reader.ReadString]); end; p := Param1; Dispose(p); end; -procedure TDTClient_VirtualAuth.GetFileFragmentData_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, ResultData: TDataFrameEngine); +procedure TDTClient_VirtualAuth.GetFileFragmentData_StreamParamResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; InData, Result_: TDataFrameEngine); var p: PFileFragmentDataBackcall_VirtualAuth; begin - if ResultData.Count > 0 then + if Result_.Count > 0 then begin - if ResultData.Reader.ReadBool then + if Result_.Reader.ReadBool then exit; end; @@ -2274,17 +2318,17 @@ procedure TDTClient_VirtualAuth.AsyncRecvConnectResult(const cState: Boolean); FAsyncOnResultProc := nil; end; -procedure TDTClient_VirtualAuth.UserLogin_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: TDataFrameEngine); +procedure TDTClient_VirtualAuth.UserLogin_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine); var r: Boolean; p: POnStateStruct; begin p := Param1; r := False; - if ResultData.Count > 0 then + if Result_.Count > 0 then begin - r := ResultData.ReadBool(0); - FSendTunnel.ClientIO.Print(ResultData.ReadString(1)); + r := Result_.ReadBool(0); + FSendTunnel.ClientIO.Print(Result_.ReadString(1)); end; if Assigned(p^.OnCall) then @@ -2312,20 +2356,24 @@ procedure TDTClient_VirtualAuth.UserLogin_OnFailed(Sender: TPeerIO; Param1: Poin Dispose(p); end; -procedure TDTClient_VirtualAuth.TunnelLink_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, ResultData: TDataFrameEngine); +procedure TDTClient_VirtualAuth.TunnelLink_OnResult(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDataFrameEngine); var r: Boolean; p: POnStateStruct; begin p := Param1; r := False; - if ResultData.Count > 0 then + if Result_.Count > 0 then begin - r := ResultData.ReadBool(0); - FSendTunnel.ClientIO.Print(ResultData.ReadString(1)); + r := Result_.ReadBool(0); + FSendTunnel.ClientIO.Print(Result_.ReadString(1)); if r then begin + if Result_.Count >= 2 then + FFileSystem := Result_.ReadBool(2) + else + FFileSystem := True; TClientUserDefineForSendTunnel_VirtualAuth(FSendTunnel.ClientIO.UserDefine).Client := Self; TClientUserDefineForSendTunnel_VirtualAuth(FSendTunnel.ClientIO.UserDefine).RecvTunnel := TClientUserDefineForRecvTunnel_VirtualAuth(FRecvTunnel.ClientIO.UserDefine); @@ -2375,6 +2423,7 @@ constructor TDTClient_VirtualAuth.Create(RecvTunnel_, SendTunnel_: TCommunicatio FRecvTunnel.DoubleChannelFramework := Self; FSendTunnel.DoubleChannelFramework := Self; + FFileSystem := False; FAutoFreeTunnel := False; FLinkOk := False; @@ -2649,6 +2698,10 @@ function TDTClient_VirtualAuth.TunnelLink: Boolean; if Result then begin + if resDE.Count >= 2 then + FFileSystem := resDE.ReadBool(2) + else + FFileSystem := True; TClientUserDefineForSendTunnel_VirtualAuth(FSendTunnel.ClientIO.UserDefine).Client := Self; TClientUserDefineForSendTunnel_VirtualAuth(FSendTunnel.ClientIO.UserDefine).RecvTunnel := TClientUserDefineForRecvTunnel_VirtualAuth(FRecvTunnel.ClientIO.UserDefine); @@ -2828,6 +2881,8 @@ procedure TDTClient_VirtualAuth.GetFileTimeM(RemoteFilename: SystemString; OnCal var sendDE: TDataFrameEngine; begin + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -2843,6 +2898,8 @@ procedure TDTClient_VirtualAuth.GetFileTimeP(RemoteFilename: SystemString; OnCal var sendDE: TDataFrameEngine; begin + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -2860,6 +2917,8 @@ procedure TDTClient_VirtualAuth.GetFileInfoC(fileName: SystemString; const UserD sendDE: TDataFrameEngine; p: PGetFileInfoStruct_VirtualAuth; begin + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -2885,6 +2944,8 @@ procedure TDTClient_VirtualAuth.GetFileInfoM(fileName: SystemString; const UserD sendDE: TDataFrameEngine; p: PGetFileInfoStruct_VirtualAuth; begin + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -2910,6 +2971,8 @@ procedure TDTClient_VirtualAuth.GetFileInfoP(fileName: SystemString; const UserD sendDE: TDataFrameEngine; p: PGetFileInfoStruct_VirtualAuth; begin + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -2937,6 +3000,8 @@ procedure TDTClient_VirtualAuth.GetFileMD5C(fileName: SystemString; const StartP sendDE: TDataFrameEngine; p: PFileMD5Struct_VirtualAuth; begin + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -2967,6 +3032,8 @@ procedure TDTClient_VirtualAuth.GetFileMD5M(fileName: SystemString; const StartP sendDE: TDataFrameEngine; p: PFileMD5Struct_VirtualAuth; begin + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -2997,6 +3064,8 @@ procedure TDTClient_VirtualAuth.GetFileMD5P(fileName: SystemString; const StartP sendDE: TDataFrameEngine; p: PFileMD5Struct_VirtualAuth; begin + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -3050,6 +3119,8 @@ procedure TDTClient_VirtualAuth.GetFileC(fileName: SystemString; StartPos: Int64 sendDE: TDataFrameEngine; p: PRemoteFileBackcall_VirtualAuth; begin + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -3077,6 +3148,8 @@ procedure TDTClient_VirtualAuth.GetFileM(fileName: SystemString; StartPos: Int64 sendDE: TDataFrameEngine; p: PRemoteFileBackcall_VirtualAuth; begin + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -3104,6 +3177,8 @@ procedure TDTClient_VirtualAuth.GetFileP(fileName: SystemString; StartPos: Int64 sendDE: TDataFrameEngine; p: PRemoteFileBackcall_VirtualAuth; begin + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -3131,6 +3206,8 @@ procedure TDTClient_VirtualAuth.GetFileAsC(fileName, saveFileName: SystemString; sendDE: TDataFrameEngine; p: PRemoteFileBackcall_VirtualAuth; begin + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -3159,6 +3236,8 @@ procedure TDTClient_VirtualAuth.GetFileAsM(fileName, saveFileName: SystemString; sendDE: TDataFrameEngine; p: PRemoteFileBackcall_VirtualAuth; begin + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -3187,6 +3266,8 @@ procedure TDTClient_VirtualAuth.GetFileAsP(fileName, saveFileName: SystemString; sendDE: TDataFrameEngine; p: PRemoteFileBackcall_VirtualAuth; begin + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -3216,6 +3297,8 @@ function TDTClient_VirtualAuth.GetFile(fileName: SystemString; StartPos: Int64; sendDE, resDE: TDataFrameEngine; begin Result := False; + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -3247,6 +3330,8 @@ procedure TDTClient_VirtualAuth.GetFileFragmentDataC(fileName: SystemString; Sta sendDE: TDataFrameEngine; p: PFileFragmentDataBackcall_VirtualAuth; begin + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -3279,6 +3364,8 @@ procedure TDTClient_VirtualAuth.GetFileFragmentDataM(fileName: SystemString; Sta sendDE: TDataFrameEngine; p: PFileFragmentDataBackcall_VirtualAuth; begin + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -3311,6 +3398,8 @@ procedure TDTClient_VirtualAuth.GetFileFragmentDataP(fileName: SystemString; Sta sendDE: TDataFrameEngine; p: PFileFragmentDataBackcall_VirtualAuth; begin + if not FFileSystem then + exit; if not FSendTunnel.Connected then exit; if not FRecvTunnel.Connected then @@ -3341,6 +3430,8 @@ procedure TDTClient_VirtualAuth.AutomatedDownloadFileC(remoteFile, localFile: U_ var tmp: TAutomatedDownloadFile_Struct_VirtualAuth; begin + if not FFileSystem then + exit; tmp := TAutomatedDownloadFile_Struct_VirtualAuth.Create; tmp.remoteFile := remoteFile; tmp.localFile := localFile; @@ -3354,6 +3445,8 @@ procedure TDTClient_VirtualAuth.AutomatedDownloadFileM(remoteFile, localFile: U_ var tmp: TAutomatedDownloadFile_Struct_VirtualAuth; begin + if not FFileSystem then + exit; tmp := TAutomatedDownloadFile_Struct_VirtualAuth.Create; tmp.remoteFile := remoteFile; tmp.localFile := localFile; @@ -3367,6 +3460,8 @@ procedure TDTClient_VirtualAuth.AutomatedDownloadFileP(remoteFile, localFile: U_ var tmp: TAutomatedDownloadFile_Struct_VirtualAuth; begin + if not FFileSystem then + exit; tmp := TAutomatedDownloadFile_Struct_VirtualAuth.Create; tmp.remoteFile := remoteFile; tmp.localFile := localFile; @@ -3382,6 +3477,8 @@ procedure TDTClient_VirtualAuth.PostFile(fileName: SystemString); fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + exit; if not umlFileExists(fileName) then exit; if not FSendTunnel.Connected then @@ -3415,6 +3512,8 @@ procedure TDTClient_VirtualAuth.PostFile(fileName: SystemString; StartPos: Int64 fs: TCoreClassFileStream; MD5: TMD5; begin + if not FFileSystem then + exit; if not umlFileExists(fileName) then exit; if not FSendTunnel.Connected then @@ -3447,9 +3546,10 @@ procedure TDTClient_VirtualAuth.PostFile(fn: SystemString; stream: TCoreClassStr sendDE: TDataFrameEngine; MD5: TMD5; begin - if (not FSendTunnel.Connected) or (not FRecvTunnel.Connected) then + if (not FSendTunnel.Connected) or (not FRecvTunnel.Connected) or (not FFileSystem) then begin - DisposeObject(stream); + if doneFreeStream then + DisposeObject(stream); exit; end; @@ -3477,9 +3577,10 @@ procedure TDTClient_VirtualAuth.PostFile(fn: SystemString; stream: TCoreClassStr sendDE: TDataFrameEngine; MD5: TMD5; begin - if (not FSendTunnel.Connected) or (not FRecvTunnel.Connected) then + if (not FSendTunnel.Connected) or (not FRecvTunnel.Connected) or (not FFileSystem) then begin - DisposeObject(stream); + if doneFreeStream then + DisposeObject(stream); exit; end; @@ -3506,6 +3607,8 @@ procedure TDTClient_VirtualAuth.AutomatedUploadFile(localFile: U_String); var tmp: TAutomatedUploadFile_Struct_VirtualAuth; begin + if not FFileSystem then + exit; tmp := TAutomatedUploadFile_Struct_VirtualAuth.Create; tmp.localFile := localFile; tmp.Client := Self; @@ -3645,13 +3748,13 @@ procedure TDTClient_VirtualAuth.GetBatchStreamStateP(Param1: Pointer; Param2: TO DisposeObject(de); end; -function TDTClient_VirtualAuth.GetBatchStreamState(ResultData: TDataFrameEngine; ATimeOut: TTimeTick): Boolean; +function TDTClient_VirtualAuth.GetBatchStreamState(Result_: TDataFrameEngine; ATimeOut: TTimeTick): Boolean; var de: TDataFrameEngine; begin de := TDataFrameEngine.Create; - SendTunnel.WaitSendStreamCmd(C_GetBatchStreamState, de, ResultData, ATimeOut); - Result := ResultData.Count > 0; + SendTunnel.WaitSendStreamCmd(C_GetBatchStreamState, de, Result_, ATimeOut); + Result := Result_.Count > 0; DisposeObject(de); end; @@ -3726,10 +3829,10 @@ constructor TDT_P2PVM_VirtualAuth_Service.Create(ServiceClass_: TDTService_Virtu PhysicsTunnel.AutomatedP2PVMBindService.AddService(SendTunnel); PhysicsTunnel.AutomatedP2PVMService := True; - RecvTunnel.PrefixName := 'DTVirtualAuth'; - RecvTunnel.Name := 'Recv'; - SendTunnel.PrefixName := 'DTVirtualAuth'; - SendTunnel.Name := 'Send'; + RecvTunnel.PrefixName := 'VA'; + RecvTunnel.Name := 'R'; + SendTunnel.PrefixName := 'VA'; + SendTunnel.Name := 'S'; PhysicsTunnel.PrefixName := 'Physics'; PhysicsTunnel.Name := 'p2pVM'; end; @@ -3874,10 +3977,10 @@ constructor TDT_P2PVM_VirtualAuth_Client.Create(ClientClass_: TDTClient_VirtualA AutomatedConnection := True; - RecvTunnel.PrefixName := 'DTVirtualAuth'; - RecvTunnel.Name := 'Recv'; - SendTunnel.PrefixName := 'DTVirtualAuth'; - SendTunnel.Name := 'Send'; + RecvTunnel.PrefixName := 'VA'; + RecvTunnel.Name := 'R'; + SendTunnel.PrefixName := 'VA'; + SendTunnel.Name := 'S'; PhysicsTunnel.PrefixName := 'Physics'; PhysicsTunnel.Name := 'p2pVM'; end; @@ -4014,13 +4117,13 @@ constructor TDT_P2PVM_VirtualAuth_Custom_Service.Create(ServiceClass_: TDTServic Bind_P2PVM_Send_Port := umlStrToInt(P2PVM_Send_Port_); RecvTunnel := TCommunicationFrameworkWithP2PVM_Server.Create; - RecvTunnel.QuietMode := True; - RecvTunnel.PrefixName := 'DTVirtualAuth'; + RecvTunnel.QuietMode := PhysicsTunnel_.QuietMode; + RecvTunnel.PrefixName := 'VA'; RecvTunnel.Name := P2PVM_Recv_Name_; SendTunnel := TCommunicationFrameworkWithP2PVM_Server.Create; - SendTunnel.QuietMode := True; - SendTunnel.PrefixName := 'DTVirtualAuth'; + SendTunnel.QuietMode := PhysicsTunnel_.QuietMode; + SendTunnel.PrefixName := 'VA'; SendTunnel.Name := P2PVM_Send_Name_; DTService := ServiceClass_.Create(RecvTunnel, SendTunnel); @@ -4029,6 +4132,7 @@ constructor TDT_P2PVM_VirtualAuth_Custom_Service.Create(ServiceClass_: TDTServic Bind_PhysicsTunnel.AutomatedP2PVMServiceBind.AddService(RecvTunnel); Bind_PhysicsTunnel.AutomatedP2PVMServiceBind.AddService(SendTunnel); + Bind_PhysicsTunnel.AutomatedP2PVMService := True; StartService(); end; @@ -4079,24 +4183,6 @@ procedure TDT_P2PVM_VirtualAuth_Custom_Client.DoLoginResult(const state: Boolean DTClient.TunnelLinkM({$IFDEF FPC}@{$ENDIF FPC}DoTunnelLinkResult); end; -procedure TDT_P2PVM_VirtualAuth_Custom_Client.DoTunnelLinkResult(const state: Boolean); -begin - if Assigned(OnConnectResultState.OnCall) then - OnConnectResultState.OnCall(state); - if Assigned(OnConnectResultState.OnMethod) then - OnConnectResultState.OnMethod(state); - if Assigned(OnConnectResultState.OnProc) then - OnConnectResultState.OnProc(state); - OnConnectResultState.Init; - Connecting := False; - - if state then - begin - if AutomatedConnection then - Reconnection := True; - end; -end; - function TDT_P2PVM_VirtualAuth_Custom_Client.GetQuietMode: Boolean; begin Result := RecvTunnel.QuietMode and SendTunnel.QuietMode; @@ -4127,12 +4213,12 @@ constructor TDT_P2PVM_VirtualAuth_Custom_Client.Create(ClientClass_: TDTClient_V // local RecvTunnel := TCommunicationFrameworkWithP2PVM_Client.Create; - RecvTunnel.QuietMode := True; - RecvTunnel.PrefixName := 'DTVirtualAuth'; + RecvTunnel.QuietMode := PhysicsTunnel_.QuietMode; + RecvTunnel.PrefixName := 'VA'; RecvTunnel.Name := P2PVM_Recv_Name_; SendTunnel := TCommunicationFrameworkWithP2PVM_Client.Create; - SendTunnel.QuietMode := True; - SendTunnel.PrefixName := 'DTVirtualAuth'; + SendTunnel.QuietMode := PhysicsTunnel_.QuietMode; + SendTunnel.PrefixName := 'VA'; SendTunnel.Name := P2PVM_Send_Name_; DTClient := ClientClass_.Create(RecvTunnel, SendTunnel); DTClient.RegisterCommand; @@ -4140,6 +4226,7 @@ constructor TDT_P2PVM_VirtualAuth_Custom_Client.Create(ClientClass_: TDTClient_V LastUser := ''; LastPasswd := ''; AutomatedConnection := True; + OnTunnelLink := nil; // automated p2pVM Bind_PhysicsTunnel.AutomatedP2PVMBindClient.AddClient(RecvTunnel, Bind_P2PVM_Recv_IP6, Bind_P2PVM_Recv_Port); @@ -4166,6 +4253,27 @@ procedure TDT_P2PVM_VirtualAuth_Custom_Client.Progress; Connect(LastUser, LastPasswd); end; +procedure TDT_P2PVM_VirtualAuth_Custom_Client.DoTunnelLinkResult(const state: Boolean); +begin + if Assigned(OnConnectResultState.OnCall) then + OnConnectResultState.OnCall(state); + if Assigned(OnConnectResultState.OnMethod) then + OnConnectResultState.OnMethod(state); + if Assigned(OnConnectResultState.OnProc) then + OnConnectResultState.OnProc(state); + OnConnectResultState.Init; + Connecting := False; + + if state then + begin + if AutomatedConnection then + Reconnection := True; + + if Assigned(OnTunnelLink) then + OnTunnelLink(Self); + end; +end; + procedure TDT_P2PVM_VirtualAuth_Custom_Client.Connect(User, Passwd: SystemString); begin if Connecting then diff --git a/Source/CoreClasses.pas b/Source/CoreClasses.pas index 617c9f74..948299dd 100644 --- a/Source/CoreClasses.pas +++ b/Source/CoreClasses.pas @@ -48,6 +48,7 @@ interface PTimeTick = ^TTimeTick; TSeekOrigin = Classes.TSeekOrigin; TNotify = Classes.TNotifyEvent; + TArrayBool = Array of Boolean; TArrayInt64 = Array of Int64; TArrayUInt64 = Array of UInt64; TInt64Buffer = Array [0 .. MaxInt div SizeOf(Int64) - 1] of Int64; @@ -642,6 +643,8 @@ {$IFDEF FPC}generic{$ENDIF FPC}TLineProcessor = class CPU64 = {$IFDEF CPU64}True{$ELSE CPU64}False{$IFEND CPU64}; X64 = CPU64; + IsDebug = {$IFDEF DEBUG}True{$ELSE DEBUG}False{$ENDIF DEBUG}; + // timetick define C_Tick_Second = TTimeTick(1000); C_Tick_Minute = TTimeTick(C_Tick_Second) * 60; diff --git a/Source/DTC40.pas b/Source/DTC40.pas new file mode 100644 index 00000000..6f60b454 --- /dev/null +++ b/Source/DTC40.pas @@ -0,0 +1,4084 @@ +{ ****************************************************************************** } +{ * cloud 4.0 framework * } +{ ****************************************************************************** } +{ * https://zpascal.net * } +{ * https://github.com/PassByYou888/zAI * } +{ * https://github.com/PassByYou888/ZServer4D * } +{ * https://github.com/PassByYou888/PascalString * } +{ * https://github.com/PassByYou888/zRasterization * } +{ * https://github.com/PassByYou888/CoreCipher * } +{ * https://github.com/PassByYou888/zSound * } +{ * https://github.com/PassByYou888/zChinese * } +{ * https://github.com/PassByYou888/zExpression * } +{ * https://github.com/PassByYou888/zGameWare * } +{ * https://github.com/PassByYou888/zAnalysis * } +{ * https://github.com/PassByYou888/FFMPEG-Header * } +{ * https://github.com/PassByYou888/zTranslate * } +{ * https://github.com/PassByYou888/InfiniteIoT * } +{ * https://github.com/PassByYou888/FastMD5 * } +{ ****************************************************************************** } +unit DTC40; + +{$INCLUDE zDefine.inc} + +interface + +uses +{$IFDEF FPC} + FPCGenericStructlist, +{$ELSE FPC} + System.IOUtils, +{$ENDIF FPC} + CoreClasses, PascalStrings, DoStatusIO, UnicodeMixedLib, ListEngine, + Geometry2DUnit, DataFrameEngine, ZJson, + NotifyObjectBase, CoreCipher, MemoryStream64, + CommunicationFramework, PhysicsIO, + CommunicationFrameworkDoubleTunnelIO, + CommunicationFrameworkDataStoreService, + CommunicationFrameworkDoubleTunnelIO_VirtualAuth, + CommunicationFrameworkDataStoreService_VirtualAuth, + CommunicationFrameworkDoubleTunnelIO_NoAuth, + CommunicationFrameworkDataStoreService_NoAuth; + +type + TDTC40_PhysicsService = class; + TDTC40_PhysicsServicePool = class; + TDTC40_PhysicsTunnel = class; + TDTC40_PhysicsTunnelPool = class; + TDTC40_Info = class; + TDTC40_InfoList = class; + TDTC40_Custom_Service = class; + TDTC40_Custom_ServicePool = class; + TDTC40_Custom_Client = class; + TDTC40_Custom_ClientPool = class; + TDTC40_Dispatch_Service = class; + TDTC40_Dispatch_Client = class; + TDTC40_Base_NoAuth_Service = class; + TDTC40_Base_NoAuth_Client = class; + TDTC40_Base_DataStoreNoAuth_Service = class; + TDTC40_Base_DataStoreNoAuth_Client = class; + TDTC40_Base_VirtualAuth_Service = class; + TDTC40_Base_VirtualAuth_Client = class; + TDTC40_Base_DataStoreVirtualAuth_Service = class; + TDTC40_Base_DataStoreVirtualAuth_Client = class; + +{$REGION 'PhysicsService'} + TDTC40_DependNetworkString = U_StringArray; + + TDTC40_DependNetworkInfo = record + Typ: U_String; + Param: U_String; + end; + + TDTC40_DependNetworkInfoArray = array of TDTC40_DependNetworkInfo; + + IDTC40_PhysicsService_Event = interface + procedure DTC40_PhysicsService_Build_Network(Sender: TDTC40_PhysicsService; Custom_Service_: TDTC40_Custom_Service); + procedure DTC40_PhysicsService_Start(Sender: TDTC40_PhysicsService); + procedure DTC40_PhysicsService_Stop(Sender: TDTC40_PhysicsService); + procedure DTC40_PhysicsService_LinkSuccess(Sender: TDTC40_PhysicsService; Custom_Service_: TDTC40_Custom_Service; Trigger_: TCoreClassObject); + procedure DTC40_PhysicsService_UserOut(Sender: TDTC40_PhysicsService; Custom_Service_: TDTC40_Custom_Service; Trigger_: TCoreClassObject); + end; + + { automated physics service } + TDTC40_PhysicsService = class(TCoreClassInterfacedObject) + private + FActivted: Boolean; + procedure cmd_QueryInfo(Sender: TPeerIO; InData, OutData: TDFE); + public + PhysicsAddr: U_String; + PhysicsPort: Word; + PhysicsTunnel: TCommunicationFrameworkServer; + AutoFreePhysicsTunnel: Boolean; + DependNetworkServicePool: TDTC40_Custom_ServicePool; + OnEvent: IDTC40_PhysicsService_Event; + { api } + constructor Create(PhysicsAddr_: U_String; PhysicsPort_: Word; PhysicsTunnel_: TCommunicationFrameworkServer); virtual; + destructor Destroy; override; + procedure Progress; virtual; + function BuildDependNetwork(const Depend_: TDTC40_DependNetworkInfoArray): Boolean; overload; + function BuildDependNetwork(const Depend_: TDTC40_DependNetworkString): Boolean; overload; + function BuildDependNetwork(const Depend_: U_String): Boolean; overload; + property Activted: Boolean read FActivted; + procedure StartService; virtual; + procedure StopService; virtual; + { event } + procedure DoLinkSuccess(Custom_Service_: TDTC40_Custom_Service; Trigger_: TCoreClassObject); + procedure DoUserOut(Custom_Service_: TDTC40_Custom_Service; Trigger_: TCoreClassObject); + end; + + TDTC40_PhysicsServicePool_Decl = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + + TDTC40_PhysicsServicePool = class(TDTC40_PhysicsServicePool_Decl) + public + procedure Progress; + function ExistsPhysicsAddr(PhysicsAddr: U_String; PhysicsPort: Word): Boolean; + end; +{$ENDREGION 'PhysicsService'} +{$REGION 'PhysicsTunnel'} + + TDCT40_OnQueryResultC = procedure(Sender: TDTC40_PhysicsTunnel; L: TDTC40_InfoList); + TDCT40_OnQueryResultM = procedure(Sender: TDTC40_PhysicsTunnel; L: TDTC40_InfoList) of object; +{$IFDEF FPC} + TDCT40_OnQueryResultP = procedure(Sender: TDTC40_PhysicsTunnel; L: TDTC40_InfoList) is nested; +{$ELSE FPC} + TDCT40_OnQueryResultP = reference to procedure(Sender: TDTC40_PhysicsTunnel; L: TDTC40_InfoList); +{$ENDIF FPC} + + TDCT40_QueryResultData = class + private + procedure DoStreamParam(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); + procedure DoStreamFailed(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); + procedure DoRun; + public + DTC40_PhysicsTunnel: TDTC40_PhysicsTunnel; + L: TDTC40_InfoList; + OnResultC: TDCT40_OnQueryResultC; + OnResultM: TDCT40_OnQueryResultM; + OnResultP: TDCT40_OnQueryResultP; + constructor Create; + destructor Destroy; override; + end; + + TDCT40_QueryResultAndDependProcessor = class + private + procedure DCT40_OnCheckDepend(Sender: TDTC40_PhysicsTunnel; L: TDTC40_InfoList); + procedure DCT40_OnAutoP2PVMConnectionDone(Sender: TCommunicationFramework; P_IO: TPeerIO); + procedure DCT40_OnBuildDependNetwork(Sender: TDTC40_PhysicsTunnel; L: TDTC40_InfoList); + procedure DoRun(const state: Boolean); + public + DTC40_PhysicsTunnel: TDTC40_PhysicsTunnel; + OnCall: TStateCall; + OnMethod: TStateMethod; + OnProc: TStateProc; + constructor Create; + destructor Destroy; override; + end; + + IDTC40_PhysicsTunnel_Event = interface + procedure DTC40_PhysicsTunnel_Connected(Sender: TDTC40_PhysicsTunnel); + procedure DTC40_PhysicsTunnel_Disconnect(Sender: TDTC40_PhysicsTunnel); + procedure DTC40_PhysicsTunnel_Build_Network(Sender: TDTC40_PhysicsTunnel; Custom_Client_: TDTC40_Custom_Client); + procedure DTC40_PhysicsTunnel_Client_Connected(Sender: TDTC40_PhysicsTunnel; Custom_Client_: TDTC40_Custom_Client); + end; + + { automated tunnel } + TDTC40_PhysicsTunnel = class(TCoreClassInterfacedObject, ICommunicationFrameworkClientInterface) + private + IsConnecting: Boolean; + BuildNetworkIsDone: Boolean; + OfflineTime: TTimeTick; + procedure DoDelayConnect(); + procedure DoConnectOnResult(const state: Boolean); + procedure DoConnectAndQuery(Param1: Pointer; Param2: TObject; const state: Boolean); + procedure DoConnectAndCheckDepend(Param1: Pointer; Param2: TObject; const state: Boolean); + procedure DoConnectAndBuildDependNetwork(Param1: Pointer; Param2: TObject; const state: Boolean); + protected + procedure ClientConnected(Sender: TCommunicationFrameworkClient); virtual; + procedure ClientDisconnect(Sender: TCommunicationFrameworkClient); virtual; + public + PhysicsAddr: U_String; + PhysicsPort: Word; + p2pVM_Auth: U_String; + PhysicsTunnel: TCommunicationFrameworkClient; + DependNetworkInfoArray: TDTC40_DependNetworkInfoArray; + DependNetworkClientPool: TDTC40_Custom_ClientPool; + OnEvent: IDTC40_PhysicsTunnel_Event; + { api } + constructor Create(Addr_: U_String; Port_: Word); + destructor Destroy; override; + procedure Progress; virtual; + function ResetDepend(const Depend_: TDTC40_DependNetworkInfoArray): Boolean; overload; + function ResetDepend(const Depend_: TDTC40_DependNetworkString): Boolean; overload; + function ResetDepend(const Depend_: U_String): Boolean; overload; + function CheckDepend(): Boolean; + function CheckDependC(OnResult: TStateCall): Boolean; + function CheckDependM(OnResult: TStateMethod): Boolean; + function CheckDependP(OnResult: TStateProc): Boolean; + function BuildDependNetwork(): Boolean; + function BuildDependNetworkC(OnResult: TStateCall): Boolean; + function BuildDependNetworkM(OnResult: TStateMethod): Boolean; + function BuildDependNetworkP(OnResult: TStateProc): Boolean; + procedure QueryInfoC(OnResult: TDCT40_OnQueryResultC); + procedure QueryInfoM(OnResult: TDCT40_OnQueryResultM); + procedure QueryInfoP(OnResult: TDCT40_OnQueryResultP); + function DependNetworkIsConnected: Boolean; + { event } + procedure DoClientConnected(Custom_Client_: TDTC40_Custom_Client); + end; + + TDTC40_PhysicsTunnelPool_Decl = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + + TDTC40_PhysicsTunnelPool = class(TDTC40_PhysicsTunnelPool_Decl) + public + { find addr } + function ExistsPhysicsAddr(PhysicsAddr: U_String; PhysicsPort: Word): Boolean; + function GetPhysicsTunnel(PhysicsAddr: U_String; PhysicsPort: Word): TDTC40_PhysicsTunnel; + { get or create from addr } + function GetOrCreatePhysicsTunnel(PhysicsAddr: U_String; PhysicsPort: Word): TDTC40_PhysicsTunnel; overload; + function GetOrCreatePhysicsTunnel(PhysicsAddr: U_String; PhysicsPort: Word; + const Depend_: TDTC40_DependNetworkInfoArray; const OnEvent_: IDTC40_PhysicsTunnel_Event): TDTC40_PhysicsTunnel; overload; + function GetOrCreatePhysicsTunnel(PhysicsAddr: U_String; PhysicsPort: Word; + const Depend_: U_String; const OnEvent_: IDTC40_PhysicsTunnel_Event): TDTC40_PhysicsTunnel; overload; + { get or create from define } + function GetOrCreatePhysicsTunnel(dispInfo: TDTC40_Info): TDTC40_PhysicsTunnel; overload; + function GetOrCreatePhysicsTunnel(dispInfo: TDTC40_Info; + const Depend_: TDTC40_DependNetworkInfoArray; const OnEvent_: IDTC40_PhysicsTunnel_Event): TDTC40_PhysicsTunnel; overload; + { progress } + procedure Progress; + end; +{$ENDREGION 'PhysicsTunnel'} +{$REGION 'infoDefine'} + + TDTC40_Info = class + private + Ignored: Boolean; + LastUpdateTimeTick: TTimeTick; + procedure MakeHash; + public + { share } + OnlyInstance: Boolean; + ServiceTyp: U_String; + PhysicsAddr: U_String; + PhysicsPort: Word; + p2pVM_Auth: U_String; + p2pVM_RecvTunnel_Addr: U_String; + p2pVM_RecvTunnel_Port: Word; + p2pVM_SendTunnel_Addr: U_String; + p2pVM_SendTunnel_Port: Word; + Workload, MaxWorkload: Integer; + AliveTime: TTimeTick; + Hash: TMD5; + + { client translate } + property p2pVM_ClientRecvTunnel_Addr: U_String read p2pVM_SendTunnel_Addr; + property p2pVM_ClientRecvTunnel_Port: Word read p2pVM_SendTunnel_Port; + property p2pVM_ClientSendTunnel_Addr: U_String read p2pVM_RecvTunnel_Addr; + property p2pVM_ClientSendTunnel_Port: Word read p2pVM_RecvTunnel_Port; + + { api } + constructor Create; + destructor Destroy; override; + procedure Assign(source: TDTC40_Info); + function Clone: TDTC40_Info; + procedure Load(stream: TCoreClassStream); + procedure Save(stream: TCoreClassStream); + function Same(Data_: TDTC40_Info): Boolean; + function SameServiceTyp(Data_: TDTC40_Info): Boolean; + function SamePhysicsAddr(Data_: TDTC40_Info): Boolean; overload; + function SamePhysicsAddr(Data_: TDTC40_PhysicsTunnel): Boolean; overload; + function SamePhysicsAddr(Data_: TDTC40_PhysicsService): Boolean; overload; + function SameP2PVMAddr(Data_: TDTC40_Info): Boolean; + function ReadyDTC40Client: Boolean; + function GetOrCreateDTC40Client(Param_: U_String): TDTC40_Custom_Client; + end; + + TDTC40_InfoList_Decl = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + + TDTC40_InfoList = class(TDTC40_InfoList_Decl) + public + AutoFree: Boolean; + constructor Create(AutoFree_: Boolean); + destructor Destroy; override; + procedure Remove(obj: TDTC40_Info); + procedure Delete(index: Integer); + procedure Clear; + class procedure SortWorkLoad(L: TDTC40_InfoList); + function IsOnlyInstance(ServiceTyp: U_String): Boolean; + function GetServiceTypNum(ServiceTyp: U_String): Integer; + function SearchService(ServiceTyp: U_String): TDTC40_InfoList; + function ExistsService(ServiceTyp: U_String): Boolean; + function ExistsServiceAndPhysicsTunnel(ServiceTyp: U_String; PhysicsTunnel_: TDTC40_PhysicsTunnel): Boolean; + function FindSame(Data_: TDTC40_Info): TDTC40_Info; + function FindHash(Hash: TMD5): TDTC40_Info; + function ExistsPhysicsAddr(PhysicsAddr: U_String; PhysicsPort: Word): Boolean; + procedure RemovePhysicsAddr(PhysicsAddr: U_String; PhysicsPort: Word); + function OverwriteInfo(Data_: TDTC40_Info): Boolean; + function MergeFromDF(D: TDFE): Boolean; + procedure SaveToDF(D: TDFE); + procedure UpdateAlive(PhysicsService_: TDTC40_PhysicsService); overload; + procedure UpdateAlive(PhysicsTunnel_: TDTC40_PhysicsTunnel); overload; + end; +{$ENDREGION 'infoDefine'} +{$REGION 'p2pVMCustomService'} + + TDTC40_Custom_Service = class(TCoreClassInterfacedObject) + private + FLastSafeCheckTime: TTimeTick; + public + SafeCheckTime: TTimeTick; + Param: U_String; + ParamList: THashStringList; + ServiceInfo: TDTC40_Info; + DTC40PhysicsService: TDTC40_PhysicsService; + constructor Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); virtual; + destructor Destroy; override; + procedure SafeCheck; virtual; + procedure Progress; virtual; + procedure SetWorkload(Workload_, MaxWorkload_: Integer); + procedure UpdateToGlobalDispatch; + function GetHash: TMD5; + property Hash: TMD5 read GetHash; + { event } + procedure DoLinkSuccess(Trigger_: TCoreClassObject); + procedure DoUserOut(Trigger_: TCoreClassObject); + end; + + TDTC40_Custom_Service_Class = class of TDTC40_Custom_Service; + + TDTC40_Custom_ServicePool_Decl = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + TDTC40_Custom_Service_Array = array of TDTC40_Custom_Service; + + TDTC40_Custom_ServicePool = class(TDTC40_Custom_ServicePool_Decl) + private + FIPV6_Seed: Word; + public + constructor Create; + procedure Progress; + procedure MakeP2PVM_IPv6_Port(var ip6, port: U_String); + function GetServiceFromHash(Hash: TMD5): TDTC40_Custom_Service; + function ExistsPhysicsAddr(PhysicsAddr: U_String; PhysicsPort: Word): Boolean; + function ExistsOnlyInstance(ServiceTyp: U_String): Boolean; + function GetDTC40Array: TDTC40_Custom_Service_Array; + function GetFromServiceTyp(ServiceTyp: U_String): TDTC40_Custom_Service_Array; + function GetFromPhysicsAddr(PhysicsAddr: U_String; PhysicsPort: Word): TDTC40_Custom_Service_Array; + function GetFromClass(Class_: TDTC40_Custom_Service_Class): TDTC40_Custom_Service_Array; + end; +{$ENDREGION 'p2pVMCustomService'} +{$REGION 'p2pVMCustomClient'} + + TDTC40_Custom_Client = class(TCoreClassInterfacedObject) + public + Param: U_String; + ParamList: THashStringList; + ClientInfo: TDTC40_Info; + DTC40PhysicsTunnel: TDTC40_PhysicsTunnel; + constructor Create(source_: TDTC40_Info; Param_: U_String); virtual; + destructor Destroy; override; + procedure Progress; virtual; + procedure Connect; virtual; + function Connected: Boolean; virtual; + procedure Disconnect; virtual; + function GetHash: TMD5; + property Hash: TMD5 read GetHash; + { event } + procedure DoClientConnected; + end; + + TDTC40_Custom_Client_Class = class of TDTC40_Custom_Client; + + TDTC40_Custom_ClientPool_Decl = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + + TDTC40_Custom_Client_Array = array of TDTC40_Custom_Client; + + TOn_DTC40_Custom_Client_EventC = procedure(Client_: TDTC40_Custom_Client); + TOn_DTC40_Custom_Client_EventM = procedure(Client_: TDTC40_Custom_Client) of object; +{$IFDEF FPC} + TOn_DTC40_Custom_Client_EventP = procedure(Client_: TDTC40_Custom_Client) is nested; +{$ELSE FPC} + TOn_DTC40_Custom_Client_EventP = reference to procedure(Client_: TDTC40_Custom_Client); +{$ENDIF FPC} + + TDTC40_Custom_ClientPool_Wait = class + private + procedure DoRun; + public + Pool_: TDTC40_Custom_ClientPool; + ServiceTyp_: U_String; + TimeOut_: TTimeTick; + OnCall: TOn_DTC40_Custom_Client_EventC; + OnMethod: TOn_DTC40_Custom_Client_EventM; + OnProc: TOn_DTC40_Custom_Client_EventP; + constructor Create; + destructor Destroy; override; + end; + + TDTC40_Custom_ClientPool = class(TDTC40_Custom_ClientPool_Decl) + private + public + procedure Progress; + function ExistsPhysicsAddr(PhysicsAddr: U_String; PhysicsPort: Word): Boolean; + function ExistsServiceInfo(info_: TDTC40_Info): Boolean; + function ExistsServiceTyp(ServiceTyp: U_String): Boolean; + function ExistsClass(Class_: TDTC40_Custom_Client_Class): TDTC40_Custom_Client; + function ExistsConnectedClass(Class_: TDTC40_Custom_Client_Class): TDTC40_Custom_Client; + function ExistsConnectedServiceTyp(ServiceTyp: U_String): TDTC40_Custom_Client; + function GetClientFromHash(Hash: TMD5): TDTC40_Custom_Client; + function GetDTC40Array: TDTC40_Custom_Client_Array; + function GetFromServiceTyp(ServiceTyp: U_String): TDTC40_Custom_Client_Array; + function GetFromPhysicsAddr(PhysicsAddr: U_String; PhysicsPort: Word): TDTC40_Custom_Client_Array; + function GetFromClass(Class_: TDTC40_Custom_Client_Class): TDTC40_Custom_Client_Array; + procedure WaitConnectedDoneC(ServiceTyp: U_String; TimeOut_: TTimeTick; OnResult: TOn_DTC40_Custom_Client_EventC); + procedure WaitConnectedDoneM(ServiceTyp: U_String; TimeOut_: TTimeTick; OnResult: TOn_DTC40_Custom_Client_EventM); + procedure WaitConnectedDoneP(ServiceTyp: U_String; TimeOut_: TTimeTick; OnResult: TOn_DTC40_Custom_Client_EventP); + end; +{$ENDREGION 'p2pVMCustomClient'} +{$REGION 'DispatchService'} + + TOnRemovePhysicsNetwork = class + public + PhysicsAddr: U_String; + PhysicsPort: Word; + constructor Create; + procedure DoRun; virtual; + end; + + TOnServiceInfoChange = procedure(Sender: TCoreClassObject; ServiceInfoList: TDTC40_InfoList) of object; + + // dispatch service + TDTC40_Dispatch_Service = class(TDTC40_Custom_Service) + private + FOnServiceInfoChange: TOnServiceInfoChange; + FWaiting_UpdateServerInfoToAllClient: Boolean; + FWaiting_UpdateServerInfoToAllClient_TimeTick: TTimeTick; + DelayCheck_Working: Boolean; + procedure cmd_UpdateServiceInfo(Sender: TPeerIO; InData: TDFE); + procedure cmd_UpdateServiceState(Sender: TPeerIO; InData: TDFE); + procedure cmd_IgnoreChange(Sender: TPeerIO; InData: TDFE); + procedure cmd_RequestUpdate(Sender: TPeerIO; InData: TDFE); + procedure cmd_RemovePhysicsNetwork(Sender: TPeerIO; InData: TDFE); + procedure Prepare_UpdateServerInfoToAllClient; + procedure UpdateServerInfoToAllClient; + + procedure DoLinkSuccess_Event(Sender: TDTService_NoAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth); + procedure DoUserOut_Event(Sender: TDTService_NoAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth); + procedure DoDelayCheckLocalServiceInfo; + public + Service: TDT_P2PVM_NoAuth_Custom_Service; + ServiceInfoList: TDTC40_InfoList; + constructor Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); override; + destructor Destroy; override; + procedure Progress; override; + procedure IgnoreChangeToAllClient(Hash: TMD5; Ignored: Boolean); + procedure UpdateServiceStateToAllClient; + { event } + property OnServiceInfoChange: TOnServiceInfoChange read FOnServiceInfoChange write FOnServiceInfoChange; + end; +{$ENDREGION 'DispatchService'} +{$REGION 'DispatchClient'} + + // dispatch client + TDTC40_Dispatch_Client = class(TDTC40_Custom_Client) + private + FOnServiceInfoChange: TOnServiceInfoChange; + DelayCheck_Working: Boolean; + procedure cmd_UpdateServiceInfo(Sender: TPeerIO; InData: TDFE); + procedure cmd_UpdateServiceState(Sender: TPeerIO; InData: TDFE); + procedure cmd_IgnoreChange(Sender: TPeerIO; InData: TDFE); + procedure cmd_RemovePhysicsNetwork(Sender: TPeerIO; InData: TDFE); + procedure Do_DT_P2PVM_NoAuth_Custom_Client_TunnelLink(Sender: TDT_P2PVM_NoAuth_Custom_Client); + procedure DoDelayCheckLocalServiceInfo; + public + Client: TDT_P2PVM_NoAuth_Custom_Client; + ServiceInfoList: TDTC40_InfoList; + constructor Create(source_: TDTC40_Info; Param_: U_String); override; + destructor Destroy; override; + procedure Progress; override; + procedure Connect; override; + function Connected: Boolean; override; + procedure Disconnect; override; + procedure PostLocalServiceInfo(forcePost_: Boolean); + procedure RequestUpdate(); + procedure IgnoreChangeToService(Hash: TMD5; Ignored: Boolean); + procedure UpdateLocalServiceState; + procedure RemovePhysicsNetwork(PhysicsAddr: U_String; PhysicsPort: Word); + { event } + property OnServiceInfoChange: TOnServiceInfoChange read FOnServiceInfoChange write FOnServiceInfoChange; + end; +{$ENDREGION 'DispatchClient'} +{$REGION 'RegistedData'} + + TDTC40_RegistedData = record + ServiceTyp: U_String; + ServiceClass: TDTC40_Custom_Service_Class; + ClientClass: TDTC40_Custom_Client_Class; + end; + + PDTC40_RegistedData = ^TDTC40_RegistedData; + + TDTC40_RegistedDataList_Decl = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + + TDTC40_RegistedDataList = class(TDTC40_RegistedDataList_Decl) + public + destructor Destroy; override; + procedure Clean; + procedure Print; + end; +{$ENDREGION 'RegistedData'} +{$REGION 'DTC40NoAuthModel'} + + TDTC40_Base_NoAuth_Service = class(TDTC40_Custom_Service) + protected + procedure DoLinkSuccess_Event(Sender: TDTService_NoAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth); virtual; + procedure DoUserOut_Event(Sender: TDTService_NoAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth); virtual; + public + Service: TDT_P2PVM_NoAuth_Custom_Service; + DTNoAuthService: TDTService_NoAuth; + constructor Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); override; + destructor Destroy; override; + procedure Progress; override; + end; + + TDTC40_Base_NoAuth_Client = class(TDTC40_Custom_Client) + protected + procedure Do_DT_P2PVM_NoAuth_Custom_Client_TunnelLink(Sender: TDT_P2PVM_NoAuth_Custom_Client); virtual; + public + Client: TDT_P2PVM_NoAuth_Custom_Client; + DTNoAuthClient: TDTClient_NoAuth; + constructor Create(source_: TDTC40_Info; Param_: U_String); override; + destructor Destroy; override; + procedure Progress; override; + procedure Connect; override; + function Connected: Boolean; override; + procedure Disconnect; override; + end; + + TDTC40_Base_DataStoreNoAuth_Service = class(TDTC40_Custom_Service) + protected + procedure DoLinkSuccess_Event(Sender: TDTService_NoAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth); virtual; + procedure DoUserOut_Event(Sender: TDTService_NoAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth); virtual; + public + Service: TDT_P2PVM_NoAuth_Custom_Service; + DTNoAuthService: TDataStoreService_NoAuth; + constructor Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); override; + destructor Destroy; override; + procedure Progress; override; + end; + + TDTC40_Base_DataStoreNoAuth_Client = class(TDTC40_Custom_Client) + protected + procedure Do_DT_P2PVM_DataStoreNoAuth_Custom_Client_TunnelLink(Sender: TDT_P2PVM_NoAuth_Custom_Client); virtual; + public + Client: TDT_P2PVM_NoAuth_Custom_Client; + DTNoAuthClient: TDataStoreClient_NoAuth; + constructor Create(source_: TDTC40_Info; Param_: U_String); override; + destructor Destroy; override; + procedure Progress; override; + procedure Connect; override; + function Connected: Boolean; override; + procedure Disconnect; override; + end; + +{$ENDREGION 'DTC40NoAuthModel'} +{$REGION 'DTC40VirtualAuthModel'} + + TDTC40_Base_VirtualAuth_Service = class(TDTC40_Custom_Service) + protected + procedure DoUserAuth_Event(Sender: TDTService_VirtualAuth; AuthIO: TVirtualAuthIO); virtual; + procedure DoLinkSuccess_Event(Sender: TDTService_VirtualAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_VirtualAuth); virtual; + procedure DoUserOut_Event(Sender: TDTService_VirtualAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_VirtualAuth); virtual; + public + Service: TDT_P2PVM_VirtualAuth_Custom_Service; + DTVirtualAuthService: TDTService_VirtualAuth; + constructor Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); override; + destructor Destroy; override; + procedure Progress; override; + end; + + TDTC40_Base_VirtualAuth_Client = class(TDTC40_Custom_Client) + protected + procedure Do_DT_P2PVM_VirtualAuth_Custom_Client_TunnelLink(Sender: TDT_P2PVM_VirtualAuth_Custom_Client); virtual; + public + Client: TDT_P2PVM_VirtualAuth_Custom_Client; + DTVirtualAuthClient: TDTClient_VirtualAuth; + UserName, Password: U_String; + constructor Create(source_: TDTC40_Info; Param_: U_String); override; + destructor Destroy; override; + procedure Progress; override; + procedure Connect; override; + function Connected: Boolean; override; + procedure Disconnect; override; + end; + + TDTC40_Base_DataStoreVirtualAuth_Service = class(TDTC40_Custom_Service) + protected + procedure DoUserAuth_Event(Sender: TDTService_VirtualAuth; AuthIO: TVirtualAuthIO); virtual; + procedure DoLinkSuccess_Event(Sender: TDTService_VirtualAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_VirtualAuth); virtual; + procedure DoUserOut_Event(Sender: TDTService_VirtualAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_VirtualAuth); virtual; + public + Service: TDT_P2PVM_VirtualAuth_Custom_Service; + DTVirtualAuthService: TDataStoreService_VirtualAuth; + constructor Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); override; + destructor Destroy; override; + procedure Progress; override; + end; + + TDTC40_Base_DataStoreVirtualAuth_Client = class(TDTC40_Custom_Client) + protected + procedure Do_DT_P2PVM_VirtualAuth_Custom_Client_TunnelLink(Sender: TDT_P2PVM_VirtualAuth_Custom_Client); virtual; + public + Client: TDT_P2PVM_VirtualAuth_Custom_Client; + DTVirtualAuthClient: TDataStoreClient_VirtualAuth; + UserName, Password: U_String; + constructor Create(source_: TDTC40_Info; Param_: U_String); override; + destructor Destroy; override; + procedure Progress; override; + procedure Connect; override; + function Connected: Boolean; override; + procedure Disconnect; override; + end; + +{$ENDREGION 'DTC40VirtualAuthModel'} +{$REGION 'DTC40BuildInAuthModel'} + + TDTC40_Base_Service = class(TDTC40_Custom_Service) + protected + procedure DoLinkSuccess_Event(Sender: TDTService; UserDefineIO: TPeerClientUserDefineForRecvTunnel); virtual; + procedure DoUserOut_Event(Sender: TDTService; UserDefineIO: TPeerClientUserDefineForRecvTunnel); virtual; + public + Service: TDT_P2PVM_Custom_Service; + DTService: TDTService; + constructor Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); override; + destructor Destroy; override; + procedure SafeCheck; override; + procedure Progress; override; + end; + + TDTC40_Base_Client = class(TDTC40_Custom_Client) + protected + procedure Do_DT_P2PVM_Custom_Client_TunnelLink(Sender: TDT_P2PVM_Custom_Client); virtual; + public + Client: TDT_P2PVM_Custom_Client; + DTClient: TDTClient; + UserName, Password: U_String; + constructor Create(source_: TDTC40_Info; Param_: U_String); override; + destructor Destroy; override; + procedure Progress; override; + procedure Connect; override; + function Connected: Boolean; override; + procedure Disconnect; override; + end; + + TDTC40_Base_DataStore_Service = class(TDTC40_Custom_Service) + protected + procedure DoLinkSuccess_Event(Sender: TDTService; UserDefineIO: TPeerClientUserDefineForRecvTunnel); virtual; + procedure DoUserOut_Event(Sender: TDTService; UserDefineIO: TPeerClientUserDefineForRecvTunnel); virtual; + public + Service: TDT_P2PVM_Custom_Service; + DTService: TDataStoreService; + constructor Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); override; + destructor Destroy; override; + procedure SafeCheck; override; + procedure Progress; override; + end; + + TDTC40_Base_DataStore_Client = class(TDTC40_Custom_Client) + protected + procedure Do_DT_P2PVM_Custom_Client_TunnelLink(Sender: TDT_P2PVM_Custom_Client); virtual; + public + Client: TDT_P2PVM_Custom_Client; + DTClient: TDataStoreClient; + UserName, Password: U_String; + constructor Create(source_: TDTC40_Info; Param_: U_String); override; + destructor Destroy; override; + procedure Progress; override; + procedure Connect; override; + function Connected: Boolean; override; + procedure Disconnect; override; + end; + +{$ENDREGION 'DTC40BuildInAuthModel'} + + +var + { quiet mode, defualt is false } + DTC40_QuietMode: Boolean; + { physics service safeCheck time, default is 10 minute } + DTC40_SafeCheckTime: TTimeTick; + { physics service timeout, default is 1 minute } + DTC40_PhysicsServiceTimeout: TTimeTick; + { physics tunnel timeout, default is 15 seconds } + DTC40_PhysicsTunnelTimeout: TTimeTick; + { kill dead physics connection timeout, default is 1 minute } + DTC40_KillDeadPhysicsConnectionTimeout: TTimeTick; + { kill IDC fault timeout, default is 1 hours } + DTC40_KillIDCFaultTimeout: TTimeTick; + { root path, default is current Directory } + DTC40_RootPath: U_String; + { p2pVM default password } + DTC40_Password: SystemString = 'DTC40@ZSERVER'; + { PhysicsTunnel interface } + DTC40_PhysicsClientClass: TCommunicationFrameworkClientClass; + { automated matched } + DTC40_Registed: TDTC40_RegistedDataList; + { physics service pool } + DTC40_PhysicsServicePool: TDTC40_PhysicsServicePool; + { custom service pool } + DTC40_ServicePool: TDTC40_Custom_ServicePool; + { physics tunnel pool } + DTC40_PhysicsTunnelPool: TDTC40_PhysicsTunnelPool; + { custom client pool } + DTC40_ClientPool: TDTC40_Custom_ClientPool; + +procedure C40Progress; { DTC40 main progress } + +{ free all DTC40 system } +procedure C40Clean; + +{ print state } +procedure C40PrintRegistation; +function C40ExistsPhysicsNetwork(PhysicsAddr: U_String; PhysicsPort: Word): Boolean; + +{ Kill physics tunnel } +procedure C40RemovePhysics(PhysicsAddr: U_String; PhysicsPort: Word; + Remove_P2PVM_Client_, Remove_Physics_Client_, RemoveP2PVM_Service_, Remove_Physcis_Service_: Boolean); overload; +procedure C40RemovePhysics(Tunnel_: TDTC40_PhysicsTunnel); overload; +procedure C40RemovePhysics(Service_: TDTC40_PhysicsService); overload; +procedure C40CheckAndKillDeadPhysicsTunnel(); + +{ register } +function RegisterC40(ServiceTyp: U_String; ServiceClass: TDTC40_Custom_Service_Class; ClientClass: TDTC40_Custom_Client_Class): Boolean; +function FindRegistedC40(ServiceTyp: U_String): PDTC40_RegistedData; + +{ misc } +function ExtractDependInfo(info: U_String): TDTC40_DependNetworkInfoArray; overload; +function ExtractDependInfo(arry: TDTC40_DependNetworkString): TDTC40_DependNetworkInfoArray; overload; + +implementation + +var + C40Progress_Working: Boolean = False; + +procedure C40Progress; +begin + if C40Progress_Working then + exit; + C40Progress_Working := True; + try + CheckThread; + DTC40_PhysicsServicePool.Progress; + DTC40_ServicePool.Progress; + DTC40_PhysicsTunnelPool.Progress; + DTC40_ClientPool.Progress; + C40CheckAndKillDeadPhysicsTunnel(); + finally + C40Progress_Working := False; + end; +end; + +procedure C40Clean; +begin + while DTC40_ClientPool.Count > 0 do + DisposeObject(DTC40_ClientPool[0]); + while DTC40_ServicePool.Count > 0 do + DisposeObject(DTC40_ServicePool[0]); + DTC40_ServicePool.FIPV6_Seed := 1; + while DTC40_PhysicsTunnelPool.Count > 0 do + DisposeObject(DTC40_PhysicsTunnelPool[0]); + while DTC40_PhysicsServicePool.Count > 0 do + DisposeObject(DTC40_PhysicsServicePool[0]); +end; + +procedure C40PrintRegistation; +begin + DTC40_Registed.Print; +end; + +function C40ExistsPhysicsNetwork(PhysicsAddr: U_String; PhysicsPort: Word): Boolean; +begin + Result := True; + if + DTC40_PhysicsServicePool.ExistsPhysicsAddr(PhysicsAddr, PhysicsPort) or + DTC40_ServicePool.ExistsPhysicsAddr(PhysicsAddr, PhysicsPort) or + DTC40_PhysicsTunnelPool.ExistsPhysicsAddr(PhysicsAddr, PhysicsPort) or + DTC40_ClientPool.ExistsPhysicsAddr(PhysicsAddr, PhysicsPort) then + exit; + Result := False; +end; + +procedure C40RemovePhysics(PhysicsAddr: U_String; PhysicsPort: Word; + Remove_P2PVM_Client_, Remove_Physics_Client_, RemoveP2PVM_Service_, Remove_Physcis_Service_: Boolean); +var + i: Integer; +begin + if Remove_P2PVM_Client_ then + begin + try + { remove client } + i := 0; + while i < DTC40_ClientPool.Count do + if PhysicsAddr.Same(@DTC40_ClientPool[i].ClientInfo.PhysicsAddr) and (PhysicsPort = DTC40_ClientPool[i].ClientInfo.PhysicsPort) then + begin + DisposeObject(DTC40_ClientPool[i]); + i := 0; + end + else + inc(i); + except + end; + end; + + { remove dispatch info } + for i := 0 to DTC40_ClientPool.Count - 1 do + if DTC40_ClientPool[i] is TDTC40_Dispatch_Client then + TDTC40_Dispatch_Client(DTC40_ClientPool[i]).ServiceInfoList.RemovePhysicsAddr(PhysicsAddr, PhysicsPort); + + if Remove_Physics_Client_ then + begin + try + { remove physics tunnel } + i := 0; + while i < DTC40_PhysicsTunnelPool.Count do + begin + if PhysicsAddr.Same(@DTC40_PhysicsTunnelPool[i].PhysicsAddr) and (PhysicsPort = DTC40_PhysicsTunnelPool[i].PhysicsPort) then + begin + DisposeObject(DTC40_PhysicsTunnelPool[i]); + i := 0; + end + else + inc(i); + end; + except + end; + end; + + if RemoveP2PVM_Service_ then + begin + try + { remove service } + i := 0; + while i < DTC40_ServicePool.Count do + if PhysicsAddr.Same(@DTC40_ServicePool[i].ServiceInfo.PhysicsAddr) and (PhysicsPort = DTC40_ServicePool[i].ServiceInfo.PhysicsPort) then + begin + DisposeObject(DTC40_ServicePool[i]); + i := 0; + end + else + inc(i); + except + end; + end; + + { remove service info } + for i := 0 to DTC40_ServicePool.Count - 1 do + if DTC40_ServicePool[i] is TDTC40_Dispatch_Service then + TDTC40_Dispatch_Service(DTC40_ServicePool[i]).ServiceInfoList.RemovePhysicsAddr(PhysicsAddr, PhysicsPort); + + if Remove_Physcis_Service_ then + begin + try + { remove physics service } + i := 0; + while i < DTC40_PhysicsServicePool.Count do + begin + if PhysicsAddr.Same(@DTC40_PhysicsServicePool[i].PhysicsAddr) and (PhysicsPort = DTC40_PhysicsServicePool[i].PhysicsPort) then + begin + DisposeObject(DTC40_PhysicsServicePool[i]); + i := 0; + end + else + inc(i); + end; + except + end; + end; +end; + +procedure C40RemovePhysics(Tunnel_: TDTC40_PhysicsTunnel); +begin + C40RemovePhysics(Tunnel_.PhysicsAddr, Tunnel_.PhysicsPort, True, True, False, False); +end; + +procedure C40RemovePhysics(Service_: TDTC40_PhysicsService); +begin + C40RemovePhysics(Service_.PhysicsAddr, Service_.PhysicsPort, True, True, True, True); +end; + +procedure C40CheckAndKillDeadPhysicsTunnel(); +var + i: Integer; + tmp: TDTC40_PhysicsTunnel; +begin + i := 0; + while i < DTC40_PhysicsTunnelPool.Count do + begin + tmp := DTC40_PhysicsTunnelPool[i]; + if (not tmp.PhysicsTunnel.RemoteInited) and (not tmp.BuildNetworkIsDone) and + (tmp.OfflineTime > 0) and (GetTimeTick - tmp.OfflineTime > DTC40_KillDeadPhysicsConnectionTimeout) then + begin + C40RemovePhysics(tmp); + i := 0; + end + else if (not tmp.PhysicsTunnel.RemoteInited) and (tmp.BuildNetworkIsDone) and + (tmp.OfflineTime > 0) and (GetTimeTick - tmp.OfflineTime > DTC40_KillIDCFaultTimeout) then + begin + C40RemovePhysics(tmp); + i := 0; + end + else + inc(i); + end; +end; + +function RegisterC40(ServiceTyp: U_String; ServiceClass: TDTC40_Custom_Service_Class; ClientClass: TDTC40_Custom_Client_Class): Boolean; +var + i: Integer; + p: PDTC40_RegistedData; +begin + Result := False; + for i := 0 to DTC40_Registed.Count - 1 do + if ServiceTyp.Same(@DTC40_Registed[i]^.ServiceTyp) then + begin + RaiseInfo('"%s" repeat registion.', [ServiceTyp.Text]); + exit; + end; + + new(p); + p^.ServiceTyp := ServiceTyp; + p^.ServiceClass := ServiceClass; + p^.ClientClass := ClientClass; + DTC40_Registed.Add(p); + Result := True; +end; + +function FindRegistedC40(ServiceTyp: U_String): PDTC40_RegistedData; +var + i: Integer; +begin + Result := nil; + for i := 0 to DTC40_Registed.Count - 1 do + if ServiceTyp.Same(@DTC40_Registed[i]^.ServiceTyp) then + begin + Result := DTC40_Registed[i]; + exit; + end; +end; + +function ExtractDependInfo(info: U_String): TDTC40_DependNetworkInfoArray; +var + tmp: TDTC40_DependNetworkString; +begin + umlGetSplitArray(info, tmp, '|<>'); + Result := ExtractDependInfo(tmp); +end; + +function ExtractDependInfo(arry: TDTC40_DependNetworkString): TDTC40_DependNetworkInfoArray; +var + i: Integer; + info_: TDTC40_DependNetworkInfo; +begin + SetLength(Result, Length(arry)); + for i := 0 to Length(arry) - 1 do + begin + info_.Typ := umlTrimSpace(umlGetFirstStr(arry[i], '@')); + info_.Param := umlTrimSpace(umlDeleteFirstStr(arry[i], '@')); + Result[i] := info_; + end; +end; + +procedure TDTC40_PhysicsService.cmd_QueryInfo(Sender: TPeerIO; InData, OutData: TDFE); +var + i: Integer; + L: TDTC40_InfoList; +begin + L := TDTC40_InfoList.Create(False); + for i := 0 to DTC40_ServicePool.Count - 1 do + if L.FindSame(DTC40_ServicePool[i].ServiceInfo) = nil then + L.Add(DTC40_ServicePool[i].ServiceInfo); + L.SaveToDF(OutData); + DisposeObject(L); +end; + +constructor TDTC40_PhysicsService.Create(PhysicsAddr_: U_String; PhysicsPort_: Word; PhysicsTunnel_: TCommunicationFrameworkServer); +begin + inherited Create; + FActivted := False; + PhysicsAddr := umlTrimSpace(PhysicsAddr_); + PhysicsPort := PhysicsPort_; + PhysicsTunnel := PhysicsTunnel_; + PhysicsTunnel.AutomatedP2PVMAuthToken := DTC40_Password; + PhysicsTunnel.TimeOutKeepAlive := True; + PhysicsTunnel.IdleTimeOut := DTC40_PhysicsServiceTimeout; + PhysicsTunnel.RegisterStream('QueryInfo').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_QueryInfo; + PhysicsTunnel.PrintParams['QueryInfo'] := False; + PhysicsTunnel.QuietMode := DTC40_QuietMode; + AutoFreePhysicsTunnel := False; + DependNetworkServicePool := TDTC40_Custom_ServicePool.Create; + OnEvent := nil; + DTC40_PhysicsServicePool.Add(Self); +end; + +destructor TDTC40_PhysicsService.Destroy; +begin + DTC40_PhysicsServicePool.Remove(Self); + PhysicsTunnel.DeleteRegistedCMD('QueryInfo'); + DisposeObject(DependNetworkServicePool); + if AutoFreePhysicsTunnel then + DisposeObject(PhysicsTunnel); + inherited Destroy; +end; + +procedure TDTC40_PhysicsService.Progress; +begin + PhysicsTunnel.Progress; +end; + +function TDTC40_PhysicsService.BuildDependNetwork(const Depend_: TDTC40_DependNetworkInfoArray): Boolean; +var + i: Integer; + p: PDTC40_RegistedData; + tmp: TDTC40_Custom_Service; +begin + Result := False; + + PhysicsTunnel.Print(''); + + for i := 0 to Length(Depend_) - 1 do + begin + p := FindRegistedC40(Depend_[i].Typ); + if p = nil then + begin + PhysicsTunnel.Print('no found Registed service "%s"', [Depend_[i].Typ.Text]); + exit; + end; + + tmp := p^.ServiceClass.Create(Self, p^.ServiceTyp, Depend_[i].Param); + PhysicsTunnel.Print('Build Depend service "%s" instance class "%s"', [tmp.ServiceInfo.ServiceTyp.Text, tmp.ClassName]); + PhysicsTunnel.Print('service %s p2pVM Received tunnel ip %s port: %d', [tmp.ServiceInfo.ServiceTyp.Text, tmp.ServiceInfo.p2pVM_RecvTunnel_Addr.Text, tmp.ServiceInfo.p2pVM_RecvTunnel_Port]); + PhysicsTunnel.Print('service %s p2pVM Send tunnel ip %s port: %d', [tmp.ServiceInfo.ServiceTyp.Text, tmp.ServiceInfo.p2pVM_SendTunnel_Addr.Text, tmp.ServiceInfo.p2pVM_SendTunnel_Port]); + PhysicsTunnel.Print(''); + + if Assigned(OnEvent) then + OnEvent.DTC40_PhysicsService_Build_Network(Self, tmp); + end; + Result := True; +end; + +function TDTC40_PhysicsService.BuildDependNetwork(const Depend_: TDTC40_DependNetworkString): Boolean; +begin + Result := BuildDependNetwork(ExtractDependInfo(Depend_)); +end; + +function TDTC40_PhysicsService.BuildDependNetwork(const Depend_: U_String): Boolean; +begin + Result := BuildDependNetwork(ExtractDependInfo(Depend_)); +end; + +procedure TDTC40_PhysicsService.StartService; +begin + FActivted := PhysicsTunnel.StartService(PhysicsAddr, PhysicsPort); + if FActivted then + begin + PhysicsTunnel.Print('Physics Service "%s" Listening successed, internet addr: %s port: %d', [PhysicsTunnel.ClassName, PhysicsAddr.Text, PhysicsPort]); + if Assigned(OnEvent) then + OnEvent.DTC40_PhysicsService_Start(Self); + end + else + PhysicsTunnel.Print('Physics Service "%s" Listening failed, internet addr: %s port: %d', [PhysicsTunnel.ClassName, PhysicsAddr.Text, PhysicsPort]); +end; + +procedure TDTC40_PhysicsService.StopService; +begin + if not FActivted then + exit; + PhysicsTunnel.StopService; + PhysicsTunnel.Print('Physics Service "%s" Listening Stop.', [PhysicsTunnel.ClassName]); + if Assigned(OnEvent) then + OnEvent.DTC40_PhysicsService_Stop(Self); +end; + +procedure TDTC40_PhysicsService.DoLinkSuccess(Custom_Service_: TDTC40_Custom_Service; Trigger_: TCoreClassObject); +begin + if Assigned(OnEvent) then + OnEvent.DTC40_PhysicsService_LinkSuccess(Self, Custom_Service_, Trigger_); +end; + +procedure TDTC40_PhysicsService.DoUserOut(Custom_Service_: TDTC40_Custom_Service; Trigger_: TCoreClassObject); +begin + if Assigned(OnEvent) then + OnEvent.DTC40_PhysicsService_UserOut(Self, Custom_Service_, Trigger_); +end; + +procedure TDTC40_PhysicsServicePool.Progress; +var + i: Integer; +begin + for i := 0 to Count - 1 do + Items[i].Progress; +end; + +function TDTC40_PhysicsServicePool.ExistsPhysicsAddr(PhysicsAddr: U_String; PhysicsPort: Word): Boolean; +var + i: Integer; +begin + Result := True; + for i := 0 to Count - 1 do + if PhysicsAddr.Same(@Items[i].PhysicsAddr) and (PhysicsPort = Items[i].PhysicsPort) then + exit; + Result := False; +end; + +procedure TDCT40_QueryResultData.DoStreamParam(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); +begin + L.MergeFromDF(Result_); + DoRun; +end; + +procedure TDCT40_QueryResultData.DoStreamFailed(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); +begin + DoRun; +end; + +procedure TDCT40_QueryResultData.DoRun; +begin + try + if Assigned(OnResultC) then + OnResultC(DTC40_PhysicsTunnel, L); + if Assigned(OnResultM) then + OnResultM(DTC40_PhysicsTunnel, L); + if Assigned(OnResultP) then + OnResultP(DTC40_PhysicsTunnel, L); + except + end; + Free; +end; + +constructor TDCT40_QueryResultData.Create; +begin + inherited Create; + DTC40_PhysicsTunnel := nil; + L := TDTC40_InfoList.Create(True); + OnResultC := nil; + OnResultM := nil; + OnResultP := nil; +end; + +destructor TDCT40_QueryResultData.Destroy; +begin + DisposeObject(L); + inherited Destroy; +end; + +procedure TDCT40_QueryResultAndDependProcessor.DCT40_OnCheckDepend(Sender: TDTC40_PhysicsTunnel; L: TDTC40_InfoList); +var + i: Integer; + state: Boolean; +begin + state := True; + for i := 0 to Length(Sender.DependNetworkInfoArray) - 1 do + begin + if L.ExistsService(Sender.DependNetworkInfoArray[i].Typ) then + begin + Sender.PhysicsTunnel.Print('Check addr %s port:%d service "%s" passed.', [Sender.PhysicsAddr.Text, Sender.PhysicsPort, Sender.DependNetworkInfoArray[i].Typ.Text]); + end + else + begin + Sender.PhysicsTunnel.Print('failed! Check addr %s port:%d no found service "%s".', [Sender.PhysicsAddr.Text, Sender.PhysicsPort, Sender.DependNetworkInfoArray[i].Typ.Text]); + state := False; + end; + end; + DoRun(state); +end; + +procedure TDCT40_QueryResultAndDependProcessor.DCT40_OnAutoP2PVMConnectionDone(Sender: TCommunicationFramework; P_IO: TPeerIO); +var + i: Integer; +begin + Sender.AutomatedP2PVMClient := True; + + for i := 0 to DTC40_PhysicsTunnel.DependNetworkClientPool.Count - 1 do + with DTC40_PhysicsTunnel.DependNetworkClientPool[i] do + if not Connected then + Connect; + + DTC40_PhysicsTunnel.BuildNetworkIsDone := True; + DTC40_PhysicsTunnel.OfflineTime := 0; + DoRun(True); +end; + +procedure TDCT40_QueryResultAndDependProcessor.DCT40_OnBuildDependNetwork(Sender: TDTC40_PhysicsTunnel; L: TDTC40_InfoList); +var + i, j: Integer; + found_: Integer; + tmp: TDTC40_Custom_Client; +begin + found_ := 0; + for i := 0 to Length(Sender.DependNetworkInfoArray) - 1 do + if L.ExistsService(Sender.DependNetworkInfoArray[i].Typ) then + inc(found_); + + if found_ = 0 then + begin + DoRun(False); + exit; + end; + + Sender.PhysicsTunnel.Print(''); + for i := 0 to Length(Sender.DependNetworkInfoArray) - 1 do + for j := 0 to L.Count - 1 do + begin + if L[j].SamePhysicsAddr(Sender) and L[j].ServiceTyp.Same(@Sender.DependNetworkInfoArray[i].Typ) and + (not Sender.DependNetworkClientPool.ExistsServiceInfo(L[j])) then + begin + tmp := L[j].GetOrCreateDTC40Client(Sender.DependNetworkInfoArray[i].Param); + if tmp <> nil then + begin + Sender.PhysicsTunnel.Print('build "%s" network done.', [L[j].ServiceTyp.Text]); + Sender.PhysicsTunnel.Print('"%s" network physics address "%s" physics port "%d" DCT40 Class:%s', + [L[j].ServiceTyp.Text, Sender.PhysicsAddr.Text, Sender.PhysicsPort, tmp.ClassName]); + Sender.PhysicsTunnel.Print('"%s" network p2pVM Received Tunnel IPV6 "%s" Port:%d', + [L[j].ServiceTyp.Text, L[j].p2pVM_RecvTunnel_Addr.Text, L[j].PhysicsPort]); + Sender.PhysicsTunnel.Print('"%s" network p2pVM Send Tunnel IPV6 "%s" Port:%d', + [L[j].ServiceTyp.Text, L[j].p2pVM_SendTunnel_Addr.Text, L[j].PhysicsPort]); + Sender.PhysicsTunnel.Print(''); + + if Assigned(DTC40_PhysicsTunnel.OnEvent) then + DTC40_PhysicsTunnel.OnEvent.DTC40_PhysicsTunnel_Build_Network(DTC40_PhysicsTunnel, tmp); + end + else + begin + Sender.PhysicsTunnel.Print('build "%s" network error.', [L[j].ServiceTyp.Text]); + Sender.PhysicsTunnel.Print(''); + end; + end; + end; + Sender.PhysicsTunnel.OnAutomatedP2PVMClientConnectionDone_M := {$IFDEF FPC}@{$ENDIF FPC}DCT40_OnAutoP2PVMConnectionDone; + Sender.PhysicsTunnel.AutomatedP2PVM_Open(Sender.PhysicsTunnel.ClientIO); +end; + +procedure TDCT40_QueryResultAndDependProcessor.DoRun(const state: Boolean); +begin + if Assigned(OnCall) then + OnCall(state); + if Assigned(OnMethod) then + OnMethod(state); + if Assigned(OnProc) then + OnProc(state); + Free; +end; + +constructor TDCT40_QueryResultAndDependProcessor.Create; +begin + inherited Create; + DTC40_PhysicsTunnel := nil; + OnCall := nil; + OnMethod := nil; + OnProc := nil; +end; + +destructor TDCT40_QueryResultAndDependProcessor.Destroy; +begin + inherited Destroy; +end; + +procedure TDTC40_PhysicsTunnel.DoDelayConnect; +begin + PhysicsTunnel.AsyncConnectM(PhysicsAddr, PhysicsPort, {$IFDEF FPC}@{$ENDIF FPC}DoConnectOnResult); +end; + +procedure TDTC40_PhysicsTunnel.DoConnectOnResult(const state: Boolean); +begin + if state then + PhysicsTunnel.Print('Physics Tunnel "%s" connection successed, internet addr: %s port: %d', [PhysicsTunnel.ClassName, PhysicsAddr.Text, PhysicsPort]) + else + PhysicsTunnel.Print('Physics Tunnel "%s" connection failed, internet addr: %s port: %d', [PhysicsTunnel.ClassName, PhysicsAddr.Text, PhysicsPort]); + IsConnecting := False; +end; + +procedure TDTC40_PhysicsTunnel.DoConnectAndQuery(Param1: Pointer; Param2: TObject; const state: Boolean); +var + tmp: TDCT40_QueryResultData; +begin + DoConnectOnResult(state); + tmp := TDCT40_QueryResultData(Param2); + if state then + begin + PhysicsTunnel.SendStreamCmdM('QueryInfo', nil, nil, nil, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParam, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailed); + end + else + begin + try + tmp.DoRun; + except + end; + end; +end; + +procedure TDTC40_PhysicsTunnel.DoConnectAndCheckDepend(Param1: Pointer; Param2: TObject; const state: Boolean); +var + tmp: TDCT40_QueryResultAndDependProcessor; +begin + DoConnectOnResult(state); + tmp := TDCT40_QueryResultAndDependProcessor(Param2); + if state then + begin + QueryInfoM({$IFDEF FPC}@{$ENDIF FPC}tmp.DCT40_OnCheckDepend); + end + else + begin + try + tmp.DoRun(state); + except + end; + end; +end; + +procedure TDTC40_PhysicsTunnel.DoConnectAndBuildDependNetwork(Param1: Pointer; Param2: TObject; const state: Boolean); +var + tmp: TDCT40_QueryResultAndDependProcessor; +begin + DoConnectOnResult(state); + tmp := TDCT40_QueryResultAndDependProcessor(Param2); + if state then + begin + QueryInfoM({$IFDEF FPC}@{$ENDIF FPC}tmp.DCT40_OnBuildDependNetwork); + end + else + begin + try + tmp.DoRun(state); + except + end; + end; +end; + +procedure TDTC40_PhysicsTunnel.ClientConnected(Sender: TCommunicationFrameworkClient); +begin + if Assigned(OnEvent) then + OnEvent.DTC40_PhysicsTunnel_Connected(Self); +end; + +procedure TDTC40_PhysicsTunnel.ClientDisconnect(Sender: TCommunicationFrameworkClient); +begin + if Assigned(OnEvent) then + OnEvent.DTC40_PhysicsTunnel_Disconnect(Self); +end; + +constructor TDTC40_PhysicsTunnel.Create(Addr_: U_String; Port_: Word); +var + i: Integer; +begin + inherited Create; + IsConnecting := False; + BuildNetworkIsDone := False; + OfflineTime := GetTimeTick; + + PhysicsAddr := umlTrimSpace(Addr_); + PhysicsPort := Port_; + PhysicsTunnel := DTC40_PhysicsClientClass.Create; + PhysicsTunnel.AutomatedP2PVMAuthToken := DTC40_Password; + PhysicsTunnel.TimeOutKeepAlive := True; + PhysicsTunnel.IdleTimeOut := DTC40_PhysicsTunnelTimeout; + PhysicsTunnel.SyncOnResult := False; + PhysicsTunnel.SyncOnCompleteBuffer := True; + PhysicsTunnel.SwitchDefaultPerformance; + PhysicsTunnel.OnInterface := Self; + PhysicsTunnel.PrintParams['QueryInfo'] := False; + PhysicsTunnel.QuietMode := DTC40_QuietMode; + + p2pVM_Auth := PhysicsTunnel.AutomatedP2PVMAuthToken; + SetLength(DependNetworkInfoArray, 0); + DependNetworkClientPool := TDTC40_Custom_ClientPool.Create; + OnEvent := nil; + DTC40_PhysicsTunnelPool.Add(Self); +end; + +destructor TDTC40_PhysicsTunnel.Destroy; +begin + OnEvent := nil; + DTC40_PhysicsTunnelPool.Remove(Self); + PhysicsAddr := ''; + SetLength(DependNetworkInfoArray, 0); + DisposeObject(DependNetworkClientPool); + DisposeObject(PhysicsTunnel); + inherited Destroy; +end; + +procedure TDTC40_PhysicsTunnel.Progress; +begin + PhysicsTunnel.Progress; + + { check state and reconnection } + if BuildNetworkIsDone and (not IsConnecting) and (not PhysicsTunnel.RemoteInited) then + begin + IsConnecting := True; + PhysicsTunnel.PostProgress.PostExecuteM_NP(1.0, {$IFDEF FPC}@{$ENDIF FPC}DoDelayConnect); + end; + + { check offline state } + if (OfflineTime = 0) and (not PhysicsTunnel.RemoteInited) then + OfflineTime := GetTimeTick; +end; + +function TDTC40_PhysicsTunnel.ResetDepend(const Depend_: TDTC40_DependNetworkInfoArray): Boolean; +var + i: Integer; +begin + SetLength(DependNetworkInfoArray, Length(Depend_)); + for i := 0 to Length(Depend_) - 1 do + DependNetworkInfoArray[i] := Depend_[i]; + + Result := False; + for i := 0 to Length(DependNetworkInfoArray) - 1 do + if FindRegistedC40(DependNetworkInfoArray[i].Typ) = nil then + exit; + Result := True; +end; + +function TDTC40_PhysicsTunnel.ResetDepend(const Depend_: TDTC40_DependNetworkString): Boolean; +begin + Result := ResetDepend(ExtractDependInfo(Depend_)); +end; + +function TDTC40_PhysicsTunnel.ResetDepend(const Depend_: U_String): Boolean; +begin + Result := ResetDepend(ExtractDependInfo(Depend_)); +end; + +function TDTC40_PhysicsTunnel.CheckDepend(): Boolean; +var + i: Integer; + tmp: TDCT40_QueryResultAndDependProcessor; +begin + Result := False; + if IsConnecting then + exit; + + Result := True; + for i := 0 to Length(DependNetworkInfoArray) - 1 do + if FindRegistedC40(DependNetworkInfoArray[i].Typ) = nil then + begin + PhysicsTunnel.Print('no registed "%s"', [DependNetworkInfoArray[i].Typ.Text]); + exit; + end; + + tmp := TDCT40_QueryResultAndDependProcessor.Create; + tmp.DTC40_PhysicsTunnel := Self; + + if PhysicsTunnel.RemoteInited then + begin + QueryInfoM({$IFDEF FPC}@{$ENDIF FPC}tmp.DCT40_OnCheckDepend); + exit; + end; + + IsConnecting := True; + PhysicsTunnel.AutomatedP2PVMService := False; + PhysicsTunnel.AutomatedP2PVMClient := False; + PhysicsTunnel.AsyncConnectM(PhysicsAddr, PhysicsPort, nil, tmp, {$IFDEF FPC}@{$ENDIF FPC}DoConnectAndCheckDepend); +end; + +function TDTC40_PhysicsTunnel.CheckDependC(OnResult: TStateCall): Boolean; +var + i: Integer; + tmp: TDCT40_QueryResultAndDependProcessor; +begin + Result := False; + if IsConnecting then + exit; + + Result := True; + for i := 0 to Length(DependNetworkInfoArray) - 1 do + if FindRegistedC40(DependNetworkInfoArray[i].Typ) = nil then + begin + PhysicsTunnel.Print('no registed "%s"', [DependNetworkInfoArray[i].Typ.Text]); + if Assigned(OnResult) then + OnResult(False); + exit; + end; + + tmp := TDCT40_QueryResultAndDependProcessor.Create; + tmp.DTC40_PhysicsTunnel := Self; + tmp.OnCall := OnResult; + + if PhysicsTunnel.RemoteInited then + begin + QueryInfoM({$IFDEF FPC}@{$ENDIF FPC}tmp.DCT40_OnCheckDepend); + exit; + end; + + IsConnecting := True; + PhysicsTunnel.AutomatedP2PVMService := False; + PhysicsTunnel.AutomatedP2PVMClient := False; + PhysicsTunnel.AsyncConnectM(PhysicsAddr, PhysicsPort, nil, tmp, {$IFDEF FPC}@{$ENDIF FPC}DoConnectAndCheckDepend); +end; + +function TDTC40_PhysicsTunnel.CheckDependM(OnResult: TStateMethod): Boolean; +var + i: Integer; + tmp: TDCT40_QueryResultAndDependProcessor; +begin + Result := False; + if IsConnecting then + exit; + + Result := True; + for i := 0 to Length(DependNetworkInfoArray) - 1 do + if FindRegistedC40(DependNetworkInfoArray[i].Typ) = nil then + begin + PhysicsTunnel.Print('no registed "%s"', [DependNetworkInfoArray[i].Typ.Text]); + if Assigned(OnResult) then + OnResult(False); + exit; + end; + + tmp := TDCT40_QueryResultAndDependProcessor.Create; + tmp.DTC40_PhysicsTunnel := Self; + tmp.OnMethod := OnResult; + + if PhysicsTunnel.RemoteInited then + begin + QueryInfoM({$IFDEF FPC}@{$ENDIF FPC}tmp.DCT40_OnCheckDepend); + exit; + end; + + IsConnecting := True; + PhysicsTunnel.AutomatedP2PVMService := False; + PhysicsTunnel.AutomatedP2PVMClient := False; + PhysicsTunnel.AsyncConnectM(PhysicsAddr, PhysicsPort, nil, tmp, {$IFDEF FPC}@{$ENDIF FPC}DoConnectAndCheckDepend); +end; + +function TDTC40_PhysicsTunnel.CheckDependP(OnResult: TStateProc): Boolean; +var + i: Integer; + tmp: TDCT40_QueryResultAndDependProcessor; +begin + Result := False; + if IsConnecting then + exit; + + Result := True; + for i := 0 to Length(DependNetworkInfoArray) - 1 do + if FindRegistedC40(DependNetworkInfoArray[i].Typ) = nil then + begin + PhysicsTunnel.Print('no registed "%s"', [DependNetworkInfoArray[i].Typ.Text]); + if Assigned(OnResult) then + OnResult(False); + exit; + end; + + tmp := TDCT40_QueryResultAndDependProcessor.Create; + tmp.DTC40_PhysicsTunnel := Self; + tmp.OnProc := OnResult; + + if PhysicsTunnel.RemoteInited then + begin + QueryInfoM({$IFDEF FPC}@{$ENDIF FPC}tmp.DCT40_OnCheckDepend); + exit; + end; + + IsConnecting := True; + PhysicsTunnel.AutomatedP2PVMService := False; + PhysicsTunnel.AutomatedP2PVMClient := False; + PhysicsTunnel.AsyncConnectM(PhysicsAddr, PhysicsPort, nil, tmp, {$IFDEF FPC}@{$ENDIF FPC}DoConnectAndCheckDepend); +end; + +function TDTC40_PhysicsTunnel.BuildDependNetwork: Boolean; +var + i: Integer; + tmp: TDCT40_QueryResultAndDependProcessor; +begin + Result := False; + if IsConnecting then + exit; + if BuildNetworkIsDone then + exit; + + Result := True; + for i := 0 to Length(DependNetworkInfoArray) - 1 do + if FindRegistedC40(DependNetworkInfoArray[i].Typ) = nil then + begin + PhysicsTunnel.Print('no registed "%s"', [DependNetworkInfoArray[i].Typ.Text]); + exit; + end; + + tmp := TDCT40_QueryResultAndDependProcessor.Create; + tmp.DTC40_PhysicsTunnel := Self; + + if PhysicsTunnel.RemoteInited then + begin + QueryInfoM({$IFDEF FPC}@{$ENDIF FPC}tmp.DCT40_OnBuildDependNetwork); + exit; + end; + + IsConnecting := True; + PhysicsTunnel.AutomatedP2PVMService := False; + PhysicsTunnel.AutomatedP2PVMClient := False; + PhysicsTunnel.AsyncConnectM(PhysicsAddr, PhysicsPort, nil, tmp, {$IFDEF FPC}@{$ENDIF FPC}DoConnectAndBuildDependNetwork); +end; + +function TDTC40_PhysicsTunnel.BuildDependNetworkC(OnResult: TStateCall): Boolean; +var + i: Integer; + tmp: TDCT40_QueryResultAndDependProcessor; +begin + Result := False; + if IsConnecting then + exit; + if BuildNetworkIsDone then + begin + tmp := TDCT40_QueryResultAndDependProcessor.Create; + tmp.DTC40_PhysicsTunnel := Self; + tmp.OnCall := OnResult; + QueryInfoM({$IFDEF FPC}@{$ENDIF FPC}tmp.DCT40_OnBuildDependNetwork); + PhysicsTunnel.AutomatedP2PVM_Open(); + exit; + end; + + Result := True; + for i := 0 to Length(DependNetworkInfoArray) - 1 do + if FindRegistedC40(DependNetworkInfoArray[i].Typ) = nil then + begin + PhysicsTunnel.Print('no registed "%s"', [DependNetworkInfoArray[i].Typ.Text]); + if Assigned(OnResult) then + OnResult(False); + exit; + end; + + tmp := TDCT40_QueryResultAndDependProcessor.Create; + tmp.DTC40_PhysicsTunnel := Self; + tmp.OnCall := OnResult; + + if PhysicsTunnel.RemoteInited then + begin + QueryInfoM({$IFDEF FPC}@{$ENDIF FPC}tmp.DCT40_OnBuildDependNetwork); + exit; + end; + + IsConnecting := True; + PhysicsTunnel.AutomatedP2PVMService := False; + PhysicsTunnel.AutomatedP2PVMClient := False; + PhysicsTunnel.AsyncConnectM(PhysicsAddr, PhysicsPort, nil, tmp, {$IFDEF FPC}@{$ENDIF FPC}DoConnectAndBuildDependNetwork); +end; + +function TDTC40_PhysicsTunnel.BuildDependNetworkM(OnResult: TStateMethod): Boolean; +var + i: Integer; + tmp: TDCT40_QueryResultAndDependProcessor; +begin + Result := False; + if IsConnecting then + exit; + if BuildNetworkIsDone then + begin + tmp := TDCT40_QueryResultAndDependProcessor.Create; + tmp.DTC40_PhysicsTunnel := Self; + tmp.OnMethod := OnResult; + QueryInfoM({$IFDEF FPC}@{$ENDIF FPC}tmp.DCT40_OnBuildDependNetwork); + PhysicsTunnel.AutomatedP2PVM_Open(); + exit; + end; + + Result := True; + for i := 0 to Length(DependNetworkInfoArray) - 1 do + if FindRegistedC40(DependNetworkInfoArray[i].Typ) = nil then + begin + PhysicsTunnel.Print('no registed "%s"', [DependNetworkInfoArray[i].Typ.Text]); + if Assigned(OnResult) then + OnResult(False); + exit; + end; + + tmp := TDCT40_QueryResultAndDependProcessor.Create; + tmp.DTC40_PhysicsTunnel := Self; + tmp.OnMethod := OnResult; + + if PhysicsTunnel.RemoteInited then + begin + QueryInfoM({$IFDEF FPC}@{$ENDIF FPC}tmp.DCT40_OnBuildDependNetwork); + exit; + end; + + IsConnecting := True; + PhysicsTunnel.AutomatedP2PVMService := False; + PhysicsTunnel.AutomatedP2PVMClient := False; + PhysicsTunnel.AsyncConnectM(PhysicsAddr, PhysicsPort, nil, tmp, {$IFDEF FPC}@{$ENDIF FPC}DoConnectAndBuildDependNetwork); +end; + +function TDTC40_PhysicsTunnel.BuildDependNetworkP(OnResult: TStateProc): Boolean; +var + i: Integer; + tmp: TDCT40_QueryResultAndDependProcessor; +begin + Result := False; + if IsConnecting then + exit; + if BuildNetworkIsDone then + begin + tmp := TDCT40_QueryResultAndDependProcessor.Create; + tmp.DTC40_PhysicsTunnel := Self; + tmp.OnProc := OnResult; + QueryInfoM({$IFDEF FPC}@{$ENDIF FPC}tmp.DCT40_OnBuildDependNetwork); + PhysicsTunnel.AutomatedP2PVM_Open(); + exit; + end; + + Result := True; + for i := 0 to Length(DependNetworkInfoArray) - 1 do + if FindRegistedC40(DependNetworkInfoArray[i].Typ) = nil then + begin + PhysicsTunnel.Print('no registed "%s"', [DependNetworkInfoArray[i].Typ.Text]); + if Assigned(OnResult) then + OnResult(False); + exit; + end; + + tmp := TDCT40_QueryResultAndDependProcessor.Create; + tmp.DTC40_PhysicsTunnel := Self; + tmp.OnProc := OnResult; + + if PhysicsTunnel.RemoteInited then + begin + QueryInfoM({$IFDEF FPC}@{$ENDIF FPC}tmp.DCT40_OnBuildDependNetwork); + exit; + end; + + IsConnecting := True; + PhysicsTunnel.AutomatedP2PVMService := False; + PhysicsTunnel.AutomatedP2PVMClient := False; + PhysicsTunnel.AsyncConnectM(PhysicsAddr, PhysicsPort, nil, tmp, {$IFDEF FPC}@{$ENDIF FPC}DoConnectAndBuildDependNetwork); +end; + +procedure TDTC40_PhysicsTunnel.QueryInfoC(OnResult: TDCT40_OnQueryResultC); +var + tmp: TDCT40_QueryResultData; +begin + tmp := TDCT40_QueryResultData.Create; + tmp.DTC40_PhysicsTunnel := Self; + tmp.OnResultC := OnResult; + + if PhysicsTunnel.RemoteInited then + begin + PhysicsTunnel.SendStreamCmdM('QueryInfo', nil, nil, nil, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParam, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailed); + exit; + end; + + IsConnecting := True; + PhysicsTunnel.AutomatedP2PVMService := False; + PhysicsTunnel.AutomatedP2PVMClient := False; + PhysicsTunnel.AsyncConnectM(PhysicsAddr, PhysicsPort, nil, tmp, {$IFDEF FPC}@{$ENDIF FPC}DoConnectAndQuery); +end; + +procedure TDTC40_PhysicsTunnel.QueryInfoM(OnResult: TDCT40_OnQueryResultM); +var + tmp: TDCT40_QueryResultData; +begin + tmp := TDCT40_QueryResultData.Create; + tmp.DTC40_PhysicsTunnel := Self; + tmp.OnResultM := OnResult; + + if PhysicsTunnel.RemoteInited then + begin + PhysicsTunnel.SendStreamCmdM('QueryInfo', nil, nil, nil, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParam, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailed); + exit; + end; + + IsConnecting := True; + PhysicsTunnel.AutomatedP2PVMService := False; + PhysicsTunnel.AutomatedP2PVMClient := False; + PhysicsTunnel.AsyncConnectM(PhysicsAddr, PhysicsPort, nil, tmp, {$IFDEF FPC}@{$ENDIF FPC}DoConnectAndQuery); +end; + +procedure TDTC40_PhysicsTunnel.QueryInfoP(OnResult: TDCT40_OnQueryResultP); +var + tmp: TDCT40_QueryResultData; +begin + tmp := TDCT40_QueryResultData.Create; + tmp.DTC40_PhysicsTunnel := Self; + tmp.OnResultP := OnResult; + + if PhysicsTunnel.RemoteInited then + begin + PhysicsTunnel.SendStreamCmdM('QueryInfo', nil, nil, nil, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParam, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailed); + exit; + end; + + IsConnecting := True; + PhysicsTunnel.AutomatedP2PVMService := False; + PhysicsTunnel.AutomatedP2PVMClient := False; + PhysicsTunnel.AsyncConnectM(PhysicsAddr, PhysicsPort, nil, tmp, {$IFDEF FPC}@{$ENDIF FPC}DoConnectAndQuery); +end; + +function TDTC40_PhysicsTunnel.DependNetworkIsConnected: Boolean; +var + i: Integer; +begin + Result := False; + if IsConnecting then + exit; + if not PhysicsTunnel.RemoteInited then + exit; + if not BuildNetworkIsDone then + exit; + for i := 0 to DependNetworkClientPool.Count - 1 do + if not DependNetworkClientPool[i].Connected then + exit; + Result := True; +end; + +procedure TDTC40_PhysicsTunnel.DoClientConnected(Custom_Client_: TDTC40_Custom_Client); +begin + if Assigned(OnEvent) then + OnEvent.DTC40_PhysicsTunnel_Client_Connected(Self, Custom_Client_); +end; + +function TDTC40_PhysicsTunnelPool.ExistsPhysicsAddr(PhysicsAddr: U_String; PhysicsPort: Word): Boolean; +var + i: Integer; +begin + Result := True; + for i := 0 to Count - 1 do + if PhysicsAddr.Same(@Items[i].PhysicsAddr) and (PhysicsPort = Items[i].PhysicsPort) then + exit; + Result := False; +end; + +function TDTC40_PhysicsTunnelPool.GetPhysicsTunnel(PhysicsAddr: U_String; PhysicsPort: Word): TDTC40_PhysicsTunnel; +var + i: Integer; +begin + Result := nil; + for i := 0 to Count - 1 do + if PhysicsAddr.Same(@Items[i].PhysicsAddr) and (PhysicsPort = Items[i].PhysicsPort) then + begin + Result := Items[i]; + exit; + end; +end; + +function TDTC40_PhysicsTunnelPool.GetOrCreatePhysicsTunnel(PhysicsAddr: U_String; PhysicsPort: Word): TDTC40_PhysicsTunnel; +begin + Result := GetPhysicsTunnel(PhysicsAddr, PhysicsPort); + if Result = nil then + Result := TDTC40_PhysicsTunnel.Create(PhysicsAddr, PhysicsPort); +end; + +function TDTC40_PhysicsTunnelPool.GetOrCreatePhysicsTunnel(PhysicsAddr: U_String; PhysicsPort: Word; + const Depend_: TDTC40_DependNetworkInfoArray; const OnEvent_: IDTC40_PhysicsTunnel_Event): TDTC40_PhysicsTunnel; +begin + Result := GetPhysicsTunnel(PhysicsAddr, PhysicsPort); + if Result = nil then + begin + Result := TDTC40_PhysicsTunnel.Create(PhysicsAddr, PhysicsPort); + Result.OnEvent := OnEvent_; + Result.ResetDepend(Depend_); + Result.BuildDependNetwork(); + end; +end; + +function TDTC40_PhysicsTunnelPool.GetOrCreatePhysicsTunnel(PhysicsAddr: U_String; PhysicsPort: Word; + const Depend_: U_String; const OnEvent_: IDTC40_PhysicsTunnel_Event): TDTC40_PhysicsTunnel; +begin + Result := GetPhysicsTunnel(PhysicsAddr, PhysicsPort); + if Result = nil then + begin + Result := TDTC40_PhysicsTunnel.Create(PhysicsAddr, PhysicsPort); + Result.OnEvent := OnEvent_; + Result.ResetDepend(Depend_); + Result.BuildDependNetwork(); + end; +end; + +function TDTC40_PhysicsTunnelPool.GetOrCreatePhysicsTunnel(dispInfo: TDTC40_Info): TDTC40_PhysicsTunnel; +begin + Result := GetPhysicsTunnel(dispInfo.PhysicsAddr, dispInfo.PhysicsPort); + if Result = nil then + Result := TDTC40_PhysicsTunnel.Create(dispInfo.PhysicsAddr, dispInfo.PhysicsPort); +end; + +function TDTC40_PhysicsTunnelPool.GetOrCreatePhysicsTunnel(dispInfo: TDTC40_Info; + const Depend_: TDTC40_DependNetworkInfoArray; const OnEvent_: IDTC40_PhysicsTunnel_Event): TDTC40_PhysicsTunnel; +begin + Result := GetPhysicsTunnel(dispInfo.PhysicsAddr, dispInfo.PhysicsPort); + if Result = nil then + begin + Result := TDTC40_PhysicsTunnel.Create(dispInfo.PhysicsAddr, dispInfo.PhysicsPort); + Result.OnEvent := OnEvent_; + Result.ResetDepend(Depend_); + Result.BuildDependNetwork(); + end; +end; + +procedure TDTC40_PhysicsTunnelPool.Progress; +var + i: Integer; +begin + for i := 0 to Count - 1 do + Items[i].Progress; +end; + +procedure TDTC40_Info.MakeHash; +var + n: U_String; + buff: TBytes; +begin + n := umlTrimSpace(PhysicsAddr) + '_' + umlIntToStr(PhysicsPort) + '_' + p2pVM_RecvTunnel_Addr + '_' + p2pVM_SendTunnel_Addr; + n := n.LowerText; + buff := n.Bytes; + n := ''; + Hash := umlMD5(@buff[0], Length(buff)); + SetLength(buff, 0); +end; + +constructor TDTC40_Info.Create; +begin + inherited Create; + Ignored := False; + LastUpdateTimeTick := GetTimeTick(); + + OnlyInstance := False; + ServiceTyp := ''; + PhysicsAddr := ''; + PhysicsPort := 0; + p2pVM_Auth := ''; + p2pVM_RecvTunnel_Addr := ''; + p2pVM_RecvTunnel_Port := 0; + p2pVM_SendTunnel_Addr := ''; + p2pVM_SendTunnel_Port := 0; + Workload := 0; + MaxWorkload := 0; + AliveTime := 0; + Hash := NullMD5; +end; + +destructor TDTC40_Info.Destroy; +begin + ServiceTyp := ''; + PhysicsAddr := ''; + p2pVM_Auth := ''; + p2pVM_RecvTunnel_Addr := ''; + p2pVM_SendTunnel_Addr := ''; + inherited Destroy; +end; + +procedure TDTC40_Info.Assign(source: TDTC40_Info); +begin + Ignored := source.Ignored; + LastUpdateTimeTick := source.LastUpdateTimeTick; + OnlyInstance := source.OnlyInstance; + ServiceTyp := source.ServiceTyp; + PhysicsAddr := source.PhysicsAddr; + PhysicsPort := source.PhysicsPort; + p2pVM_Auth := source.p2pVM_Auth; + p2pVM_RecvTunnel_Addr := source.p2pVM_RecvTunnel_Addr; + p2pVM_RecvTunnel_Port := source.p2pVM_RecvTunnel_Port; + p2pVM_SendTunnel_Addr := source.p2pVM_SendTunnel_Addr; + p2pVM_SendTunnel_Port := source.p2pVM_SendTunnel_Port; + Workload := source.Workload; + MaxWorkload := source.MaxWorkload; + AliveTime := source.AliveTime; + Hash := source.Hash; +end; + +function TDTC40_Info.Clone: TDTC40_Info; +begin + Result := TDTC40_Info.Create; + Result.Assign(Self); +end; + +procedure TDTC40_Info.Load(stream: TCoreClassStream); +var + D: TDFE; +begin + D := TDFE.Create; + D.LoadFromStream(stream); + + OnlyInstance := D.R.ReadBool; + ServiceTyp := D.R.ReadString; + PhysicsAddr := D.R.ReadString; + PhysicsPort := D.R.ReadWord; + p2pVM_Auth := D.R.ReadString; + p2pVM_RecvTunnel_Addr := D.R.ReadString; + p2pVM_RecvTunnel_Port := D.R.ReadWord; + p2pVM_SendTunnel_Addr := D.R.ReadString; + p2pVM_SendTunnel_Port := D.R.ReadWord; + Workload := D.R.ReadInteger; + MaxWorkload := D.R.ReadInteger; + AliveTime := D.R.ReadUInt64; + Hash := D.R.ReadMD5; + + DisposeObject(D); +end; + +procedure TDTC40_Info.Save(stream: TCoreClassStream); +var + D: TDFE; +begin + D := TDFE.Create; + + D.WriteBool(OnlyInstance); + D.WriteString(ServiceTyp); + D.WriteString(PhysicsAddr); + D.WriteWord(PhysicsPort); + D.WriteString(p2pVM_Auth); + D.WriteString(p2pVM_RecvTunnel_Addr); + D.WriteWord(p2pVM_RecvTunnel_Port); + D.WriteString(p2pVM_SendTunnel_Addr); + D.WriteWord(p2pVM_SendTunnel_Port); + D.WriteInteger(Workload); + D.WriteInteger(MaxWorkload); + D.WriteUInt64(AliveTime); + D.WriteMD5(Hash); + + D.FastEncodeTo(stream); + DisposeObject(D); +end; + +function TDTC40_Info.Same(Data_: TDTC40_Info): Boolean; +begin + Result := False; + if not ServiceTyp.Same(@Data_.ServiceTyp) then + exit; + if not PhysicsAddr.Same(@Data_.PhysicsAddr) then + exit; + if PhysicsPort <> Data_.PhysicsPort then + exit; + if not p2pVM_RecvTunnel_Addr.Same(@Data_.p2pVM_RecvTunnel_Addr) then + exit; + if p2pVM_RecvTunnel_Port <> Data_.p2pVM_RecvTunnel_Port then + exit; + if not p2pVM_SendTunnel_Addr.Same(@Data_.p2pVM_SendTunnel_Addr) then + exit; + if p2pVM_SendTunnel_Port <> Data_.p2pVM_SendTunnel_Port then + exit; + Result := True; +end; + +function TDTC40_Info.SameServiceTyp(Data_: TDTC40_Info): Boolean; +begin + Result := ServiceTyp.Same(@Data_.ServiceTyp); +end; + +function TDTC40_Info.SamePhysicsAddr(Data_: TDTC40_Info): Boolean; +begin + Result := False; + if not PhysicsAddr.Same(@Data_.PhysicsAddr) then + exit; + if PhysicsPort <> Data_.PhysicsPort then + exit; + Result := True; +end; + +function TDTC40_Info.SamePhysicsAddr(Data_: TDTC40_PhysicsTunnel): Boolean; +begin + Result := False; + if not PhysicsAddr.Same(@Data_.PhysicsAddr) then + exit; + if PhysicsPort <> Data_.PhysicsPort then + exit; + Result := True; +end; + +function TDTC40_Info.SamePhysicsAddr(Data_: TDTC40_PhysicsService): Boolean; +begin + Result := False; + if not PhysicsAddr.Same(@Data_.PhysicsAddr) then + exit; + if PhysicsPort <> Data_.PhysicsPort then + exit; + Result := True; +end; + +function TDTC40_Info.SameP2PVMAddr(Data_: TDTC40_Info): Boolean; +begin + Result := False; + if not p2pVM_RecvTunnel_Addr.Same(@Data_.p2pVM_RecvTunnel_Addr) then + exit; + if p2pVM_RecvTunnel_Port <> Data_.p2pVM_RecvTunnel_Port then + exit; + if not p2pVM_SendTunnel_Addr.Same(@Data_.p2pVM_SendTunnel_Addr) then + exit; + if p2pVM_SendTunnel_Port <> Data_.p2pVM_SendTunnel_Port then + exit; + Result := True; +end; + +function TDTC40_Info.ReadyDTC40Client: Boolean; +var + p: PDTC40_RegistedData; +begin + p := FindRegistedC40(ServiceTyp); + Result := (p <> nil) and (p^.ClientClass <> nil); +end; + +function TDTC40_Info.GetOrCreateDTC40Client(Param_: U_String): TDTC40_Custom_Client; +var + p: PDTC40_RegistedData; + i: Integer; +begin + Result := nil; + for i := 0 to DTC40_ClientPool.Count - 1 do + if Same(DTC40_ClientPool[i].ClientInfo) then + begin + Result := DTC40_ClientPool[i]; + exit; + end; + + p := FindRegistedC40(ServiceTyp); + if p <> nil then + Result := p^.ClientClass.Create(Self, Param_); +end; + +constructor TDTC40_InfoList.Create(AutoFree_: Boolean); +begin + inherited Create; + AutoFree := AutoFree_; +end; + +destructor TDTC40_InfoList.Destroy; +begin + Clear; + inherited Destroy; +end; + +procedure TDTC40_InfoList.Remove(obj: TDTC40_Info); +begin + if AutoFree then + DisposeObject(obj); + inherited Remove(obj); +end; + +procedure TDTC40_InfoList.Delete(index: Integer); +begin + if AutoFree then + DisposeObject(Items[index]); + inherited Delete(index); +end; + +procedure TDTC40_InfoList.Clear; +var + i: Integer; +begin + if AutoFree then + for i := 0 to Count - 1 do + DisposeObject(Items[i]); + inherited Clear; +end; + +class procedure TDTC40_InfoList.SortWorkLoad(L: TDTC40_InfoList); + function Compare_(Left, Right: TDTC40_Info): ShortInt; + begin + Result := CompareFloat(Left.Workload / Left.MaxWorkload, Right.Workload / Right.MaxWorkload); + if Result = 0 then + Result := CompareGeoInt(Right.MaxWorkload, Left.MaxWorkload); + end; + + procedure fastSort_(var Arry_: TDTC40_InfoList; L, R: Integer); + var + i, j: Integer; + p: TDTC40_Info; + begin + repeat + i := L; + j := R; + p := Arry_[(L + R) shr 1]; + repeat + while Compare_(Arry_[i], p) < 0 do + inc(i); + while Compare_(Arry_[j], p) > 0 do + dec(j); + if i <= j then + begin + if i <> j then + Arry_.Exchange(i, j); + inc(i); + dec(j); + end; + until i > j; + if L < j then + fastSort_(Arry_, L, j); + L := i; + until i >= R; + end; + +begin + if L.Count > 1 then + fastSort_(L, 0, L.Count - 1); +end; + +function TDTC40_InfoList.IsOnlyInstance(ServiceTyp: U_String): Boolean; +var + i: Integer; +begin + Result := False; + for i := 0 to Count - 1 do + if umlMultipleMatch(True, ServiceTyp, Items[i].ServiceTyp) and Items[i].OnlyInstance then + begin + Result := True; + exit; + end; +end; + +function TDTC40_InfoList.GetServiceTypNum(ServiceTyp: U_String): Integer; +var + i: Integer; +begin + Result := 0; + for i := 0 to Count - 1 do + if umlMultipleMatch(True, ServiceTyp, Items[i].ServiceTyp) then + inc(Result); +end; + +function TDTC40_InfoList.SearchService(ServiceTyp: U_String): TDTC40_InfoList; +var + L: TDTC40_InfoList; + i: Integer; +begin + L := TDTC40_InfoList.Create(False); + + { filter } + for i := 0 to Count - 1 do + if umlMultipleMatch(True, ServiceTyp, Items[i].ServiceTyp) then + L.Add(Items[i]); + + { sort } + TDTC40_InfoList.SortWorkLoad(L); + + Result := L; +end; + +function TDTC40_InfoList.ExistsService(ServiceTyp: U_String): Boolean; +var + i: Integer; +begin + Result := True; + for i := 0 to Count - 1 do + if umlMultipleMatch(True, ServiceTyp, Items[i].ServiceTyp) then + exit; + Result := False; +end; + +function TDTC40_InfoList.ExistsServiceAndPhysicsTunnel(ServiceTyp: U_String; PhysicsTunnel_: TDTC40_PhysicsTunnel): Boolean; +var + i: Integer; +begin + Result := True; + for i := 0 to Count - 1 do + if umlMultipleMatch(True, ServiceTyp, Items[i].ServiceTyp) and (Items[i].SamePhysicsAddr(PhysicsTunnel_)) then + exit; + Result := False; +end; + +function TDTC40_InfoList.FindSame(Data_: TDTC40_Info): TDTC40_Info; +var + i: Integer; +begin + Result := nil; + for i := 0 to Count - 1 do + if Items[i].Same(Data_) then + begin + Result := Items[i]; + exit; + end; +end; + +function TDTC40_InfoList.FindHash(Hash: TMD5): TDTC40_Info; +var + i: Integer; +begin + Result := nil; + for i := 0 to Count - 1 do + if umlCompareMD5(Hash, Items[i].Hash) then + begin + Result := Items[i]; + exit; + end; +end; + +function TDTC40_InfoList.ExistsPhysicsAddr(PhysicsAddr: U_String; PhysicsPort: Word): Boolean; +var + i: Integer; +begin + Result := True; + for i := 0 to Count - 1 do + if PhysicsAddr.Same(@Items[i].PhysicsAddr) and (PhysicsPort = Items[i].PhysicsPort) then + exit; + Result := False; +end; + +procedure TDTC40_InfoList.RemovePhysicsAddr(PhysicsAddr: U_String; PhysicsPort: Word); +var + i: Integer; +begin + i := 0; + while i < Count do + if PhysicsAddr.Same(@Items[i].PhysicsAddr) and (PhysicsPort = Items[i].PhysicsPort) then + Delete(i) + else + inc(i); +end; + +function TDTC40_InfoList.OverwriteInfo(Data_: TDTC40_Info): Boolean; +var + found_: TDTC40_Info; +begin + Result := False; + found_ := FindSame(Data_); + if found_ <> nil then + begin + if found_ <> Data_ then + found_.Assign(Data_); + end + else + begin + if AutoFree then + begin + Add(Data_.Clone); + Result := True; + end + else + DoStatus('not autofree a memory leak.'); + end; +end; + +function TDTC40_InfoList.MergeFromDF(D: TDFE): Boolean; +var + i: Integer; + m64: TMS64; + tmp, found_: TDTC40_Info; +begin + Result := False; + while D.R.NotEnd do + begin + m64 := TMS64.Create; + D.R.ReadStream(m64); + m64.Position := 0; + tmp := TDTC40_Info.Create; + tmp.Load(m64); + DisposeObject(m64); + found_ := FindSame(tmp); + if found_ <> nil then + begin + DisposeObject(tmp); + end + else + begin + if not AutoFree then + begin + DoStatus('not autofree a memory leak.'); + end + else if (tmp.OnlyInstance) and (GetServiceTypNum(tmp.ServiceTyp) > 0) then + begin + DoStatus('"%s" is only instance.', [tmp.ServiceTyp.Text]); + end + else + begin + Add(tmp); + Result := True; + end; + end; + end; +end; + +procedure TDTC40_InfoList.SaveToDF(D: TDFE); +var + i: Integer; + m64: TMS64; +begin + m64 := TMS64.Create; + for i := 0 to Count - 1 do + if not Items[i].Ignored then + begin + Items[i].Save(m64); + D.WriteStream(m64); + m64.Clear; + end; + DisposeObject(m64); +end; + +procedure TDTC40_InfoList.UpdateAlive(PhysicsService_: TDTC40_PhysicsService); +var + i: Integer; +begin + for i := 0 to Count - 1 do + with Items[i] do + if SamePhysicsAddr(PhysicsService_) then + begin + LastUpdateTimeTick := GetTimeTick; + end; +end; + +procedure TDTC40_InfoList.UpdateAlive(PhysicsTunnel_: TDTC40_PhysicsTunnel); +var + i: Integer; +begin + for i := 0 to Count - 1 do + with Items[i] do + if SamePhysicsAddr(PhysicsTunnel_) then + begin + LastUpdateTimeTick := GetTimeTick; + end; +end; + +constructor TDTC40_Custom_Service.Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); +var + P2PVM_Recv_Name_, P2PVM_Recv_IP6_, P2PVM_Recv_Port_: U_String; + P2PVM_Send_Name_, P2PVM_Send_IP6_, P2PVM_Send_Port_: U_String; + tmp: TPascalStringList; +begin + inherited Create; + + FLastSafeCheckTime := GetTimeTick; + SafeCheckTime := DTC40_SafeCheckTime; + + Param := Param_; + DTC40PhysicsService := PhysicsService_; + + P2PVM_Recv_Name_ := ServiceTyp + 'R'; + DTC40_ServicePool.MakeP2PVM_IPv6_Port(P2PVM_Recv_IP6_, P2PVM_Recv_Port_); + P2PVM_Send_Name_ := ServiceTyp + 'S'; + DTC40_ServicePool.MakeP2PVM_IPv6_Port(P2PVM_Send_IP6_, P2PVM_Send_Port_); + + ServiceInfo := TDTC40_Info.Create; + ServiceInfo.ServiceTyp := ServiceTyp; + ServiceInfo.PhysicsAddr := DTC40PhysicsService.PhysicsAddr; + ServiceInfo.PhysicsPort := DTC40PhysicsService.PhysicsPort; + ServiceInfo.p2pVM_Auth := DTC40PhysicsService.PhysicsTunnel.AutomatedP2PVMAuthToken; + ServiceInfo.p2pVM_RecvTunnel_Addr := P2PVM_Recv_IP6_; + ServiceInfo.p2pVM_RecvTunnel_Port := umlStrToInt(P2PVM_Recv_Port_); + ServiceInfo.p2pVM_SendTunnel_Addr := P2PVM_Send_IP6_; + ServiceInfo.p2pVM_SendTunnel_Port := umlStrToInt(P2PVM_Send_Port_); + SetWorkload(0, 100); + ServiceInfo.MakeHash; + + ParamList := THashStringList.Create; + try + tmp := TPascalStringList.Create; + umlSeparatorText(Param, tmp, ',;' + #13#10); + ParamList.ImportFromStrings(tmp); + DisposeObject(tmp); + except + end; + + DTC40_ServicePool.Add(Self); + DTC40PhysicsService.DependNetworkServicePool.Add(Self); +end; + +destructor TDTC40_Custom_Service.Destroy; +begin + DTC40PhysicsService.DependNetworkServicePool.Remove(Self); + DTC40_ServicePool.Remove(Self); + DisposeObject(ServiceInfo); + DisposeObject(ParamList); + inherited Destroy; +end; + +procedure TDTC40_Custom_Service.SafeCheck; +begin + +end; + +procedure TDTC40_Custom_Service.Progress; +begin + if GetTimeTick - FLastSafeCheckTime > SafeCheckTime then + begin + SafeCheck; + FLastSafeCheckTime := GetTimeTick; + end; +end; + +procedure TDTC40_Custom_Service.SetWorkload(Workload_, MaxWorkload_: Integer); +begin + ServiceInfo.Workload := MaxWorkload_; + ServiceInfo.MaxWorkload := MaxWorkload_; +end; + +procedure TDTC40_Custom_Service.UpdateToGlobalDispatch; +var + i: Integer; + dps: TDTC40_Dispatch_Service; + dpc: TDTC40_Dispatch_Client; +begin + for i := 0 to DTC40_ServicePool.Count - 1 do + begin + if DTC40_ServicePool[i] is TDTC40_Dispatch_Service then + begin + dps := TDTC40_Dispatch_Service(DTC40_ServicePool[i]); + if dps.ServiceInfoList.OverwriteInfo(ServiceInfo) then + dps.Prepare_UpdateServerInfoToAllClient; + end; + end; + for i := 0 to DTC40_ClientPool.Count - 1 do + begin + if DTC40_ClientPool[i] is TDTC40_Dispatch_Client then + begin + dpc := TDTC40_Dispatch_Client(DTC40_ClientPool[i]); + if dpc.ServiceInfoList.OverwriteInfo(ServiceInfo) and dpc.Connected then + dpc.PostLocalServiceInfo(True); + end; + end; +end; + +function TDTC40_Custom_Service.GetHash: TMD5; +begin + Result := ServiceInfo.Hash; +end; + +procedure TDTC40_Custom_Service.DoLinkSuccess(Trigger_: TCoreClassObject); +begin + DTC40PhysicsService.DoLinkSuccess(Self, Trigger_); +end; + +procedure TDTC40_Custom_Service.DoUserOut(Trigger_: TCoreClassObject); +begin + DTC40PhysicsService.DoUserOut(Self, Trigger_); +end; + +constructor TDTC40_Custom_ServicePool.Create; +begin + inherited Create; + FIPV6_Seed := 1; +end; + +procedure TDTC40_Custom_ServicePool.Progress; +var + i: Integer; +begin + for i := 0 to Count - 1 do + Items[i].Progress; +end; + +procedure TDTC40_Custom_ServicePool.MakeP2PVM_IPv6_Port(var ip6, port: U_String); +var + tmp: TIPV6; + i: Integer; +begin + for i := 0 to 7 do + tmp[i] := FIPV6_Seed; + inc(FIPV6_Seed); + port := '1'; + ip6 := IPV6ToStr(tmp); +end; + +function TDTC40_Custom_ServicePool.GetServiceFromHash(Hash: TMD5): TDTC40_Custom_Service; +var + i: Integer; +begin + Result := nil; + for i := 0 to Count - 1 do + if umlCompareMD5(Hash, Items[i].ServiceInfo.Hash) then + Result := Items[i]; +end; + +function TDTC40_Custom_ServicePool.ExistsPhysicsAddr(PhysicsAddr: U_String; PhysicsPort: Word): Boolean; +var + i: Integer; +begin + Result := True; + for i := 0 to Count - 1 do + if PhysicsAddr.Same(@Items[i].ServiceInfo.PhysicsAddr) and (PhysicsPort = Items[i].ServiceInfo.PhysicsPort) then + exit; + Result := False; +end; + +function TDTC40_Custom_ServicePool.ExistsOnlyInstance(ServiceTyp: U_String): Boolean; +var + i: Integer; +begin + Result := True; + for i := 0 to Count - 1 do + if Items[i].ServiceInfo.OnlyInstance and ServiceTyp.Same(@Items[i].ServiceInfo.ServiceTyp) then + exit; + Result := False; +end; + +function TDTC40_Custom_ServicePool.GetDTC40Array: TDTC40_Custom_Service_Array; +var + i: Integer; +begin + SetLength(Result, Count); + for i := 0 to Count - 1 do + Result[i] := Items[i]; +end; + +function TDTC40_Custom_ServicePool.GetFromServiceTyp(ServiceTyp: U_String): TDTC40_Custom_Service_Array; +var + L: TDTC40_Custom_ServicePool; + i: Integer; +begin + L := TDTC40_Custom_ServicePool.Create; + for i := 0 to Count - 1 do + if ServiceTyp.Same(@Items[i].ServiceInfo.ServiceTyp) then + L.Add(Items[i]); + Result := L.GetDTC40Array; + DisposeObject(L); +end; + +function TDTC40_Custom_ServicePool.GetFromPhysicsAddr(PhysicsAddr: U_String; PhysicsPort: Word): TDTC40_Custom_Service_Array; +var + L: TDTC40_Custom_ServicePool; + i: Integer; +begin + L := TDTC40_Custom_ServicePool.Create; + for i := 0 to Count - 1 do + if (PhysicsPort = Items[i].ServiceInfo.PhysicsPort) and PhysicsAddr.Same(@Items[i].ServiceInfo.PhysicsAddr) then + L.Add(Items[i]); + Result := L.GetDTC40Array; + DisposeObject(L); +end; + +function TDTC40_Custom_ServicePool.GetFromClass(Class_: TDTC40_Custom_Service_Class): TDTC40_Custom_Service_Array; +var + L: TDTC40_Custom_ServicePool; + i: Integer; +begin + L := TDTC40_Custom_ServicePool.Create; + for i := 0 to Count - 1 do + if Items[i].InheritsFrom(Class_) then + L.Add(Items[i]); + Result := L.GetDTC40Array; + DisposeObject(L); +end; + +constructor TDTC40_Custom_Client.Create(source_: TDTC40_Info; Param_: U_String); +var + tmp: TPascalStringList; +begin + inherited Create; + Param := Param_; + ClientInfo := TDTC40_Info.Create; + ClientInfo.Assign(source_); + + ParamList := THashStringList.Create; + try + tmp := TPascalStringList.Create; + umlSeparatorText(Param, tmp, ',;' + #13#10); + ParamList.ImportFromStrings(tmp); + DisposeObject(tmp); + except + end; + + DTC40_ClientPool.Add(Self); + DTC40PhysicsTunnel := DTC40_PhysicsTunnelPool.GetOrCreatePhysicsTunnel(ClientInfo); + DTC40PhysicsTunnel.DependNetworkClientPool.Add(Self); +end; + +destructor TDTC40_Custom_Client.Destroy; +begin + DTC40_ClientPool.Remove(Self); + DTC40PhysicsTunnel.DependNetworkClientPool.Remove(Self); + DisposeObject(ClientInfo); + DisposeObject(ParamList); + inherited Destroy; +end; + +procedure TDTC40_Custom_Client.Progress; +begin + +end; + +procedure TDTC40_Custom_Client.Connect; +begin + +end; + +function TDTC40_Custom_Client.Connected: Boolean; +begin + Result := False; +end; + +procedure TDTC40_Custom_Client.Disconnect; +begin + +end; + +function TDTC40_Custom_Client.GetHash: TMD5; +begin + Result := ClientInfo.Hash; +end; + +procedure TDTC40_Custom_Client.DoClientConnected; +begin + DTC40PhysicsTunnel.DoClientConnected(Self); +end; + +procedure TDTC40_Custom_ClientPool_Wait.DoRun; +var + found_: TDTC40_Custom_Client; +begin + found_ := Pool_.ExistsConnectedServiceTyp(ServiceTyp_); + if (found_ <> nil) then + begin + try + if Assigned(OnCall) then + OnCall(found_); + if Assigned(OnMethod) then + OnMethod(found_); + if Assigned(OnProc) then + OnProc(found_); + except + end; + DelayFreeObject(0.5, Self, nil); + end + else + SystemPostProgress.PostExecuteM_NP(0.1, {$IFDEF FPC}@{$ENDIF FPC}DoRun); +end; + +constructor TDTC40_Custom_ClientPool_Wait.Create; +begin + inherited Create; + Pool_ := nil; + ServiceTyp_ := ''; + TimeOut_ := 0; + OnCall := nil; + OnMethod := nil; + OnProc := nil; +end; + +destructor TDTC40_Custom_ClientPool_Wait.Destroy; +begin + inherited Destroy; +end; + +procedure TDTC40_Custom_ClientPool.Progress; +var + i: Integer; +begin + for i := 0 to Count - 1 do + Items[i].Progress; +end; + +function TDTC40_Custom_ClientPool.ExistsPhysicsAddr(PhysicsAddr: U_String; PhysicsPort: Word): Boolean; +var + i: Integer; +begin + Result := True; + for i := 0 to Count - 1 do + if PhysicsAddr.Same(@Items[i].ClientInfo.PhysicsAddr) and (PhysicsPort = Items[i].ClientInfo.PhysicsPort) then + exit; + Result := False; +end; + +function TDTC40_Custom_ClientPool.ExistsServiceInfo(info_: TDTC40_Info): Boolean; +var + i: Integer; +begin + Result := True; + for i := 0 to Count - 1 do + if info_.Same(Items[i].ClientInfo) then + exit; + Result := False; +end; + +function TDTC40_Custom_ClientPool.ExistsServiceTyp(ServiceTyp: U_String): Boolean; +var + i: Integer; +begin + Result := True; + for i := 0 to Count - 1 do + if ServiceTyp.Same(@Items[i].ClientInfo.ServiceTyp) then + exit; + Result := False; +end; + +function TDTC40_Custom_ClientPool.ExistsClass(Class_: TDTC40_Custom_Client_Class): TDTC40_Custom_Client; +var + i: Integer; +begin + Result := nil; + for i := 0 to Count - 1 do + if Items[i].InheritsFrom(Class_) then + exit(Items[i]); +end; + +function TDTC40_Custom_ClientPool.ExistsConnectedClass(Class_: TDTC40_Custom_Client_Class): TDTC40_Custom_Client; +var + i: Integer; +begin + Result := nil; + for i := 0 to Count - 1 do + if Items[i].InheritsFrom(Class_) and Items[i].Connected then + exit(Items[i]); +end; + +function TDTC40_Custom_ClientPool.ExistsConnectedServiceTyp(ServiceTyp: U_String): TDTC40_Custom_Client; +var + i: Integer; +begin + Result := nil; + for i := 0 to Count - 1 do + if ServiceTyp.Same(@Items[i].ClientInfo.ServiceTyp) and Items[i].Connected then + exit(Items[i]); +end; + +function TDTC40_Custom_ClientPool.GetClientFromHash(Hash: TMD5): TDTC40_Custom_Client; +var + i: Integer; +begin + Result := nil; + for i := 0 to Count - 1 do + if umlCompareMD5(Hash, Items[i].ClientInfo.Hash) then + Result := Items[i]; +end; + +function TDTC40_Custom_ClientPool.GetDTC40Array: TDTC40_Custom_Client_Array; +var + i: Integer; +begin + SetLength(Result, Count); + for i := 0 to Count - 1 do + Result[i] := Items[i]; +end; + +function TDTC40_Custom_ClientPool.GetFromServiceTyp(ServiceTyp: U_String): TDTC40_Custom_Client_Array; +var + L: TDTC40_Custom_ClientPool; + i: Integer; +begin + L := TDTC40_Custom_ClientPool.Create; + for i := 0 to Count - 1 do + if ServiceTyp.Same(@Items[i].ClientInfo.ServiceTyp) then + L.Add(Items[i]); + Result := L.GetDTC40Array; + DisposeObject(L); +end; + +function TDTC40_Custom_ClientPool.GetFromPhysicsAddr(PhysicsAddr: U_String; PhysicsPort: Word): TDTC40_Custom_Client_Array; +var + L: TDTC40_Custom_ClientPool; + i: Integer; +begin + L := TDTC40_Custom_ClientPool.Create; + for i := 0 to Count - 1 do + if (PhysicsPort = Items[i].ClientInfo.PhysicsPort) and PhysicsAddr.Same(@Items[i].ClientInfo.PhysicsAddr) then + L.Add(Items[i]); + Result := L.GetDTC40Array; + DisposeObject(L); +end; + +function TDTC40_Custom_ClientPool.GetFromClass(Class_: TDTC40_Custom_Client_Class): TDTC40_Custom_Client_Array; +var + L: TDTC40_Custom_ClientPool; + i: Integer; +begin + L := TDTC40_Custom_ClientPool.Create; + for i := 0 to Count - 1 do + if Items[i].InheritsFrom(Class_) then + L.Add(Items[i]); + Result := L.GetDTC40Array; + DisposeObject(L); +end; + +procedure TDTC40_Custom_ClientPool.WaitConnectedDoneC(ServiceTyp: U_String; TimeOut_: TTimeTick; OnResult: TOn_DTC40_Custom_Client_EventC); +var + tmp: TDTC40_Custom_ClientPool_Wait; +begin + tmp := TDTC40_Custom_ClientPool_Wait.Create; + tmp.Pool_ := Self; + tmp.ServiceTyp_ := ServiceTyp; + tmp.TimeOut_ := GetTimeTick + TimeOut_; + tmp.OnCall := OnResult; + SystemPostProgress.PostExecuteM_NP(0.1, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoRun); +end; + +procedure TDTC40_Custom_ClientPool.WaitConnectedDoneM(ServiceTyp: U_String; TimeOut_: TTimeTick; OnResult: TOn_DTC40_Custom_Client_EventM); +var + tmp: TDTC40_Custom_ClientPool_Wait; +begin + tmp := TDTC40_Custom_ClientPool_Wait.Create; + tmp.Pool_ := Self; + tmp.ServiceTyp_ := ServiceTyp; + tmp.TimeOut_ := GetTimeTick + TimeOut_; + tmp.OnMethod := OnResult; + SystemPostProgress.PostExecuteM_NP(0.1, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoRun); +end; + +procedure TDTC40_Custom_ClientPool.WaitConnectedDoneP(ServiceTyp: U_String; TimeOut_: TTimeTick; OnResult: TOn_DTC40_Custom_Client_EventP); +var + tmp: TDTC40_Custom_ClientPool_Wait; +begin + tmp := TDTC40_Custom_ClientPool_Wait.Create; + tmp.Pool_ := Self; + tmp.ServiceTyp_ := ServiceTyp; + tmp.TimeOut_ := GetTimeTick + TimeOut_; + tmp.OnProc := OnResult; + SystemPostProgress.PostExecuteM_NP(0.1, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoRun); +end; + +constructor TOnRemovePhysicsNetwork.Create; +begin + PhysicsAddr := ''; + PhysicsPort := 0; +end; + +procedure TOnRemovePhysicsNetwork.DoRun; +begin + C40RemovePhysics(PhysicsAddr, PhysicsPort, True, True, True, True); + DelayFreeObject(1.0, Self); +end; + +procedure TDTC40_Dispatch_Service.cmd_UpdateServiceInfo(Sender: TPeerIO; InData: TDFE); +begin + if ServiceInfoList.MergeFromDF(InData) then + begin + Prepare_UpdateServerInfoToAllClient; + + if Assigned(FOnServiceInfoChange) then + FOnServiceInfoChange(Self, ServiceInfoList); + end; +end; + +procedure TDTC40_Dispatch_Service.cmd_UpdateServiceState(Sender: TPeerIO; InData: TDFE); +var + D: TDFE; + Hash: TMD5; + Workload, MaxWorkload: Integer; + info_: TDTC40_Info; + i: Integer; +begin + D := TDFE.Create; + while InData.R.NotEnd do + begin + InData.R.ReadDataFrame(D); + Hash := D.R.ReadMD5; + Workload := D.R.ReadInteger; + MaxWorkload := D.R.ReadInteger; + info_ := ServiceInfoList.FindHash(Hash); + if (info_ <> nil) then + begin + info_.Workload := Workload; + info_.MaxWorkload := MaxWorkload; + end; + end; + DisposeObject(D); + + for i := 0 to DTC40_ServicePool.Count - 1 do + begin + info_ := ServiceInfoList.FindSame(DTC40_ServicePool[i].ServiceInfo); + if info_ <> nil then + info_.Assign(DTC40_ServicePool[i].ServiceInfo); + end; +end; + +procedure TDTC40_Dispatch_Service.cmd_IgnoreChange(Sender: TPeerIO; InData: TDFE); +var + Hash: TMD5; + Ignored: Boolean; + info_: TDTC40_Info; +begin + Hash := InData.R.ReadMD5; + Ignored := InData.R.ReadBool; + info_ := ServiceInfoList.FindHash(Hash); + if (info_ <> nil) and (info_.Ignored <> Ignored) then + begin + info_.Ignored := Ignored; + IgnoreChangeToAllClient(info_.Hash, info_.Ignored); + end; +end; + +procedure TDTC40_Dispatch_Service.cmd_RequestUpdate(Sender: TPeerIO; InData: TDFE); +begin + Prepare_UpdateServerInfoToAllClient; +end; + +procedure TDTC40_Dispatch_Service.cmd_RemovePhysicsNetwork(Sender: TPeerIO; InData: TDFE); +var + tmp: TOnRemovePhysicsNetwork; + Arry_: TIO_Array; + ID_: Cardinal; + IO_: TPeerIO; + IODef_: TPeerClientUserDefineForRecvTunnel_NoAuth; +begin + tmp := TOnRemovePhysicsNetwork.Create; + tmp.PhysicsAddr := InData.R.ReadString; + tmp.PhysicsPort := InData.R.ReadWord; + SysPost.PostExecuteM_NP(2.0, tmp.DoRun); + + if C40ExistsPhysicsNetwork(tmp.PhysicsAddr, tmp.PhysicsPort) then + begin + Service.RecvTunnel.GetIO_Array(Arry_); + for ID_ in Arry_ do + begin + IO_ := Service.RecvTunnel[ID_]; + if (IO_ <> nil) and (IO_ <> Sender) and TPeerClientUserDefineForRecvTunnel_NoAuth(IO_.UserDefine).LinkOk then + begin + IODef_ := TPeerClientUserDefineForRecvTunnel_NoAuth(IO_.UserDefine); + IODef_.SendTunnel.Owner.SendDirectStreamCmd('RemovePhysicsNetwork', InData); + end; + end; + end; +end; + +procedure TDTC40_Dispatch_Service.Prepare_UpdateServerInfoToAllClient; +begin + FWaiting_UpdateServerInfoToAllClient := True; + FWaiting_UpdateServerInfoToAllClient_TimeTick := GetTimeTick + 5000; +end; + +procedure TDTC40_Dispatch_Service.UpdateServerInfoToAllClient; +var + D: TDFE; + Arry_: TIO_Array; + ID_: Cardinal; + IO_: TPeerIO; +begin + D := TDFE.Create; + ServiceInfoList.SaveToDF(D); + Service.SendTunnel.GetIO_Array(Arry_); + for ID_ in Arry_ do + begin + IO_ := Service.SendTunnel[ID_]; + if (IO_ <> nil) and TPeerClientUserDefineForSendTunnel_NoAuth(IO_.UserDefine).LinkOk then + IO_.SendDirectStreamCmd('UpdateServiceInfo', D); + end; + DisposeObject(D); +end; + +procedure TDTC40_Dispatch_Service.DoLinkSuccess_Event(Sender: TDTService_NoAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth); +begin + DoLinkSuccess(UserDefineIO); +end; + +procedure TDTC40_Dispatch_Service.DoUserOut_Event(Sender: TDTService_NoAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth); +begin + DoUserOut(UserDefineIO); +end; + +procedure TDTC40_Dispatch_Service.DoDelayCheckLocalServiceInfo; +var + i: Integer; + isChange_: Boolean; + info_: TDTC40_Info; +begin + DelayCheck_Working := False; + isChange_ := False; + for i := 0 to DTC40_ServicePool.Count - 1 do + begin + info_ := ServiceInfoList.FindSame(DTC40_ServicePool[i].ServiceInfo); + if info_ = nil then + begin + ServiceInfoList.Add(DTC40_ServicePool[i].ServiceInfo.Clone); + isChange_ := True; + end + else + info_.Assign(DTC40_ServicePool[i].ServiceInfo); + end; + if isChange_ then + begin + Prepare_UpdateServerInfoToAllClient; + end + else + begin + UpdateServiceStateToAllClient; + end; +end; + +constructor TDTC40_Dispatch_Service.Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); +var + i: Integer; +begin + inherited Create(PhysicsService_, ServiceTyp, Param_); + FOnServiceInfoChange := nil; + FWaiting_UpdateServerInfoToAllClient := False; + FWaiting_UpdateServerInfoToAllClient_TimeTick := 0; + DelayCheck_Working := False; + + { custom p2pVM service } + Service := TDT_P2PVM_NoAuth_Custom_Service.Create(TDTService_NoAuth, PhysicsService_.PhysicsTunnel, + ServiceInfo.ServiceTyp + 'R', ServiceInfo.p2pVM_RecvTunnel_Addr, umlIntToStr(ServiceInfo.p2pVM_RecvTunnel_Port), + ServiceInfo.ServiceTyp + 'S', ServiceInfo.p2pVM_SendTunnel_Addr, umlIntToStr(ServiceInfo.p2pVM_SendTunnel_Port) + ); + Service.DTService.OnLinkSuccess := {$IFDEF FPC}@{$ENDIF FPC}DoLinkSuccess_Event; + Service.DTService.OnUserOut := {$IFDEF FPC}@{$ENDIF FPC}DoUserOut_Event; + + Service.DTService.PublicFileDirectory := umlCombinePath(DTC40_RootPath, ServiceInfo.ServiceTyp.Text); + if not umlDirectoryExists(Service.DTService.PublicFileDirectory) then + umlCreateDirectory(Service.DTService.PublicFileDirectory); + + Service.RecvTunnel.RegisterDirectStream('UpdateServiceInfo').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_UpdateServiceInfo; + Service.RecvTunnel.RegisterDirectStream('UpdateServiceState').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_UpdateServiceState; + Service.RecvTunnel.RegisterDirectStream('IgnoreChange').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_IgnoreChange; + Service.RecvTunnel.RegisterDirectStream('RequestUpdate').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_RequestUpdate; + Service.RecvTunnel.RegisterDirectStream('RemovePhysicsNetwork').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_RemovePhysicsNetwork; + + Service.RecvTunnel.PrintParams['UpdateServiceInfo'] := False; + Service.RecvTunnel.PrintParams['UpdateServiceState'] := False; + Service.RecvTunnel.PrintParams['IgnoreChange'] := False; + Service.RecvTunnel.PrintParams['RequestUpdate'] := False; + + Service.SendTunnel.PrintParams['UpdateServiceInfo'] := False; + Service.SendTunnel.PrintParams['UpdateServiceState'] := False; + Service.SendTunnel.PrintParams['IgnoreChange'] := False; + Service.SendTunnel.PrintParams['RequestUpdate'] := False; + + { register local service. } + ServiceInfoList := TDTC40_InfoList.Create(True); + for i := 0 to DTC40_ServicePool.Count - 1 do + if ServiceInfoList.FindSame(DTC40_ServicePool[i].ServiceInfo) = nil then + ServiceInfoList.Add(DTC40_ServicePool[i].ServiceInfo.Clone); + + UpdateToGlobalDispatch; +end; + +destructor TDTC40_Dispatch_Service.Destroy; +begin + DisposeObject(Service); + DisposeObject(ServiceInfoList); + inherited Destroy; +end; + +procedure TDTC40_Dispatch_Service.Progress; +begin + inherited Progress; + Service.Progress; + + if FWaiting_UpdateServerInfoToAllClient and (GetTimeTick > FWaiting_UpdateServerInfoToAllClient_TimeTick) then + begin + FWaiting_UpdateServerInfoToAllClient := False; + FWaiting_UpdateServerInfoToAllClient_TimeTick := 0; + UpdateServerInfoToAllClient; + end; + ServiceInfo.Workload := Service.DTService.TotalLinkCount * 2; + + if not DelayCheck_Working then + begin + DelayCheck_Working := True; + DTC40PhysicsService.PhysicsTunnel.PostProgress.PostExecuteM_NP(2.0, {$IFDEF FPC}@{$ENDIF FPC}DoDelayCheckLocalServiceInfo); + end; +end; + +procedure TDTC40_Dispatch_Service.IgnoreChangeToAllClient(Hash: TMD5; Ignored: Boolean); +var + D: TDFE; + Arry_: TIO_Array; + ID_: Cardinal; + IO_: TPeerIO; +begin + D := TDFE.Create; + D.WriteMD5(Hash); + D.WriteBool(Ignored); + Service.SendTunnel.GetIO_Array(Arry_); + for ID_ in Arry_ do + begin + IO_ := Service.SendTunnel[ID_]; + if (IO_ <> nil) and TPeerClientUserDefineForSendTunnel_NoAuth(IO_.UserDefine).LinkOk then + IO_.SendDirectStreamCmd('IgnoreChange', D); + end; + DisposeObject(D); +end; + +procedure TDTC40_Dispatch_Service.UpdateServiceStateToAllClient; +var + i: Integer; + D, tmp: TDFE; + info_: TDTC40_Info; + Arry_: TIO_Array; + ID_: Cardinal; + IO_: TPeerIO; +begin + D := TDFE.Create; + for i := 0 to DTC40_ServicePool.Count - 1 do + begin + info_ := DTC40_ServicePool[i].ServiceInfo; + tmp := TDFE.Create; + tmp.WriteMD5(info_.Hash); + tmp.WriteInteger(info_.Workload); + tmp.WriteInteger(info_.MaxWorkload); + D.WriteDataFrame(tmp); + DisposeObject(tmp); + end; + + Service.SendTunnel.GetIO_Array(Arry_); + for ID_ in Arry_ do + begin + IO_ := Service.SendTunnel[ID_]; + if (IO_ <> nil) and TPeerClientUserDefineForSendTunnel_NoAuth(IO_.UserDefine).LinkOk then + IO_.SendDirectStreamCmd('UpdateServiceState', D); + end; + DisposeObject(D); +end; + +procedure TDTC40_Dispatch_Client.cmd_UpdateServiceInfo(Sender: TPeerIO; InData: TDFE); +var + i: Integer; + Arry_: TDTC40_Custom_Client_Array; + cc: TDTC40_Custom_Client; +begin + if ServiceInfoList.MergeFromDF(InData) then + begin + if Assigned(FOnServiceInfoChange) then + FOnServiceInfoChange(Self, ServiceInfoList); + + { broadcast to all service } + Arry_ := DTC40_ClientPool.GetFromClass(TDTC40_Dispatch_Client); + for cc in Arry_ do + if (cc <> Self) and (cc.Connected) then + TDTC40_Dispatch_Client(cc).Client.SendTunnel.SendDirectStreamCmd('UpdateServiceInfo', InData); + end; +end; + +procedure TDTC40_Dispatch_Client.cmd_UpdateServiceState(Sender: TPeerIO; InData: TDFE); +var + D: TDFE; + Hash: TMD5; + Workload, MaxWorkload: Integer; + info_: TDTC40_Info; + i: Integer; +begin + D := TDFE.Create; + while InData.R.NotEnd do + begin + InData.R.ReadDataFrame(D); + Hash := D.R.ReadMD5; + Workload := D.R.ReadInteger; + MaxWorkload := D.R.ReadInteger; + info_ := ServiceInfoList.FindHash(Hash); + if (info_ <> nil) then + begin + info_.Workload := Workload; + info_.MaxWorkload := MaxWorkload; + end; + end; + DisposeObject(D); + + for i := 0 to DTC40_ServicePool.Count - 1 do + begin + info_ := ServiceInfoList.FindSame(DTC40_ServicePool[i].ServiceInfo); + if info_ <> nil then + info_.Assign(DTC40_ServicePool[i].ServiceInfo); + end; +end; + +procedure TDTC40_Dispatch_Client.cmd_IgnoreChange(Sender: TPeerIO; InData: TDFE); +var + Hash: TMD5; + Ignored: Boolean; + info_: TDTC40_Info; + Arry_: TDTC40_Custom_Client_Array; + cc: TDTC40_Custom_Client; +begin + Hash := InData.R.ReadMD5; + Ignored := InData.R.ReadBool; + info_ := ServiceInfoList.FindHash(Hash); + if (info_ <> nil) then + begin + info_.Ignored := Ignored; + end; + + { broadcast to all service } + Arry_ := DTC40_ClientPool.GetFromClass(TDTC40_Dispatch_Client); + for cc in Arry_ do + if (cc <> Self) and (cc.Connected) then + TDTC40_Dispatch_Client(cc).Client.SendTunnel.SendDirectStreamCmd('IgnoreChange', InData); +end; + +procedure TDTC40_Dispatch_Client.cmd_RemovePhysicsNetwork(Sender: TPeerIO; InData: TDFE); +var + tmp: TOnRemovePhysicsNetwork; + Arry_: TDTC40_Custom_Client_Array; + cc: TDTC40_Custom_Client; +begin + tmp := TOnRemovePhysicsNetwork.Create; + tmp.PhysicsAddr := InData.R.ReadString; + tmp.PhysicsPort := InData.R.ReadWord; + SysPost.PostExecuteM_NP(2.0, tmp.DoRun); + + if C40ExistsPhysicsNetwork(tmp.PhysicsAddr, tmp.PhysicsPort) then + begin + { broadcast to all service } + Arry_ := DTC40_ClientPool.GetFromClass(TDTC40_Dispatch_Client); + for cc in Arry_ do + if (cc <> Self) and (cc.Connected) then + TDTC40_Dispatch_Client(cc).Client.SendTunnel.SendDirectStreamCmd('RemovePhysicsNetwork', InData); + end; +end; + +procedure TDTC40_Dispatch_Client.Do_DT_P2PVM_NoAuth_Custom_Client_TunnelLink(Sender: TDT_P2PVM_NoAuth_Custom_Client); +begin + PostLocalServiceInfo(True); + RequestUpdate(); + DoClientConnected(); +end; + +procedure TDTC40_Dispatch_Client.DoDelayCheckLocalServiceInfo; +var + i: Integer; +begin + DelayCheck_Working := False; + PostLocalServiceInfo(False); + UpdateLocalServiceState; + + { check and build network } + for i := 0 to ServiceInfoList.Count - 1 do + DTC40_PhysicsTunnelPool.GetOrCreatePhysicsTunnel(ServiceInfoList[i], DTC40PhysicsTunnel.DependNetworkInfoArray, DTC40PhysicsTunnel.OnEvent); +end; + +constructor TDTC40_Dispatch_Client.Create(source_: TDTC40_Info; Param_: U_String); +var + i: Integer; +begin + inherited Create(source_, Param_); + FOnServiceInfoChange := nil; + DelayCheck_Working := False; + + { custom p2pVM client } + Client := TDT_P2PVM_NoAuth_Custom_Client.Create( + TDTClient_NoAuth, DTC40PhysicsTunnel.PhysicsTunnel, + ClientInfo.ServiceTyp + 'R', ClientInfo.p2pVM_ClientRecvTunnel_Addr, umlIntToStr(ClientInfo.p2pVM_ClientRecvTunnel_Port), + ClientInfo.ServiceTyp + 'S', ClientInfo.p2pVM_ClientSendTunnel_Addr, umlIntToStr(ClientInfo.p2pVM_ClientSendTunnel_Port) + ); + Client.OnTunnelLink := {$IFDEF FPC}@{$ENDIF FPC}Do_DT_P2PVM_NoAuth_Custom_Client_TunnelLink; + + Client.RecvTunnel.RegisterDirectStream('UpdateServiceInfo').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_UpdateServiceInfo; + Client.RecvTunnel.RegisterDirectStream('UpdateServiceState').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_UpdateServiceState; + Client.RecvTunnel.RegisterDirectStream('IgnoreChange').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_IgnoreChange; + Client.RecvTunnel.RegisterDirectStream('RemovePhysicsNetwork').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_RemovePhysicsNetwork; + + Client.RecvTunnel.PrintParams['UpdateServiceInfo'] := False; + Client.RecvTunnel.PrintParams['UpdateServiceState'] := False; + Client.RecvTunnel.PrintParams['IgnoreChange'] := False; + Client.RecvTunnel.PrintParams['RequestUpdate'] := False; + + Client.SendTunnel.PrintParams['UpdateServiceInfo'] := False; + Client.SendTunnel.PrintParams['UpdateServiceState'] := False; + Client.SendTunnel.PrintParams['IgnoreChange'] := False; + Client.SendTunnel.PrintParams['RequestUpdate'] := False; + + { register local service. } + ServiceInfoList := TDTC40_InfoList.Create(True); + for i := 0 to DTC40_ServicePool.Count - 1 do + if ServiceInfoList.FindSame(DTC40_ServicePool[i].ServiceInfo) = nil then + ServiceInfoList.Add(DTC40_ServicePool[i].ServiceInfo.Clone); + + { check and build network } + for i := 0 to ServiceInfoList.Count - 1 do + DTC40_PhysicsTunnelPool.GetOrCreatePhysicsTunnel(ServiceInfoList[i], DTC40PhysicsTunnel.DependNetworkInfoArray, DTC40PhysicsTunnel.OnEvent); +end; + +destructor TDTC40_Dispatch_Client.Destroy; +begin + DisposeObject(Client); + DisposeObject(ServiceInfoList); + inherited Destroy; +end; + +procedure TDTC40_Dispatch_Client.Progress; +begin + inherited Progress; + Client.Progress; + if not DelayCheck_Working then + begin + DelayCheck_Working := True; + DTC40PhysicsTunnel.PhysicsTunnel.PostProgress.PostExecuteM_NP(2.0, {$IFDEF FPC}@{$ENDIF FPC}DoDelayCheckLocalServiceInfo); + end; +end; + +procedure TDTC40_Dispatch_Client.Connect; +begin + inherited Connect; + Client.Connect(); +end; + +function TDTC40_Dispatch_Client.Connected: Boolean; +begin + Result := Client.DTClient.LinkOk; +end; + +procedure TDTC40_Dispatch_Client.Disconnect; +begin + inherited Disconnect; + Client.Disconnect; +end; + +procedure TDTC40_Dispatch_Client.PostLocalServiceInfo(forcePost_: Boolean); +var + i: Integer; + isChange_: Boolean; + info: TDTC40_Info; + D: TDFE; +begin + isChange_ := False; + for i := 0 to DTC40_ServicePool.Count - 1 do + begin + info := ServiceInfoList.FindSame(DTC40_ServicePool[i].ServiceInfo); + if info = nil then + begin + ServiceInfoList.Add(DTC40_ServicePool[i].ServiceInfo.Clone); + isChange_ := True; + end + else + info.Assign(DTC40_ServicePool[i].ServiceInfo); + end; + + if isChange_ or forcePost_ then + begin + D := TDFE.Create; + ServiceInfoList.SaveToDF(D); + Client.SendTunnel.SendDirectStreamCmd('UpdateServiceInfo', D); + DisposeObject(D); + end; +end; + +procedure TDTC40_Dispatch_Client.RequestUpdate; +begin + Client.SendTunnel.SendDirectStreamCmd('RequestUpdate'); +end; + +procedure TDTC40_Dispatch_Client.IgnoreChangeToService(Hash: TMD5; Ignored: Boolean); +var + D: TDFE; +begin + D := TDFE.Create; + D.WriteMD5(Hash); + D.WriteBool(Ignored); + Client.SendTunnel.SendDirectStreamCmd('IgnoreChange', D); + DisposeObject(D); +end; + +procedure TDTC40_Dispatch_Client.UpdateLocalServiceState; +var + i: Integer; + D, tmp: TDFE; + info_: TDTC40_Info; +begin + D := TDFE.Create; + for i := 0 to DTC40_ServicePool.Count - 1 do + begin + info_ := DTC40_ServicePool[i].ServiceInfo; + tmp := TDFE.Create; + tmp.WriteMD5(info_.Hash); + tmp.WriteInteger(info_.Workload); + tmp.WriteInteger(info_.MaxWorkload); + D.WriteDataFrame(tmp); + DisposeObject(tmp); + end; + Client.SendTunnel.SendDirectStreamCmd('UpdateServiceState', D); + DisposeObject(D); +end; + +procedure TDTC40_Dispatch_Client.RemovePhysicsNetwork(PhysicsAddr: U_String; PhysicsPort: Word); +var + D: TDFE; +begin + D := TDFE.Create; + D.WriteString(PhysicsAddr); + D.WriteWord(PhysicsPort); + Client.SendTunnel.SendDirectStreamCmd('RemovePhysicsNetwork', D); + DisposeObject(D); +end; + +destructor TDTC40_RegistedDataList.Destroy; +begin + Clean; + inherited Destroy; +end; + +procedure TDTC40_RegistedDataList.Clean; +var + i: Integer; +begin + for i := 0 to Count - 1 do + begin + Items[i]^.ServiceTyp := ''; + Dispose(Items[i]); + end; + inherited Clear; +end; + +procedure TDTC40_RegistedDataList.Print; +var + i: Integer; + p: PDTC40_RegistedData; +begin + for i := 0 to Count - 1 do + begin + p := Items[i]; + DoStatus('Type "%s" Service "%s" Client "%s"', [p^.ServiceTyp.Text, p^.ServiceClass.ClassName, p^.ClientClass.ClassName]); + end; +end; + +procedure TDTC40_Base_NoAuth_Service.DoLinkSuccess_Event(Sender: TDTService_NoAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth); +begin + DoLinkSuccess(UserDefineIO); +end; + +procedure TDTC40_Base_NoAuth_Service.DoUserOut_Event(Sender: TDTService_NoAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth); +begin + DoUserOut(UserDefineIO); +end; + +constructor TDTC40_Base_NoAuth_Service.Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); +begin + inherited Create(PhysicsService_, ServiceTyp, Param_); + { custom p2pVM service } + Service := TDT_P2PVM_NoAuth_Custom_Service.Create(TDTService_NoAuth, PhysicsService_.PhysicsTunnel, + ServiceInfo.ServiceTyp + 'R', ServiceInfo.p2pVM_RecvTunnel_Addr, umlIntToStr(ServiceInfo.p2pVM_RecvTunnel_Port), + ServiceInfo.ServiceTyp + 'S', ServiceInfo.p2pVM_SendTunnel_Addr, umlIntToStr(ServiceInfo.p2pVM_SendTunnel_Port) + ); + Service.DTService.OnLinkSuccess := {$IFDEF FPC}@{$ENDIF FPC}DoLinkSuccess_Event; + Service.DTService.OnUserOut := {$IFDEF FPC}@{$ENDIF FPC}DoUserOut_Event; + Service.DTService.PublicFileDirectory := umlCombinePath(DTC40_RootPath, ServiceInfo.ServiceTyp.Text); + if not umlDirectoryExists(Service.DTService.PublicFileDirectory) then + umlCreateDirectory(Service.DTService.PublicFileDirectory); + DTNoAuthService := Service.DTService; + UpdateToGlobalDispatch; +end; + +destructor TDTC40_Base_NoAuth_Service.Destroy; +begin + DisposeObject(Service); + inherited Destroy; +end; + +procedure TDTC40_Base_NoAuth_Service.Progress; +begin + inherited Progress; + Service.Progress; + ServiceInfo.Workload := Service.DTService.TotalLinkCount * 2; +end; + +procedure TDTC40_Base_NoAuth_Client.Do_DT_P2PVM_NoAuth_Custom_Client_TunnelLink(Sender: TDT_P2PVM_NoAuth_Custom_Client); +begin + DoClientConnected(); +end; + +constructor TDTC40_Base_NoAuth_Client.Create(source_: TDTC40_Info; Param_: U_String); +begin + inherited Create(source_, Param_); + { custom p2pVM client } + Client := TDT_P2PVM_NoAuth_Custom_Client.Create( + TDTClient_NoAuth, DTC40PhysicsTunnel.PhysicsTunnel, + ClientInfo.ServiceTyp + 'R', ClientInfo.p2pVM_ClientRecvTunnel_Addr, umlIntToStr(ClientInfo.p2pVM_ClientRecvTunnel_Port), + ClientInfo.ServiceTyp + 'S', ClientInfo.p2pVM_ClientSendTunnel_Addr, umlIntToStr(ClientInfo.p2pVM_ClientSendTunnel_Port) + ); + Client.OnTunnelLink := {$IFDEF FPC}@{$ENDIF FPC}Do_DT_P2PVM_NoAuth_Custom_Client_TunnelLink; + DTNoAuthClient := Client.DTClient; +end; + +destructor TDTC40_Base_NoAuth_Client.Destroy; +begin + DisposeObject(Client); + inherited Destroy; +end; + +procedure TDTC40_Base_NoAuth_Client.Progress; +begin + inherited Progress; + Client.Progress; +end; + +procedure TDTC40_Base_NoAuth_Client.Connect; +begin + inherited Connect; + Client.Connect(); +end; + +function TDTC40_Base_NoAuth_Client.Connected: Boolean; +begin + Result := Client.DTClient.LinkOk; +end; + +procedure TDTC40_Base_NoAuth_Client.Disconnect; +begin + inherited Disconnect; + Client.Disconnect; +end; + +procedure TDTC40_Base_DataStoreNoAuth_Service.DoLinkSuccess_Event(Sender: TDTService_NoAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth); +begin + DoLinkSuccess(UserDefineIO); +end; + +procedure TDTC40_Base_DataStoreNoAuth_Service.DoUserOut_Event(Sender: TDTService_NoAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth); +begin + DoUserOut(UserDefineIO); +end; + +constructor TDTC40_Base_DataStoreNoAuth_Service.Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); +begin + inherited Create(PhysicsService_, ServiceTyp, Param_); + { custom p2pVM service } + Service := TDT_P2PVM_NoAuth_Custom_Service.Create(TDataStoreService_NoAuth, PhysicsService_.PhysicsTunnel, + ServiceInfo.ServiceTyp + 'R', ServiceInfo.p2pVM_RecvTunnel_Addr, umlIntToStr(ServiceInfo.p2pVM_RecvTunnel_Port), + ServiceInfo.ServiceTyp + 'S', ServiceInfo.p2pVM_SendTunnel_Addr, umlIntToStr(ServiceInfo.p2pVM_SendTunnel_Port) + ); + Service.DTService.OnLinkSuccess := {$IFDEF FPC}@{$ENDIF FPC}DoLinkSuccess_Event; + Service.DTService.OnUserOut := {$IFDEF FPC}@{$ENDIF FPC}DoUserOut_Event; + Service.DTService.PublicFileDirectory := umlCombinePath(DTC40_RootPath, ServiceInfo.ServiceTyp.Text); + if not umlDirectoryExists(Service.DTService.PublicFileDirectory) then + umlCreateDirectory(Service.DTService.PublicFileDirectory); + DTNoAuthService := Service.DTService as TDataStoreService_NoAuth; + UpdateToGlobalDispatch; +end; + +destructor TDTC40_Base_DataStoreNoAuth_Service.Destroy; +begin + DisposeObject(Service); + inherited Destroy; +end; + +procedure TDTC40_Base_DataStoreNoAuth_Service.Progress; +begin + inherited Progress; + Service.Progress; + ServiceInfo.Workload := Service.DTService.TotalLinkCount * 2; +end; + +procedure TDTC40_Base_DataStoreNoAuth_Client.Do_DT_P2PVM_DataStoreNoAuth_Custom_Client_TunnelLink(Sender: TDT_P2PVM_NoAuth_Custom_Client); +begin + DoClientConnected(); +end; + +constructor TDTC40_Base_DataStoreNoAuth_Client.Create(source_: TDTC40_Info; Param_: U_String); +begin + inherited Create(source_, Param_); + { custom p2pVM client } + Client := TDT_P2PVM_NoAuth_Custom_Client.Create( + TDataStoreClient_NoAuth, DTC40PhysicsTunnel.PhysicsTunnel, + ClientInfo.ServiceTyp + 'R', ClientInfo.p2pVM_ClientRecvTunnel_Addr, umlIntToStr(ClientInfo.p2pVM_ClientRecvTunnel_Port), + ClientInfo.ServiceTyp + 'S', ClientInfo.p2pVM_ClientSendTunnel_Addr, umlIntToStr(ClientInfo.p2pVM_ClientSendTunnel_Port) + ); + Client.OnTunnelLink := {$IFDEF FPC}@{$ENDIF FPC}Do_DT_P2PVM_DataStoreNoAuth_Custom_Client_TunnelLink; + DTNoAuthClient := Client.DTClient as TDataStoreClient_NoAuth; +end; + +destructor TDTC40_Base_DataStoreNoAuth_Client.Destroy; +begin + DisposeObject(Client); + inherited Destroy; +end; + +procedure TDTC40_Base_DataStoreNoAuth_Client.Progress; +begin + inherited Progress; + Client.Progress; +end; + +procedure TDTC40_Base_DataStoreNoAuth_Client.Connect; +begin + inherited Connect; + Client.Connect(); +end; + +function TDTC40_Base_DataStoreNoAuth_Client.Connected: Boolean; +begin + Result := Client.DTClient.LinkOk; +end; + +procedure TDTC40_Base_DataStoreNoAuth_Client.Disconnect; +begin + inherited Disconnect; + Client.Disconnect; +end; + +procedure TDTC40_Base_VirtualAuth_Service.DoUserAuth_Event(Sender: TDTService_VirtualAuth; AuthIO: TVirtualAuthIO); +begin + AuthIO.Accept; +end; + +procedure TDTC40_Base_VirtualAuth_Service.DoLinkSuccess_Event(Sender: TDTService_VirtualAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_VirtualAuth); +begin + DoLinkSuccess(UserDefineIO); +end; + +procedure TDTC40_Base_VirtualAuth_Service.DoUserOut_Event(Sender: TDTService_VirtualAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_VirtualAuth); +begin + DoUserOut(UserDefineIO); +end; + +constructor TDTC40_Base_VirtualAuth_Service.Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); +begin + inherited Create(PhysicsService_, ServiceTyp, Param_); + { custom p2pVM service } + Service := TDT_P2PVM_VirtualAuth_Custom_Service.Create(TDTService_VirtualAuth, PhysicsService_.PhysicsTunnel, + ServiceInfo.ServiceTyp + 'R', ServiceInfo.p2pVM_RecvTunnel_Addr, umlIntToStr(ServiceInfo.p2pVM_RecvTunnel_Port), + ServiceInfo.ServiceTyp + 'S', ServiceInfo.p2pVM_SendTunnel_Addr, umlIntToStr(ServiceInfo.p2pVM_SendTunnel_Port) + ); + Service.DTService.OnUserAuth := {$IFDEF FPC}@{$ENDIF FPC}DoUserAuth_Event; + Service.DTService.OnLinkSuccess := {$IFDEF FPC}@{$ENDIF FPC}DoLinkSuccess_Event; + Service.DTService.OnUserOut := {$IFDEF FPC}@{$ENDIF FPC}DoUserOut_Event; + Service.DTService.PublicFileDirectory := umlCombinePath(DTC40_RootPath, ServiceInfo.ServiceTyp.Text); + if not umlDirectoryExists(Service.DTService.PublicFileDirectory) then + umlCreateDirectory(Service.DTService.PublicFileDirectory); + DTVirtualAuthService := Service.DTService; + UpdateToGlobalDispatch; +end; + +destructor TDTC40_Base_VirtualAuth_Service.Destroy; +begin + DisposeObject(Service); + inherited Destroy; +end; + +procedure TDTC40_Base_VirtualAuth_Service.Progress; +begin + inherited Progress; + Service.Progress; + ServiceInfo.Workload := Service.DTService.TotalLinkCount * 2; +end; + +procedure TDTC40_Base_VirtualAuth_Client.Do_DT_P2PVM_VirtualAuth_Custom_Client_TunnelLink(Sender: TDT_P2PVM_VirtualAuth_Custom_Client); +begin + DoClientConnected(); +end; + +constructor TDTC40_Base_VirtualAuth_Client.Create(source_: TDTC40_Info; Param_: U_String); +begin + inherited Create(source_, Param_); + { custom p2pVM client } + Client := TDT_P2PVM_VirtualAuth_Custom_Client.Create( + TDTClient_VirtualAuth, DTC40PhysicsTunnel.PhysicsTunnel, + ClientInfo.ServiceTyp + 'R', ClientInfo.p2pVM_ClientRecvTunnel_Addr, umlIntToStr(ClientInfo.p2pVM_ClientRecvTunnel_Port), + ClientInfo.ServiceTyp + 'S', ClientInfo.p2pVM_ClientSendTunnel_Addr, umlIntToStr(ClientInfo.p2pVM_ClientSendTunnel_Port) + ); + Client.OnTunnelLink := {$IFDEF FPC}@{$ENDIF FPC}Do_DT_P2PVM_VirtualAuth_Custom_Client_TunnelLink; + DTVirtualAuthClient := Client.DTClient; + UserName := umlMD5ToStr(ClientInfo.Hash); + Password := UserName; +end; + +destructor TDTC40_Base_VirtualAuth_Client.Destroy; +begin + DisposeObject(Client); + inherited Destroy; +end; + +procedure TDTC40_Base_VirtualAuth_Client.Progress; +begin + inherited Progress; + Client.Progress; +end; + +procedure TDTC40_Base_VirtualAuth_Client.Connect; +begin + inherited Connect; + Client.Connect(UserName, Password); +end; + +function TDTC40_Base_VirtualAuth_Client.Connected: Boolean; +begin + Result := Client.DTClient.LinkOk; +end; + +procedure TDTC40_Base_VirtualAuth_Client.Disconnect; +begin + inherited Disconnect; + Client.Disconnect; +end; + +procedure TDTC40_Base_DataStoreVirtualAuth_Service.DoUserAuth_Event(Sender: TDTService_VirtualAuth; AuthIO: TVirtualAuthIO); +begin + AuthIO.Accept; +end; + +procedure TDTC40_Base_DataStoreVirtualAuth_Service.DoLinkSuccess_Event(Sender: TDTService_VirtualAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_VirtualAuth); +begin + DoLinkSuccess(UserDefineIO); +end; + +procedure TDTC40_Base_DataStoreVirtualAuth_Service.DoUserOut_Event(Sender: TDTService_VirtualAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_VirtualAuth); +begin + DoUserOut(UserDefineIO); +end; + +constructor TDTC40_Base_DataStoreVirtualAuth_Service.Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); +begin + inherited Create(PhysicsService_, ServiceTyp, Param_); + { custom p2pVM service } + Service := TDT_P2PVM_VirtualAuth_Custom_Service.Create(TDataStoreService_VirtualAuth, PhysicsService_.PhysicsTunnel, + ServiceInfo.ServiceTyp + 'R', ServiceInfo.p2pVM_RecvTunnel_Addr, umlIntToStr(ServiceInfo.p2pVM_RecvTunnel_Port), + ServiceInfo.ServiceTyp + 'S', ServiceInfo.p2pVM_SendTunnel_Addr, umlIntToStr(ServiceInfo.p2pVM_SendTunnel_Port) + ); + Service.DTService.OnUserAuth := {$IFDEF FPC}@{$ENDIF FPC}DoUserAuth_Event; + Service.DTService.OnLinkSuccess := {$IFDEF FPC}@{$ENDIF FPC}DoLinkSuccess_Event; + Service.DTService.OnUserOut := {$IFDEF FPC}@{$ENDIF FPC}DoUserOut_Event; + Service.DTService.PublicFileDirectory := umlCombinePath(DTC40_RootPath, ServiceInfo.ServiceTyp.Text); + if not umlDirectoryExists(Service.DTService.PublicFileDirectory) then + umlCreateDirectory(Service.DTService.PublicFileDirectory); + DTVirtualAuthService := Service.DTService as TDataStoreService_VirtualAuth; + UpdateToGlobalDispatch; +end; + +destructor TDTC40_Base_DataStoreVirtualAuth_Service.Destroy; +begin + DisposeObject(Service); + inherited Destroy; +end; + +procedure TDTC40_Base_DataStoreVirtualAuth_Service.Progress; +begin + inherited Progress; + Service.Progress; + ServiceInfo.Workload := Service.DTService.TotalLinkCount * 2; +end; + +procedure TDTC40_Base_DataStoreVirtualAuth_Client.Do_DT_P2PVM_VirtualAuth_Custom_Client_TunnelLink(Sender: TDT_P2PVM_VirtualAuth_Custom_Client); +begin + DoClientConnected(); +end; + +constructor TDTC40_Base_DataStoreVirtualAuth_Client.Create(source_: TDTC40_Info; Param_: U_String); +begin + inherited Create(source_, Param_); + { custom p2pVM client } + Client := TDT_P2PVM_VirtualAuth_Custom_Client.Create( + TDataStoreClient_VirtualAuth, DTC40PhysicsTunnel.PhysicsTunnel, + ClientInfo.ServiceTyp + 'R', ClientInfo.p2pVM_ClientRecvTunnel_Addr, umlIntToStr(ClientInfo.p2pVM_ClientRecvTunnel_Port), + ClientInfo.ServiceTyp + 'S', ClientInfo.p2pVM_ClientSendTunnel_Addr, umlIntToStr(ClientInfo.p2pVM_ClientSendTunnel_Port) + ); + Client.OnTunnelLink := {$IFDEF FPC}@{$ENDIF FPC}Do_DT_P2PVM_VirtualAuth_Custom_Client_TunnelLink; + DTVirtualAuthClient := Client.DTClient as TDataStoreClient_VirtualAuth; + UserName := umlMD5ToStr(ClientInfo.Hash); + Password := UserName; +end; + +destructor TDTC40_Base_DataStoreVirtualAuth_Client.Destroy; +begin + DisposeObject(Client); + inherited Destroy; +end; + +procedure TDTC40_Base_DataStoreVirtualAuth_Client.Progress; +begin + inherited Progress; + Client.Progress; +end; + +procedure TDTC40_Base_DataStoreVirtualAuth_Client.Connect; +begin + inherited Connect; + Client.Connect(UserName, Password); +end; + +function TDTC40_Base_DataStoreVirtualAuth_Client.Connected: Boolean; +begin + Result := Client.DTClient.LinkOk; +end; + +procedure TDTC40_Base_DataStoreVirtualAuth_Client.Disconnect; +begin + inherited Disconnect; + Client.Disconnect; +end; + +procedure TDTC40_Base_Service.DoLinkSuccess_Event(Sender: TDTService; UserDefineIO: TPeerClientUserDefineForRecvTunnel); +begin + DoLinkSuccess(UserDefineIO); +end; + +procedure TDTC40_Base_Service.DoUserOut_Event(Sender: TDTService; UserDefineIO: TPeerClientUserDefineForRecvTunnel); +begin + DoUserOut(UserDefineIO); +end; + +constructor TDTC40_Base_Service.Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); +begin + inherited Create(PhysicsService_, ServiceTyp, Param_); + { custom p2pVM service } + Service := TDT_P2PVM_Custom_Service.Create(TDTService, PhysicsService_.PhysicsTunnel, + ServiceInfo.ServiceTyp + 'R', ServiceInfo.p2pVM_RecvTunnel_Addr, umlIntToStr(ServiceInfo.p2pVM_RecvTunnel_Port), + ServiceInfo.ServiceTyp + 'S', ServiceInfo.p2pVM_SendTunnel_Addr, umlIntToStr(ServiceInfo.p2pVM_SendTunnel_Port) + ); + Service.DTService.OnLinkSuccess := {$IFDEF FPC}@{$ENDIF FPC}DoLinkSuccess_Event; + Service.DTService.OnUserOut := {$IFDEF FPC}@{$ENDIF FPC}DoUserOut_Event; + Service.DTService.AllowRegisterNewUser := True; + Service.DTService.AllowSaveUserInfo := True; + Service.DTService.PublicPath := umlCombinePath(DTC40_RootPath, ServiceInfo.ServiceTyp.Text); + Service.DTService.RootPath := Service.DTService.PublicPath; + if not umlDirectoryExists(Service.DTService.PublicPath) then + umlCreateDirectory(Service.DTService.PublicPath); + DTService := Service.DTService; + UpdateToGlobalDispatch; +end; + +destructor TDTC40_Base_Service.Destroy; +begin + DisposeObject(Service); + inherited Destroy; +end; + +procedure TDTC40_Base_Service.SafeCheck; +begin + inherited SafeCheck; + Service.DTService.SaveUserDB; +end; + +procedure TDTC40_Base_Service.Progress; +begin + inherited Progress; + Service.Progress; + ServiceInfo.Workload := Service.DTService.TotalLinkCount * 2; +end; + +procedure TDTC40_Base_Client.Do_DT_P2PVM_Custom_Client_TunnelLink(Sender: TDT_P2PVM_Custom_Client); +begin + DoClientConnected(); +end; + +constructor TDTC40_Base_Client.Create(source_: TDTC40_Info; Param_: U_String); +begin + inherited Create(source_, Param_); + { custom p2pVM client } + Client := TDT_P2PVM_Custom_Client.Create( + TDTClient, DTC40PhysicsTunnel.PhysicsTunnel, + ClientInfo.ServiceTyp + 'R', ClientInfo.p2pVM_ClientRecvTunnel_Addr, umlIntToStr(ClientInfo.p2pVM_ClientRecvTunnel_Port), + ClientInfo.ServiceTyp + 'S', ClientInfo.p2pVM_ClientSendTunnel_Addr, umlIntToStr(ClientInfo.p2pVM_ClientSendTunnel_Port) + ); + Client.OnTunnelLink := {$IFDEF FPC}@{$ENDIF FPC}Do_DT_P2PVM_Custom_Client_TunnelLink; + DTClient := Client.DTClient; + UserName := umlMD5ToStr(ClientInfo.Hash); + Password := UserName; +end; + +destructor TDTC40_Base_Client.Destroy; +begin + DisposeObject(Client); + inherited Destroy; +end; + +procedure TDTC40_Base_Client.Progress; +begin + inherited Progress; + Client.Progress; +end; + +procedure TDTC40_Base_Client.Connect; +begin + inherited Connect; + Client.Connect(UserName, Password); +end; + +function TDTC40_Base_Client.Connected: Boolean; +begin + Result := Client.DTClient.LinkOk; +end; + +procedure TDTC40_Base_Client.Disconnect; +begin + inherited Disconnect; + Client.Disconnect; +end; + +procedure TDTC40_Base_DataStore_Service.DoLinkSuccess_Event(Sender: TDTService; UserDefineIO: TPeerClientUserDefineForRecvTunnel); +begin + DoLinkSuccess(UserDefineIO); +end; + +procedure TDTC40_Base_DataStore_Service.DoUserOut_Event(Sender: TDTService; UserDefineIO: TPeerClientUserDefineForRecvTunnel); +begin + DoUserOut(UserDefineIO); +end; + +constructor TDTC40_Base_DataStore_Service.Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); +begin + inherited Create(PhysicsService_, ServiceTyp, Param_); + { custom p2pVM service } + Service := TDT_P2PVM_Custom_Service.Create(TDataStoreService, PhysicsService_.PhysicsTunnel, + ServiceInfo.ServiceTyp + 'R', ServiceInfo.p2pVM_RecvTunnel_Addr, umlIntToStr(ServiceInfo.p2pVM_RecvTunnel_Port), + ServiceInfo.ServiceTyp + 'S', ServiceInfo.p2pVM_SendTunnel_Addr, umlIntToStr(ServiceInfo.p2pVM_SendTunnel_Port) + ); + Service.DTService.OnLinkSuccess := {$IFDEF FPC}@{$ENDIF FPC}DoLinkSuccess_Event; + Service.DTService.OnUserOut := {$IFDEF FPC}@{$ENDIF FPC}DoUserOut_Event; + Service.DTService.AllowRegisterNewUser := True; + Service.DTService.AllowSaveUserInfo := True; + Service.DTService.PublicPath := umlCombinePath(DTC40_RootPath, ServiceInfo.ServiceTyp.Text); + Service.DTService.RootPath := Service.DTService.PublicPath; + if not umlDirectoryExists(Service.DTService.PublicPath) then + umlCreateDirectory(Service.DTService.PublicPath); + + DTService := Service.DTService as TDataStoreService; + UpdateToGlobalDispatch; +end; + +destructor TDTC40_Base_DataStore_Service.Destroy; +begin + DisposeObject(Service); + inherited Destroy; +end; + +procedure TDTC40_Base_DataStore_Service.SafeCheck; +begin + inherited SafeCheck; + Service.DTService.SaveUserDB; +end; + +procedure TDTC40_Base_DataStore_Service.Progress; +begin + inherited Progress; + Service.Progress; + ServiceInfo.Workload := Service.DTService.TotalLinkCount * 2; +end; + +procedure TDTC40_Base_DataStore_Client.Do_DT_P2PVM_Custom_Client_TunnelLink(Sender: TDT_P2PVM_Custom_Client); +begin + DoClientConnected(); +end; + +constructor TDTC40_Base_DataStore_Client.Create(source_: TDTC40_Info; Param_: U_String); +begin + inherited Create(source_, Param_); + { custom p2pVM client } + Client := TDT_P2PVM_Custom_Client.Create( + TDataStoreClient, DTC40PhysicsTunnel.PhysicsTunnel, + ClientInfo.ServiceTyp + 'R', ClientInfo.p2pVM_ClientRecvTunnel_Addr, umlIntToStr(ClientInfo.p2pVM_ClientRecvTunnel_Port), + ClientInfo.ServiceTyp + 'S', ClientInfo.p2pVM_ClientSendTunnel_Addr, umlIntToStr(ClientInfo.p2pVM_ClientSendTunnel_Port) + ); + Client.OnTunnelLink := {$IFDEF FPC}@{$ENDIF FPC}Do_DT_P2PVM_Custom_Client_TunnelLink; + DTClient := Client.DTClient as TDataStoreClient; + UserName := umlMD5ToStr(ClientInfo.Hash); + Password := UserName; +end; + +destructor TDTC40_Base_DataStore_Client.Destroy; +begin + DisposeObject(Client); + inherited Destroy; +end; + +procedure TDTC40_Base_DataStore_Client.Progress; +begin + inherited Progress; + Client.Progress; +end; + +procedure TDTC40_Base_DataStore_Client.Connect; +begin + inherited Connect; + Client.Connect(UserName, Password); +end; + +function TDTC40_Base_DataStore_Client.Connected: Boolean; +begin + Result := Client.DTClient.LinkOk; +end; + +procedure TDTC40_Base_DataStore_Client.Disconnect; +begin + inherited Disconnect; + Client.Disconnect; +end; + +initialization + +// init +ProgressBackgroundProc := {$IFDEF FPC}@{$ENDIF FPC}C40Progress; + +DTC40_QuietMode := False; +DTC40_SafeCheckTime := 1000 * 60 * 10; +DTC40_PhysicsServiceTimeout := 1000 * 60; +DTC40_PhysicsTunnelTimeout := 15 * 1000; +DTC40_KillDeadPhysicsConnectionTimeout := 1000 * 60; +DTC40_KillIDCFaultTimeout := 1000 * 60 * 60; + +{$IFDEF FPC} +DTC40_RootPath := umlCurrentPath; +{$ELSE FPC} +DTC40_RootPath := TPath.GetLibraryPath; +{$ENDIF FPC} + +DTC40_PhysicsClientClass := PhysicsIO.TPhysicsClient; +DTC40_Registed := TDTC40_RegistedDataList.Create; +DTC40_PhysicsServicePool := TDTC40_PhysicsServicePool.Create; +DTC40_ServicePool := TDTC40_Custom_ServicePool.Create; +DTC40_PhysicsTunnelPool := TDTC40_PhysicsTunnelPool.Create; +DTC40_ClientPool := TDTC40_Custom_ClientPool.Create; + +// build-in registration +RegisterC40('DP', TDTC40_Dispatch_Service, TDTC40_Dispatch_Client); +RegisterC40('NA', TDTC40_Base_NoAuth_Service, TDTC40_Base_NoAuth_Client); +RegisterC40('DNA', TDTC40_Base_DataStoreNoAuth_Service, TDTC40_Base_DataStoreNoAuth_Client); +RegisterC40('VA', TDTC40_Base_VirtualAuth_Service, TDTC40_Base_VirtualAuth_Client); +RegisterC40('DVA', TDTC40_Base_DataStoreVirtualAuth_Service, TDTC40_Base_DataStoreVirtualAuth_Client); +RegisterC40('D', TDTC40_Base_Service, TDTC40_Base_Client); +RegisterC40('DD', TDTC40_Base_DataStore_Service, TDTC40_Base_DataStore_Client); + +finalization + +C40Clean; + +DisposeObject(DTC40_PhysicsServicePool); +DisposeObject(DTC40_ServicePool); +DisposeObject(DTC40_PhysicsTunnelPool); +DisposeObject(DTC40_ClientPool); +DisposeObject(DTC40_Registed); + +end. diff --git a/Source/DTC40_FS.pas b/Source/DTC40_FS.pas new file mode 100644 index 00000000..44dace83 --- /dev/null +++ b/Source/DTC40_FS.pas @@ -0,0 +1,531 @@ +{ ****************************************************************************** } +{ * cloud 4.0 File System * } +{ ****************************************************************************** } +{ * https://zpascal.net * } +{ * https://github.com/PassByYou888/zAI * } +{ * https://github.com/PassByYou888/ZServer4D * } +{ * https://github.com/PassByYou888/PascalString * } +{ * https://github.com/PassByYou888/zRasterization * } +{ * https://github.com/PassByYou888/CoreCipher * } +{ * https://github.com/PassByYou888/zSound * } +{ * https://github.com/PassByYou888/zChinese * } +{ * https://github.com/PassByYou888/zExpression * } +{ * https://github.com/PassByYou888/zGameWare * } +{ * https://github.com/PassByYou888/zAnalysis * } +{ * https://github.com/PassByYou888/FFMPEG-Header * } +{ * https://github.com/PassByYou888/zTranslate * } +{ * https://github.com/PassByYou888/InfiniteIoT * } +{ * https://github.com/PassByYou888/FastMD5 * } +{ ****************************************************************************** } +unit DTC40_FS; + +{$INCLUDE zDefine.inc} + +interface + +uses +{$IFDEF FPC} + FPCGenericStructlist, +{$ENDIF FPC} + CoreClasses, PascalStrings, DoStatusIO, UnicodeMixedLib, ListEngine, + Geometry2DUnit, DataFrameEngine, ZJson, + NotifyObjectBase, CoreCipher, MemoryStream64, + ObjectData, ObjectDataManager, ItemStream, + CommunicationFramework, PhysicsIO, CommunicationFrameworkDoubleTunnelIO_NoAuth, DTC40; + +type + TDTC40_FS_Client = class; + + TDTC40_FS_Service = class(TDTC40_Base_NoAuth_Service) + protected + // init build-in data + IsLoading: Boolean; + procedure DoLoading(); + protected + // command + procedure cmd_FS_PostFile(Sender: TPeerIO; InData: PByte; DataSize: NativeInt); + procedure cmd_FS_GetFile(Sender: TPeerIO; InData: TDFE); + public + DTC40_FS_FileName: U_String; + FileNameHash: THashVariantList; + FileMD5Hash: THashVariantList; + StoreEng: TObjectDataManager; + constructor Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); override; + destructor Destroy; override; + procedure SafeCheck; override; + end; + + TON_FS_PostFile_DoneC = procedure(Sender: TDTC40_FS_Client; Token: U_String); + TON_FS_PostFile_DoneM = procedure(Sender: TDTC40_FS_Client; Token: U_String) of object; +{$IFDEF FPC} + TON_FS_PostFile_DoneP = procedure(Sender: TDTC40_FS_Client; Token: U_String) is nested; +{$ELSE FPC} + TON_FS_PostFile_DoneP = reference to procedure(Sender: TDTC40_FS_Client; Token: U_String); +{$ENDIF FPC} + + TFS_Temp_Post_File_Tunnel = class + public + p2pClient: TCommunicationFrameworkWithP2PVM_Client; + Client: TDTC40_FS_Client; + Token: U_String; + stream: TMS64; + OnResultC: TON_FS_PostFile_DoneC; + OnResultM: TON_FS_PostFile_DoneM; + OnResultP: TON_FS_PostFile_DoneP; + + constructor Create; + destructor Destroy; override; + procedure DoIDLE_Trace_Event(data_: TCoreClassObject); + procedure DoP2PVM_CloneConnectAndPostFile(Sender: TCommunicationFrameworkWithP2PVM_Client); + end; + + TON_FS_GetFile_DoneC = procedure(Sender: TDTC40_FS_Client; stream: TMS64; Token: U_String; Successed: Boolean); + TON_FS_GetFile_DoneM = procedure(Sender: TDTC40_FS_Client; stream: TMS64; Token: U_String; Successed: Boolean) of object; +{$IFDEF FPC} + TON_FS_GetFile_DoneP = procedure(Sender: TDTC40_FS_Client; stream: TMS64; Token: U_String; Successed: Boolean) is nested; +{$ELSE FPC} + TON_FS_GetFile_DoneP = reference to procedure(Sender: TDTC40_FS_Client; stream: TMS64; Token: U_String; Successed: Boolean); +{$ENDIF FPC} + + TFS_Temp_Get_File_Tunnel = class + public + p2pClient: TCommunicationFrameworkWithP2PVM_Client; + Client: TDTC40_FS_Client; + Token: U_String; + Token_is_MD5: Boolean; + OnResultC: TON_FS_GetFile_DoneC; + OnResultM: TON_FS_GetFile_DoneM; + OnResultP: TON_FS_GetFile_DoneP; + + constructor Create; + destructor Destroy; override; + procedure cmd_Save(Sender: TPeerIO; InData: PByte; DataSize: NativeInt); + procedure cmd_Error(Sender: TPeerIO; InData: SystemString); + procedure DoP2PVM_CloneConnectAndGetFile(Sender: TCommunicationFrameworkWithP2PVM_Client); + end; + + TDTC40_FS_Client = class(TDTC40_Base_NoAuth_Client) + public + constructor Create(source_: TDTC40_Info; Param_: U_String); override; + destructor Destroy; override; + + // post file + procedure FS_PostFile(Token: U_String; stream: TCoreClassStream; doneFree: Boolean); + procedure FS_PostFile_C(Token: U_String; stream: TCoreClassStream; doneFree: Boolean; OnResult: TON_FS_PostFile_DoneC); + procedure FS_PostFile_M(Token: U_String; stream: TCoreClassStream; doneFree: Boolean; OnResult: TON_FS_PostFile_DoneM); + procedure FS_PostFile_P(Token: U_String; stream: TCoreClassStream; doneFree: Boolean; OnResult: TON_FS_PostFile_DoneP); + + // get file + procedure FS_GetFile_C(Token: U_String; Token_is_MD5: Boolean; OnResult: TON_FS_GetFile_DoneC); + procedure FS_GetFile_M(Token: U_String; Token_is_MD5: Boolean; OnResult: TON_FS_GetFile_DoneM); + procedure FS_GetFile_P(Token: U_String; Token_is_MD5: Boolean; OnResult: TON_FS_GetFile_DoneP); + end; + +implementation + +procedure TDTC40_FS_Service.DoLoading; +var + sr: TItemSearch; + M64: TMS64; +begin + IsLoading := True; + + DoStatus('extract FileSystem hash.'); + try + if StoreEng.ItemFastFindFirst(StoreEng.RootField, '*', sr) then + begin + M64 := TMS64.CustomCreate(8 * 1024 * 1024); + repeat + StoreEng.ItemReadToStream(sr.HeaderPOS, M64); + FileNameHash.Add(M64.ReadString, sr.HeaderPOS); + FileMD5Hash.Add(umlMD5String(M64.PosAsPtr, M64.Size - M64.Size), sr.HeaderPOS); + M64.Clear; + until not StoreEng.ItemFastFindNext(sr); + DisposeObject(M64); + end; + DoStatus('extract FileSystem Done.'); + except + end; + + IsLoading := False; +end; + +procedure TDTC40_FS_Service.cmd_FS_PostFile(Sender: TPeerIO; InData: PByte; DataSize: NativeInt); +var + M64: TMS64; + Token: U_String; + md5_: U_String; + itmHnd: TItemHandle; +begin + M64 := TMS64.Create; + M64.Mapping(InData, DataSize); + Token := M64.ReadString; + md5_ := umlMD5String(M64.PosAsPtr, M64.Size - M64.Position); + Sender.Print('post file md5 %s', [md5_.Text]); + DisposeObject(M64); + + try + StoreEng.ItemFastCreate(StoreEng.RootField, Token, '', itmHnd); + StoreEng.ItemWrite(itmHnd, DataSize, InData^); + FileNameHash.Add(Token, itmHnd.Item.RHeader.CurrentHeader); + FileMD5Hash.Add(md5_, itmHnd.Item.RHeader.CurrentHeader); + StoreEng.ItemClose(itmHnd); + except + end; +end; + +procedure TDTC40_FS_Service.cmd_FS_GetFile(Sender: TPeerIO; InData: TDFE); +var + Token: U_String; + Token_is_MD5: Boolean; + itmPos: Int64; + IO_ID: Cardinal; + IO_: TPeerIO; + itmStream: TItemStream; + M64: TMem64; +begin + Token := InData.R.ReadString; + Token_is_MD5 := InData.R.ReadBool; + IO_ID := InData.R.ReadCardinal; + + IO_ := DTNoAuthService.RecvTunnel[IO_ID]; + if IO_ = nil then + exit; + + if Token_is_MD5 then + itmPos := FileMD5Hash.GetDefaultValue(Token, 0) + else + itmPos := FileNameHash.GetDefaultValue(Token, 0); + + if itmPos = 0 then + begin + IO_.SendDirectConsoleCmd('Error', PFormat('no found file "%s"', [Token.Text])); + exit; + end; + + itmStream := TItemStream.Create(StoreEng, itmPos); + M64 := TMem64.Create; + M64.Size := itmStream.Size; + M64.CopyFrom(itmStream, itmStream.Size); + DisposeObject(itmStream); + if M64.Size > 0 then + begin + IO_.SendCompleteBuffer('Save', M64.Memory, M64.Size, True); + M64.DiscardMemory; + end + else + begin + DisposeObject(M64); + IO_.SendDirectConsoleCmd('Error', PFormat('warning: empty file "%s"', [Token.Text])); + end; +end; + +constructor TDTC40_FS_Service.Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); +begin + inherited Create(PhysicsService_, ServiceTyp, Param_); + DTNoAuthService.RecvTunnel.CompleteBufferCompressed := False; + // max complete buffer 128M + DTNoAuthService.RecvTunnel.MaxCompleteBufferSize := 128 * 1024 * 1024; + DTNoAuthService.RecvTunnel.RegisterCompleteBuffer('FS_PostFile').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_FS_PostFile; + DTNoAuthService.RecvTunnel.RegisterDirectStream('FS_GetFile').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_FS_GetFile; + ServiceInfo.OnlyInstance := True; + UpdateToGlobalDispatch; + + FileNameHash := THashVariantList.CustomCreate(1024 * 1024); + FileMD5Hash := THashVariantList.CustomCreate(1024 * 1024); + + DTC40_FS_FileName := umlCombineFileName(DTNoAuthService.PublicFileDirectory, PFormat('DTC40_%s.OX', [ServiceInfo.ServiceTyp.Text])); + if umlFileExists(DTC40_FS_FileName) then + begin + StoreEng := ObjectDataMarshal.Open(DTC40_FS_FileName, False); + DoStatus('Open DB file: %s', [DTC40_FS_FileName.Text]); + end + else + begin + StoreEng := ObjectDataMarshal.NewDB(200, DTC40_FS_FileName, False); + DoStatus('create new DB file: %s', [DTC40_FS_FileName.Text]); + end; + StoreEng.OverWriteItem := False; + DoLoading; +end; + +destructor TDTC40_FS_Service.Destroy; +begin + DisposeObject(FileNameHash); + DisposeObject(FileMD5Hash); + inherited Destroy; +end; + +procedure TDTC40_FS_Service.SafeCheck; +begin + inherited SafeCheck; + DoStatus('Update FileSystem IO.'); + StoreEng.UpdateIO; + DoStatus('Update FileSystem IO Done.'); +end; + +constructor TFS_Temp_Post_File_Tunnel.Create; +begin + inherited Create; + p2pClient := nil; + Client := nil; + Token := ''; + stream := TMS64.Create; + OnResultC := nil; + OnResultM := nil; + OnResultP := nil; +end; + +destructor TFS_Temp_Post_File_Tunnel.Destroy; +begin + DisposeObject(stream); + inherited Destroy; +end; + +procedure TFS_Temp_Post_File_Tunnel.DoIDLE_Trace_Event(data_: TCoreClassObject); +begin + try + if Assigned(OnResultC) then + OnResultC(Client, Token); + if Assigned(OnResultM) then + OnResultM(Client, Token); + if Assigned(OnResultP) then + OnResultP(Client, Token); + except + end; + DelayFreeObject(1.0, data_, Self); +end; + +procedure TFS_Temp_Post_File_Tunnel.DoP2PVM_CloneConnectAndPostFile(Sender: TCommunicationFrameworkWithP2PVM_Client); +begin + p2pClient := Sender; + Sender.SendCompleteBuffer('FS_PostFile', stream.Memory, stream.Size, True); + stream.DiscardMemory; + Sender.IO_IDLE_TraceM(Sender, {$IFDEF FPC}@{$ENDIF FPC}DoIDLE_Trace_Event); +end; + +constructor TFS_Temp_Get_File_Tunnel.Create; +begin + inherited Create; + p2pClient := nil; + Client := nil; + Token := ''; + Token_is_MD5 := False; + OnResultC := nil; + OnResultM := nil; + OnResultP := nil; +end; + +destructor TFS_Temp_Get_File_Tunnel.Destroy; +begin + inherited Destroy; +end; + +procedure TFS_Temp_Get_File_Tunnel.cmd_Save(Sender: TPeerIO; InData: PByte; DataSize: NativeInt); +var + tmp1, tmp2: TMS64; + tmp_token_: U_String; +begin + tmp1 := TMS64.Create; + tmp1.Mapping(InData, DataSize); + tmp_token_ := tmp1.ReadString; + tmp2 := TMS64.Create; + tmp2.Mapping(tmp1.PosAsPtr, tmp1.Size - tmp1.Position); + + Sender.Print('get file md5 %s', [umlStreamMD5String(tmp2).Text]); + + try + if Assigned(OnResultC) then + OnResultC(Client, tmp2, tmp_token_, True); + if Assigned(OnResultM) then + OnResultM(Client, tmp2, tmp_token_, True); + if Assigned(OnResultP) then + OnResultP(Client, tmp2, tmp_token_, True); + except + end; + + DisposeObject(tmp1); + DisposeObject(tmp2); + + p2pClient.IO_IDLE_Trace_And_FreeSelf(Self); +end; + +procedure TFS_Temp_Get_File_Tunnel.cmd_Error(Sender: TPeerIO; InData: SystemString); +begin + Sender.PrintError(InData); + try + if Assigned(OnResultC) then + OnResultC(Client, nil, Token, True); + if Assigned(OnResultM) then + OnResultM(Client, nil, Token, True); + if Assigned(OnResultP) then + OnResultP(Client, nil, Token, True); + except + end; + + p2pClient.IO_IDLE_Trace_And_FreeSelf(Self); +end; + +procedure TFS_Temp_Get_File_Tunnel.DoP2PVM_CloneConnectAndGetFile(Sender: TCommunicationFrameworkWithP2PVM_Client); +var + d: TDFE; +begin + p2pClient := Sender; + Sender.RegisterCompleteBuffer('Save').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_Save; + Sender.RegisterDirectConsole('Error').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_Error; + d := TDFE.Create; + d.WriteString(Token); + d.WriteBool(Token_is_MD5); + d.WriteCardinal(Sender.ClientIO.ID); + Client.DTNoAuthClient.SendTunnel.SendDirectStreamCmd('FS_GetFile', d); + DisposeObject(d); +end; + +constructor TDTC40_FS_Client.Create(source_: TDTC40_Info; Param_: U_String); +begin + inherited Create(source_, Param_); +end; + +destructor TDTC40_FS_Client.Destroy; +begin + inherited Destroy; +end; + +procedure TDTC40_FS_Client.FS_PostFile(Token: U_String; stream: TCoreClassStream; doneFree: Boolean); +var + tmp: TFS_Temp_Post_File_Tunnel; +begin + if stream.Size = 0 then + begin + if doneFree then + DisposeObject(stream); + exit; + end; + tmp := TFS_Temp_Post_File_Tunnel.Create; + tmp.Client := Self; + tmp.Token := Token; + tmp.stream.WriteString(Token); + stream.Position := 0; + tmp.stream.CopyFrom(stream, stream.Size); + Client.SendTunnel.CloneConnectM({$IFDEF FPC}@{$ENDIF FPC}tmp.DoP2PVM_CloneConnectAndPostFile); + if doneFree then + DisposeObject(stream); +end; + +procedure TDTC40_FS_Client.FS_PostFile_C(Token: U_String; stream: TCoreClassStream; doneFree: Boolean; OnResult: TON_FS_PostFile_DoneC); +var + tmp: TFS_Temp_Post_File_Tunnel; +begin + if stream.Size = 0 then + begin + if doneFree then + DisposeObject(stream); + exit; + end; + tmp := TFS_Temp_Post_File_Tunnel.Create; + tmp.Client := Self; + tmp.Token := Token; + tmp.OnResultC := OnResult; + tmp.stream.WriteString(Token); + stream.Position := 0; + tmp.stream.CopyFrom(stream, stream.Size); + Client.SendTunnel.CloneConnectM({$IFDEF FPC}@{$ENDIF FPC}tmp.DoP2PVM_CloneConnectAndPostFile); + if doneFree then + DisposeObject(stream); +end; + +procedure TDTC40_FS_Client.FS_PostFile_M(Token: U_String; stream: TCoreClassStream; doneFree: Boolean; OnResult: TON_FS_PostFile_DoneM); +var + tmp: TFS_Temp_Post_File_Tunnel; +begin + if stream.Size = 0 then + begin + if doneFree then + DisposeObject(stream); + exit; + end; + tmp := TFS_Temp_Post_File_Tunnel.Create; + tmp.Client := Self; + tmp.Token := Token; + tmp.OnResultM := OnResult; + tmp.stream.WriteString(Token); + stream.Position := 0; + tmp.stream.CopyFrom(stream, stream.Size); + Client.SendTunnel.CloneConnectM({$IFDEF FPC}@{$ENDIF FPC}tmp.DoP2PVM_CloneConnectAndPostFile); + if doneFree then + DisposeObject(stream); +end; + +procedure TDTC40_FS_Client.FS_PostFile_P(Token: U_String; stream: TCoreClassStream; doneFree: Boolean; OnResult: TON_FS_PostFile_DoneP); +var + tmp: TFS_Temp_Post_File_Tunnel; +begin + if stream.Size = 0 then + begin + if doneFree then + DisposeObject(stream); + exit; + end; + tmp := TFS_Temp_Post_File_Tunnel.Create; + tmp.Client := Self; + tmp.Token := Token; + tmp.OnResultP := OnResult; + tmp.stream.WriteString(Token); + stream.Position := 0; + tmp.stream.CopyFrom(stream, stream.Size); + Client.SendTunnel.CloneConnectM({$IFDEF FPC}@{$ENDIF FPC}tmp.DoP2PVM_CloneConnectAndPostFile); + if doneFree then + DisposeObject(stream); +end; + +procedure TDTC40_FS_Client.FS_GetFile_C(Token: U_String; Token_is_MD5: Boolean; OnResult: TON_FS_GetFile_DoneC); +var + tmp: TFS_Temp_Get_File_Tunnel; +begin + tmp := TFS_Temp_Get_File_Tunnel.Create; + tmp.Client := Self; + tmp.Token := Token; + tmp.Token_is_MD5 := Token_is_MD5; + tmp.OnResultC := OnResult; + Client.SendTunnel.CloneConnectM({$IFDEF FPC}@{$ENDIF FPC}tmp.DoP2PVM_CloneConnectAndGetFile); +end; + +procedure TDTC40_FS_Client.FS_GetFile_M(Token: U_String; Token_is_MD5: Boolean; OnResult: TON_FS_GetFile_DoneM); +var + tmp: TFS_Temp_Get_File_Tunnel; +begin + tmp := TFS_Temp_Get_File_Tunnel.Create; + tmp.Client := Self; + tmp.Token := Token; + tmp.Token_is_MD5 := Token_is_MD5; + tmp.OnResultM := OnResult; + Client.SendTunnel.CloneConnectM({$IFDEF FPC}@{$ENDIF FPC}tmp.DoP2PVM_CloneConnectAndGetFile); +end; + +procedure TDTC40_FS_Client.FS_GetFile_P(Token: U_String; Token_is_MD5: Boolean; OnResult: TON_FS_GetFile_DoneP); +var + tmp: TFS_Temp_Get_File_Tunnel; +begin + tmp := TFS_Temp_Get_File_Tunnel.Create; + tmp.Client := Self; + tmp.Token := Token; + tmp.Token_is_MD5 := Token_is_MD5; + tmp.OnResultP := OnResult; + Client.SendTunnel.CloneConnectM({$IFDEF FPC}@{$ENDIF FPC}tmp.DoP2PVM_CloneConnectAndGetFile); +end; + +initialization + +RegisterC40('FS', TDTC40_FS_Service, TDTC40_FS_Client); +RegisterC40('FS0', TDTC40_FS_Service, TDTC40_FS_Client); +RegisterC40('FS1', TDTC40_FS_Service, TDTC40_FS_Client); +RegisterC40('FS2', TDTC40_FS_Service, TDTC40_FS_Client); +RegisterC40('FS3', TDTC40_FS_Service, TDTC40_FS_Client); +RegisterC40('FS4', TDTC40_FS_Service, TDTC40_FS_Client); +RegisterC40('FS5', TDTC40_FS_Service, TDTC40_FS_Client); +RegisterC40('FS6', TDTC40_FS_Service, TDTC40_FS_Client); +RegisterC40('FS7', TDTC40_FS_Service, TDTC40_FS_Client); +RegisterC40('FS8', TDTC40_FS_Service, TDTC40_FS_Client); +RegisterC40('FS9', TDTC40_FS_Service, TDTC40_FS_Client); + +end. diff --git a/Source/DTC40_UserDB.pas b/Source/DTC40_UserDB.pas new file mode 100644 index 00000000..a7d3e27d --- /dev/null +++ b/Source/DTC40_UserDB.pas @@ -0,0 +1,1105 @@ +{ ****************************************************************************** } +{ * cloud 4.0 User Database * } +{ ****************************************************************************** } +{ * https://zpascal.net * } +{ * https://github.com/PassByYou888/zAI * } +{ * https://github.com/PassByYou888/ZServer4D * } +{ * https://github.com/PassByYou888/PascalString * } +{ * https://github.com/PassByYou888/zRasterization * } +{ * https://github.com/PassByYou888/CoreCipher * } +{ * https://github.com/PassByYou888/zSound * } +{ * https://github.com/PassByYou888/zChinese * } +{ * https://github.com/PassByYou888/zExpression * } +{ * https://github.com/PassByYou888/zGameWare * } +{ * https://github.com/PassByYou888/zAnalysis * } +{ * https://github.com/PassByYou888/FFMPEG-Header * } +{ * https://github.com/PassByYou888/zTranslate * } +{ * https://github.com/PassByYou888/InfiniteIoT * } +{ * https://github.com/PassByYou888/FastMD5 * } +{ ****************************************************************************** } +unit DTC40_UserDB; + +{$INCLUDE zDefine.inc} + +interface + +uses +{$IFDEF FPC} + FPCGenericStructlist, +{$ENDIF FPC} + CoreClasses, PascalStrings, DoStatusIO, UnicodeMixedLib, + Geometry2DUnit, DataFrameEngine, + ZJson, GHashList, + NotifyObjectBase, CoreCipher, MemoryStream64, + ObjectData, ObjectDataManager, ItemStream, + CommunicationFramework, PhysicsIO, CommunicationFrameworkDoubleTunnelIO_NoAuth, DTC40; + +type + TDTC40_UserDB_Client = class; + TJsonHashList = {$IFDEF FPC}specialize {$ENDIF FPC}TGenericHashList; + + TDTC40_UserDB_Service = class(TDTC40_Base_NoAuth_Service) + protected + // init build-in data + IsLoading: Boolean; + IsSaveing: Boolean; + procedure DoLoading(); + procedure DoBackground_Save(thSender: TCompute); + private + procedure cmd_Usr_Find(sender: TPeerIO; InData, OutData: TDFE); + procedure cmd_Usr_Reg(sender: TPeerIO; InData, OutData: TDFE); + procedure cmd_Usr_Get(sender: TPeerIO; InData, OutData: TDFE); + procedure cmd_Usr_Post(sender: TPeerIO; InData, OutData: TDFE); + procedure cmd_Usr_Remove(sender: TPeerIO; InData, OutData: TDFE); + public + UserIdentifierHash: TJsonHashList; + UserJsonList: TZJL; + DTC40_UserDB_FileName: U_string; + + constructor Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_string); override; + destructor Destroy; override; + procedure SafeCheck; override; + + function MatchIdentifier(Identifier_: U_string; j: TZJ): Boolean; + function ExistsIdentifier(j: TZJ): Boolean; + function ExtractJsonToHash(j: TZJ): Boolean; + procedure LoadUserDB; + procedure SaveUserDBAsDFE(DFE: TDFE); + procedure CleanLoseJson; + end; + + TON_Usr_FindC = procedure(sender: TDTC40_UserDB_Client; List: TZJL); + TON_Usr_FindM = procedure(sender: TDTC40_UserDB_Client; List: TZJL) of object; +{$IFDEF FPC} + TON_Usr_FindP = procedure(sender: TDTC40_UserDB_Client; List: TZJL) is nested; +{$ELSE FPC} + TON_Usr_FindP = reference to procedure(sender: TDTC40_UserDB_Client; List: TZJL); +{$ENDIF FPC} + + TOnUsrFind = class(TOnResultBridge) + public + Client: TDTC40_UserDB_Client; + OnResultC: TON_Usr_FindC; + OnResultM: TON_Usr_FindM; + OnResultP: TON_Usr_FindP; + constructor Create; override; + procedure DoStreamParamEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); override; + procedure DoStreamFailedEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); override; + end; + + TON_Usr_RegC = procedure(sender: TDTC40_UserDB_Client; States: TArrayBool); + TON_Usr_RegM = procedure(sender: TDTC40_UserDB_Client; States: TArrayBool) of object; +{$IFDEF FPC} + TON_Usr_RegP = procedure(sender: TDTC40_UserDB_Client; States: TArrayBool) is nested; +{$ELSE FPC} + TON_Usr_RegP = reference to procedure(sender: TDTC40_UserDB_Client; States: TArrayBool); +{$ENDIF FPC} + + TOnUsrReg = class(TOnResultBridge) + public + Client: TDTC40_UserDB_Client; + OnResultC: TON_Usr_RegC; + OnResultM: TON_Usr_RegM; + OnResultP: TON_Usr_RegP; + constructor Create; override; + procedure DoStreamParamEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); override; + procedure DoStreamFailedEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); override; + end; + + TON_Usr_GetC = procedure(sender: TDTC40_UserDB_Client; List: TZJL); + TON_Usr_GetM = procedure(sender: TDTC40_UserDB_Client; List: TZJL) of object; +{$IFDEF FPC} + TON_Usr_GetP = procedure(sender: TDTC40_UserDB_Client; List: TZJL) is nested; +{$ELSE FPC} + TON_Usr_GetP = reference to procedure(sender: TDTC40_UserDB_Client; List: TZJL); +{$ENDIF FPC} + + TOnUsrGet = class(TOnResultBridge) + public + Client: TDTC40_UserDB_Client; + OnResultC: TON_Usr_GetC; + OnResultM: TON_Usr_GetM; + OnResultP: TON_Usr_GetP; + constructor Create; override; + procedure DoStreamParamEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); override; + procedure DoStreamFailedEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); override; + end; + + TON_Usr_PostC = procedure(sender: TDTC40_UserDB_Client; States: TArrayBool); + TON_Usr_PostM = procedure(sender: TDTC40_UserDB_Client; States: TArrayBool) of object; +{$IFDEF FPC} + TON_Usr_PostP = procedure(sender: TDTC40_UserDB_Client; States: TArrayBool) is nested; +{$ELSE FPC} + TON_Usr_PostP = reference to procedure(sender: TDTC40_UserDB_Client; States: TArrayBool); +{$ENDIF FPC} + + TOnUsrPost = class(TOnResultBridge) + public + Client: TDTC40_UserDB_Client; + OnResultC: TON_Usr_PostC; + OnResultM: TON_Usr_PostM; + OnResultP: TON_Usr_PostP; + constructor Create; override; + procedure DoStreamParamEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); override; + procedure DoStreamFailedEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); override; + end; + + TON_Usr_RemoveC = procedure(sender: TDTC40_UserDB_Client; States: TArrayBool); + TON_Usr_RemoveM = procedure(sender: TDTC40_UserDB_Client; States: TArrayBool) of object; +{$IFDEF FPC} + TON_Usr_RemoveP = procedure(sender: TDTC40_UserDB_Client; States: TArrayBool) is nested; +{$ELSE FPC} + TON_Usr_RemoveP = reference to procedure(sender: TDTC40_UserDB_Client; States: TArrayBool); +{$ENDIF FPC} + + TOnUsrRemove = class(TOnResultBridge) + public + Client: TDTC40_UserDB_Client; + OnResultC: TON_Usr_RemoveC; + OnResultM: TON_Usr_RemoveM; + OnResultP: TON_Usr_RemoveP; + constructor Create; override; + procedure DoStreamParamEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); override; + procedure DoStreamFailedEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); override; + end; + + TDTC40_UserDB_Client = class(TDTC40_Base_NoAuth_Client) + public + constructor Create(source_: TDTC40_Info; Param_: U_string); override; + destructor Destroy; override; + + procedure Usr_FindC(Identifier_: SystemString; MaxResult: Integer; OnResult: TON_Usr_FindC); + procedure Usr_FindM(Identifier_: SystemString; MaxResult: Integer; OnResult: TON_Usr_FindM); + procedure Usr_FindP(Identifier_: SystemString; MaxResult: Integer; OnResult: TON_Usr_FindP); + + procedure Usr_RegC(L: TZJL; OnResult: TON_Usr_RegC); + procedure Usr_RegM(L: TZJL; OnResult: TON_Usr_RegM); + procedure Usr_RegP(L: TZJL; OnResult: TON_Usr_RegP); + + procedure Usr_GetC(Identifier_: U_StringArray; OnResult: TON_Usr_GetC); + procedure Usr_GetM(Identifier_: U_StringArray; OnResult: TON_Usr_GetM); + procedure Usr_GetP(Identifier_: U_StringArray; OnResult: TON_Usr_GetP); + + procedure Usr_PostC(L: TZJL; OnResult: TON_Usr_PostC); + procedure Usr_PostM(L: TZJL; OnResult: TON_Usr_PostM); + procedure Usr_PostP(L: TZJL; OnResult: TON_Usr_PostP); + + procedure Usr_RemoveC(L: TZJL; OnResult: TON_Usr_RemoveC); + procedure Usr_RemoveM(L: TZJL; OnResult: TON_Usr_RemoveM); + procedure Usr_RemoveP(L: TZJL; OnResult: TON_Usr_RemoveP); + end; + +function GetIdentifier(j: TZJ): TZJArry; + +implementation + +function GetIdentifier(j: TZJ): TZJArry; +begin + Result := j.A['Identifier']; +end; + +procedure TDTC40_UserDB_Service.DoLoading; +begin + IsLoading := True; + IsSaveing := False; + try + LoadUserDB; + except + end; + IsLoading := False; +end; + +procedure TDTC40_UserDB_Service.DoBackground_Save(thSender: TCompute); +var + D: TDFE; +begin + try + D := TDFE(thSender.UserObject); + D.SaveToFile(DTC40_UserDB_FileName); + DisposeObject(D); + DoStatus('Save User Database Done.'); + except + end; + IsSaveing := False; +end; + +procedure TDTC40_UserDB_Service.cmd_Usr_Find(sender: TPeerIO; InData, OutData: TDFE); +var + Identifier_: SystemString; + MaxResult: Integer; + L: TZJL; + +{$IFDEF FPC} + procedure fpc_Progress_(const Name: PSystemString; Obj: TZJ); + begin + if (MaxResult <= 0) or (L.Count < MaxResult) then + if MatchIdentifier(Identifier_, Obj) then + if not L.IndexOf(Obj) < 0 then + L.Add(Obj); + end; +{$ENDIF FPC} + + +var + i: Integer; +begin + L := TZJL.Create(False); + Identifier_ := InData.R.ReadString; + MaxResult := InData.R.ReadInteger; + +{$IFDEF FPC} + UserIdentifierHash.ProgressP(@fpc_Progress_); +{$ELSE FPC} + UserIdentifierHash.ProgressP( + procedure(const Name: PSystemString; Obj: TZJ) + begin + if (MaxResult <= 0) or (L.Count < MaxResult) then + if MatchIdentifier(Identifier_, Obj) then + if not L.IndexOf(Obj) < 0 then + L.Add(Obj); + end); +{$ENDIF FPC} + for i := 0 to L.Count - 1 do + OutData.WriteJson(L[i]); + DisposeObject(L); +end; + +procedure TDTC40_UserDB_Service.cmd_Usr_Reg(sender: TPeerIO; InData, OutData: TDFE); +var + j: TZJ; +begin + while InData.R.NotEnd do + begin + j := TZJ.Create; + InData.R.ReadJson(j); + + if (not ExistsIdentifier(j)) and ExtractJsonToHash(j) then + begin + UserJsonList.Add(j); + OutData.WriteBool(True); + end + else + begin + OutData.WriteBool(False); + DisposeObject(j); + end; + end; +end; + +procedure TDTC40_UserDB_Service.cmd_Usr_Get(sender: TPeerIO; InData, OutData: TDFE); +var + Identifier_: U_string; +begin + while InData.R.NotEnd do + begin + Identifier_ := InData.R.ReadString; + if UserIdentifierHash.Exists(Identifier_) then + begin + OutData.WriteJson(UserIdentifierHash[Identifier_]); + end + else + begin + OutData.WriteBool(False); + end; + end; +end; + +procedure TDTC40_UserDB_Service.cmd_Usr_Post(sender: TPeerIO; InData, OutData: TDFE); +var + j: TZJ; +begin + while InData.R.NotEnd do + begin + j := TZJ.Create; + InData.R.ReadJson(j); + if ExtractJsonToHash(j) then + begin + UserJsonList.Add(j); + OutData.WriteBool(True); + end + else + begin + OutData.WriteBool(False); + DisposeObject(j); + end; + end; +end; + +procedure TDTC40_UserDB_Service.cmd_Usr_Remove(sender: TPeerIO; InData, OutData: TDFE); +var + j: TZJ; + arry: TZJArry; + i: Integer; + found_: Integer; +begin + while InData.R.NotEnd do + begin + j := TZJ.Create; + InData.R.ReadJson(j); + arry := GetIdentifier(j); + found_ := 0; + for i := 0 to arry.Count - 1 do + if (arry.S[i] <> '') and UserIdentifierHash.Exists(arry.S[i]) then + begin + UserIdentifierHash.Delete(arry.S[i]); + inc(found_); + end; + OutData.WriteBool(found_ > 0); + DisposeObject(j); + end; +end; + +constructor TDTC40_UserDB_Service.Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_string); +begin + inherited Create(PhysicsService_, ServiceTyp, Param_); + ServiceInfo.OnlyInstance := True; + DTNoAuthService.RecvTunnel.RegisterStream('Usr_Find').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_Usr_Find; + DTNoAuthService.RecvTunnel.RegisterStream('Usr_Reg').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_Usr_Reg; + DTNoAuthService.RecvTunnel.RegisterStream('Usr_Get').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_Usr_Get; + DTNoAuthService.RecvTunnel.RegisterStream('Usr_Post').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_Usr_Post; + DTNoAuthService.RecvTunnel.RegisterStream('Usr_Remove').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_Usr_Remove; + UpdateToGlobalDispatch; + + UserIdentifierHash := TJsonHashList.Create(False, 1024 * 1024, nil); + UserIdentifierHash.AccessOptimization := True; + UserIdentifierHash.IgnoreCase := False; + UserJsonList := TZJL.Create(True); + DTC40_UserDB_FileName := umlCombineFileName(DTNoAuthService.PublicFileDirectory, PFormat('DTC40_%s.DFE', [ServiceInfo.ServiceTyp.Text])); + DoLoading; +end; + +destructor TDTC40_UserDB_Service.Destroy; +begin + DisposeObject(UserIdentifierHash); + DisposeObject(UserJsonList); + inherited Destroy; +end; + +procedure TDTC40_UserDB_Service.SafeCheck; +var + D: TDFE; +begin + inherited SafeCheck; + if IsSaveing then + exit; + + IsSaveing := True; + D := TDFE.Create; + DoStatus('Extract User Json.'); + SaveUserDBAsDFE(D); + DoStatus('Save User Database.'); + TCompute.RunM(nil, D, {$IFDEF FPC}@{$ENDIF FPC}DoBackground_Save); +end; + +function TDTC40_UserDB_Service.MatchIdentifier(Identifier_: U_string; j: TZJ): Boolean; +var + arry: TZJArry; + i: Integer; +begin + Result := True; + arry := GetIdentifier(j); + for i := 0 to arry.Count - 1 do + if umlMultipleMatch(True, Identifier_, arry.S[i]) then + exit; + Result := False; +end; + +function TDTC40_UserDB_Service.ExistsIdentifier(j: TZJ): Boolean; +var + arry: TZJArry; + i: Integer; +begin + Result := True; + arry := GetIdentifier(j); + for i := 0 to arry.Count - 1 do + if (arry.S[i] <> '') and UserIdentifierHash.Exists(arry.S[i]) then + exit; + Result := False; +end; + +function TDTC40_UserDB_Service.ExtractJsonToHash(j: TZJ): Boolean; +var + arry: TZJArry; + i: Integer; + tmp: TZJ; +begin + Result := False; + arry := GetIdentifier(j); + if arry.Count = 0 then + exit; + + for i := 0 to arry.Count - 1 do + if (arry.S[i] <> '') then + begin + tmp := UserIdentifierHash[arry.S[i]]; + if (tmp <> nil) then + tmp.Assign(j) + else + UserIdentifierHash.Add(arry.S[i], j); + end; + + Result := True; +end; + +procedure TDTC40_UserDB_Service.LoadUserDB; +var + D: TDFE; + j: TZJ; +begin + if not umlFileExists(DTC40_UserDB_FileName) then + exit; + + UserJsonList.Clear; + UserIdentifierHash.Clear; + + D := TDFE.Create; + + try + DoStatus('Load user database "%s"', [DTC40_UserDB_FileName.Text]); + D.LoadFromFile(DTC40_UserDB_FileName); + + DoStatus('extract user Database.'); + while D.R.NotEnd do + begin + j := TZJ.Create; + D.R.ReadJson(j); + if not ExtractJsonToHash(j) then + DTC40PhysicsService.PhysicsTunnel.Error('error json'#13#10'%s', [j.ToJSONString(True).Text]); + end; + DoStatus('extract user Database done.'); + except + end; + + DisposeObject(D); +end; + +procedure TDTC40_UserDB_Service.SaveUserDBAsDFE(DFE: TDFE); +{$IFDEF FPC} + procedure fpc_Progress_(const Name: PSystemString; Obj: TZJ); + begin + if ExistsIdentifier(Obj) then + Obj.Tag := 1; + end; +{$ENDIF FPC} + + +var + i: Integer; +begin + for i := 0 to UserJsonList.Count - 1 do + UserJsonList[i].Tag := 0; + +{$IFDEF FPC} + UserIdentifierHash.ProgressP(@fpc_Progress_); +{$ELSE FPC} + UserIdentifierHash.ProgressP( + procedure(const Name: PSystemString; Obj: TZJ) + begin + if ExistsIdentifier(Obj) then + Obj.Tag := 1; + end); +{$ENDIF FPC} + for i := 0 to UserJsonList.Count - 1 do + if UserJsonList[i].Tag = 1 then + DFE.WriteJson(UserJsonList[i]); +end; + +procedure TDTC40_UserDB_Service.CleanLoseJson; +{$IFDEF FPC} + procedure fpc_Progress_(const Name: PSystemString; Obj: TZJ); + begin + if ExistsIdentifier(Obj) then + Obj.Tag := 1; + end; +{$ENDIF FPC} + + +var + i: Integer; +begin + for i := 0 to UserJsonList.Count - 1 do + UserJsonList[i].Tag := 0; + +{$IFDEF FPC} + UserIdentifierHash.ProgressP(@fpc_Progress_); +{$ELSE FPC} + UserIdentifierHash.ProgressP( + procedure(const Name: PSystemString; Obj: TZJ) + begin + if ExistsIdentifier(Obj) then + Obj.Tag := 1; + end); +{$ENDIF FPC} + i := 0; + while i < UserJsonList.Count do + if UserJsonList[i].Tag <> 1 then + begin + UserJsonList.Delete(i); + end + else + begin + UserJsonList[i].Tag := 0; + inc(i); + end; +end; + +constructor TOnUsrFind.Create; +begin + inherited Create; + Client := nil; + OnResultC := nil; + OnResultM := nil; + OnResultP := nil; +end; + +procedure TOnUsrFind.DoStreamParamEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); +var + tmp: TZJL; + j: TZJ; +begin + tmp := TZJL.Create(True); + while Result_.R.NotEnd do + begin + j := TZJ.Create; + Result_.R.ReadJson(j); + tmp.Add(j); + end; + + try + if Assigned(OnResultC) then + OnResultC(Client, tmp); + if Assigned(OnResultM) then + OnResultM(Client, tmp); + if Assigned(OnResultP) then + OnResultP(Client, tmp); + except + end; + + DelayFreeObject(1.0, self, tmp); +end; + +procedure TOnUsrFind.DoStreamFailedEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); +begin + try + if Assigned(OnResultC) then + OnResultC(Client, nil); + if Assigned(OnResultM) then + OnResultM(Client, nil); + if Assigned(OnResultP) then + OnResultP(Client, nil); + except + end; + + DelayFreeObject(1.0, self); +end; + +constructor TOnUsrReg.Create; +begin + inherited Create; + Client := nil; + OnResultC := nil; + OnResultM := nil; + OnResultP := nil; +end; + +procedure TOnUsrReg.DoStreamParamEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); +var + tmp: TArrayBool; + i: Integer; +begin + SetLength(tmp, Result_.Count); + for i := 0 to Result_.Count - 1 do + tmp[i] := Result_.ReadBool(i); + + try + if Assigned(OnResultC) then + OnResultC(Client, tmp); + if Assigned(OnResultM) then + OnResultM(Client, tmp); + if Assigned(OnResultP) then + OnResultP(Client, tmp); + except + end; + + DelayFreeObject(1.0, self); +end; + +procedure TOnUsrReg.DoStreamFailedEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); +begin + try + if Assigned(OnResultC) then + OnResultC(Client, nil); + if Assigned(OnResultM) then + OnResultM(Client, nil); + if Assigned(OnResultP) then + OnResultP(Client, nil); + except + end; + + DelayFreeObject(1.0, self); +end; + +constructor TOnUsrGet.Create; +begin + inherited Create; + Client := nil; + OnResultC := nil; + OnResultM := nil; + OnResultP := nil; +end; + +procedure TOnUsrGet.DoStreamParamEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); +var + tmp: TZJL; + j: TZJ; +begin + tmp := TZJL.Create(True); + while Result_.R.NotEnd do + begin + j := TZJ.Create; + Result_.R.ReadJson(j); + tmp.Add(j); + end; + + try + if Assigned(OnResultC) then + OnResultC(Client, tmp); + if Assigned(OnResultM) then + OnResultM(Client, tmp); + if Assigned(OnResultP) then + OnResultP(Client, tmp); + except + end; + + DelayFreeObject(1.0, self, tmp); +end; + +procedure TOnUsrGet.DoStreamFailedEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); +begin + try + if Assigned(OnResultC) then + OnResultC(Client, nil); + if Assigned(OnResultM) then + OnResultM(Client, nil); + if Assigned(OnResultP) then + OnResultP(Client, nil); + except + end; + + DelayFreeObject(1.0, self); +end; + +constructor TOnUsrPost.Create; +begin + inherited Create; + Client := nil; + OnResultC := nil; + OnResultM := nil; + OnResultP := nil; +end; + +procedure TOnUsrPost.DoStreamParamEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); +var + tmp: TArrayBool; + i: Integer; +begin + SetLength(tmp, Result_.Count); + for i := 0 to Result_.Count - 1 do + tmp[i] := Result_.ReadBool(i); + + try + if Assigned(OnResultC) then + OnResultC(Client, tmp); + if Assigned(OnResultM) then + OnResultM(Client, tmp); + if Assigned(OnResultP) then + OnResultP(Client, tmp); + except + end; + + DelayFreeObject(1.0, self); +end; + +procedure TOnUsrPost.DoStreamFailedEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); +begin + try + if Assigned(OnResultC) then + OnResultC(Client, nil); + if Assigned(OnResultM) then + OnResultM(Client, nil); + if Assigned(OnResultP) then + OnResultP(Client, nil); + except + end; + + DelayFreeObject(1.0, self); +end; + +constructor TOnUsrRemove.Create; +begin + inherited Create; + Client := nil; + OnResultC := nil; + OnResultM := nil; + OnResultP := nil; +end; + +procedure TOnUsrRemove.DoStreamParamEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); +var + tmp: TArrayBool; + i: Integer; +begin + SetLength(tmp, Result_.Count); + for i := 0 to Result_.Count - 1 do + tmp[i] := Result_.ReadBool(i); + + try + if Assigned(OnResultC) then + OnResultC(Client, tmp); + if Assigned(OnResultM) then + OnResultM(Client, tmp); + if Assigned(OnResultP) then + OnResultP(Client, tmp); + except + end; + + DelayFreeObject(1.0, self); +end; + +procedure TOnUsrRemove.DoStreamFailedEvent(sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); +begin + try + if Assigned(OnResultC) then + OnResultC(Client, nil); + if Assigned(OnResultM) then + OnResultM(Client, nil); + if Assigned(OnResultP) then + OnResultP(Client, nil); + except + end; + + DelayFreeObject(1.0, self); +end; + +constructor TDTC40_UserDB_Client.Create(source_: TDTC40_Info; Param_: U_string); +begin + inherited Create(source_, Param_); +end; + +destructor TDTC40_UserDB_Client.Destroy; +begin + inherited Destroy; +end; + +procedure TDTC40_UserDB_Client.Usr_FindC(Identifier_: SystemString; MaxResult: Integer; OnResult: TON_Usr_FindC); +var + D: TDFE; + tmp: TOnUsrFind; +begin + D := TDFE.Create; + D.WriteString(Identifier_); + D.WriteInteger(MaxResult); + + tmp := TOnUsrFind.Create; + tmp.Client := self; + tmp.OnResultC := OnResult; + + DTNoAuthClient.SendTunnel.SendStreamCmdM('Usr_Find', D, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + + DisposeObject(D); +end; + +procedure TDTC40_UserDB_Client.Usr_FindM(Identifier_: SystemString; MaxResult: Integer; OnResult: TON_Usr_FindM); +var + D: TDFE; + tmp: TOnUsrFind; +begin + D := TDFE.Create; + D.WriteString(Identifier_); + D.WriteInteger(MaxResult); + + tmp := TOnUsrFind.Create; + tmp.Client := self; + tmp.OnResultM := OnResult; + + DTNoAuthClient.SendTunnel.SendStreamCmdM('Usr_Find', D, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + + DisposeObject(D); +end; + +procedure TDTC40_UserDB_Client.Usr_FindP(Identifier_: SystemString; MaxResult: Integer; OnResult: TON_Usr_FindP); +var + D: TDFE; + tmp: TOnUsrFind; +begin + D := TDFE.Create; + D.WriteString(Identifier_); + D.WriteInteger(MaxResult); + + tmp := TOnUsrFind.Create; + tmp.Client := self; + tmp.OnResultP := OnResult; + + DTNoAuthClient.SendTunnel.SendStreamCmdM('Usr_Find', D, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + + DisposeObject(D); +end; + +procedure TDTC40_UserDB_Client.Usr_RegC(L: TZJL; OnResult: TON_Usr_RegC); +var + D: TDFE; + i: Integer; + tmp: TOnUsrReg; +begin + D := TDFE.Create; + for i := 0 to L.Count - 1 do + D.WriteJson(L[i]); + + tmp := TOnUsrReg.Create; + tmp.Client := self; + tmp.OnResultC := OnResult; + + DTNoAuthClient.SendTunnel.SendStreamCmdM('Usr_Reg', D, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + + DisposeObject(D); +end; + +procedure TDTC40_UserDB_Client.Usr_RegM(L: TZJL; OnResult: TON_Usr_RegM); +var + D: TDFE; + i: Integer; + tmp: TOnUsrReg; +begin + D := TDFE.Create; + for i := 0 to L.Count - 1 do + D.WriteJson(L[i]); + + tmp := TOnUsrReg.Create; + tmp.Client := self; + tmp.OnResultM := OnResult; + + DTNoAuthClient.SendTunnel.SendStreamCmdM('Usr_Reg', D, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + + DisposeObject(D); +end; + +procedure TDTC40_UserDB_Client.Usr_RegP(L: TZJL; OnResult: TON_Usr_RegP); +var + D: TDFE; + i: Integer; + tmp: TOnUsrReg; +begin + D := TDFE.Create; + for i := 0 to L.Count - 1 do + D.WriteJson(L[i]); + + tmp := TOnUsrReg.Create; + tmp.Client := self; + tmp.OnResultP := OnResult; + + DTNoAuthClient.SendTunnel.SendStreamCmdM('Usr_Reg', D, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + + DisposeObject(D); +end; + +procedure TDTC40_UserDB_Client.Usr_GetC(Identifier_: U_StringArray; OnResult: TON_Usr_GetC); +var + D: TDFE; + i: Integer; + tmp: TOnUsrGet; +begin + D := TDFE.Create; + for i := 0 to length(Identifier_) - 1 do + D.WriteString(Identifier_[i]); + + tmp := TOnUsrGet.Create; + tmp.Client := self; + tmp.OnResultC := OnResult; + + DTNoAuthClient.SendTunnel.SendStreamCmdM('Usr_Get', D, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + + DisposeObject(D); +end; + +procedure TDTC40_UserDB_Client.Usr_GetM(Identifier_: U_StringArray; OnResult: TON_Usr_GetM); +var + D: TDFE; + i: Integer; + tmp: TOnUsrGet; +begin + D := TDFE.Create; + for i := 0 to length(Identifier_) - 1 do + D.WriteString(Identifier_[i]); + + tmp := TOnUsrGet.Create; + tmp.Client := self; + tmp.OnResultM := OnResult; + + DTNoAuthClient.SendTunnel.SendStreamCmdM('Usr_Get', D, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + + DisposeObject(D); +end; + +procedure TDTC40_UserDB_Client.Usr_GetP(Identifier_: U_StringArray; OnResult: TON_Usr_GetP); +var + D: TDFE; + i: Integer; + tmp: TOnUsrGet; +begin + D := TDFE.Create; + for i := 0 to length(Identifier_) - 1 do + D.WriteString(Identifier_[i]); + + tmp := TOnUsrGet.Create; + tmp.Client := self; + tmp.OnResultP := OnResult; + + DTNoAuthClient.SendTunnel.SendStreamCmdM('Usr_Get', D, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + + DisposeObject(D); +end; + +procedure TDTC40_UserDB_Client.Usr_PostC(L: TZJL; OnResult: TON_Usr_PostC); +var + D: TDFE; + i: Integer; + tmp: TOnUsrPost; +begin + D := TDFE.Create; + for i := 0 to L.Count - 1 do + D.WriteJson(L[i]); + + tmp := TOnUsrPost.Create; + tmp.Client := self; + tmp.OnResultC := OnResult; + + DTNoAuthClient.SendTunnel.SendStreamCmdM('Usr_Post', D, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + + DisposeObject(D); +end; + +procedure TDTC40_UserDB_Client.Usr_PostM(L: TZJL; OnResult: TON_Usr_PostM); +var + D: TDFE; + i: Integer; + tmp: TOnUsrPost; +begin + D := TDFE.Create; + for i := 0 to L.Count - 1 do + D.WriteJson(L[i]); + + tmp := TOnUsrPost.Create; + tmp.Client := self; + tmp.OnResultM := OnResult; + + DTNoAuthClient.SendTunnel.SendStreamCmdM('Usr_Post', D, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + + DisposeObject(D); +end; + +procedure TDTC40_UserDB_Client.Usr_PostP(L: TZJL; OnResult: TON_Usr_PostP); +var + D: TDFE; + i: Integer; + tmp: TOnUsrPost; +begin + D := TDFE.Create; + for i := 0 to L.Count - 1 do + D.WriteJson(L[i]); + + tmp := TOnUsrPost.Create; + tmp.Client := self; + tmp.OnResultP := OnResult; + + DTNoAuthClient.SendTunnel.SendStreamCmdM('Usr_Post', D, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + + DisposeObject(D); +end; + +procedure TDTC40_UserDB_Client.Usr_RemoveC(L: TZJL; OnResult: TON_Usr_RemoveC); +var + D: TDFE; + i: Integer; + tmp: TOnUsrRemove; +begin + D := TDFE.Create; + for i := 0 to L.Count - 1 do + D.WriteJson(L[i]); + + tmp := TOnUsrRemove.Create; + tmp.Client := self; + tmp.OnResultC := OnResult; + + DTNoAuthClient.SendTunnel.SendStreamCmdM('Usr_Remove', D, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + + DisposeObject(D); +end; + +procedure TDTC40_UserDB_Client.Usr_RemoveM(L: TZJL; OnResult: TON_Usr_RemoveM); +var + D: TDFE; + i: Integer; + tmp: TOnUsrRemove; +begin + D := TDFE.Create; + for i := 0 to L.Count - 1 do + D.WriteJson(L[i]); + + tmp := TOnUsrRemove.Create; + tmp.Client := self; + tmp.OnResultM := OnResult; + + DTNoAuthClient.SendTunnel.SendStreamCmdM('Usr_Remove', D, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + + DisposeObject(D); +end; + +procedure TDTC40_UserDB_Client.Usr_RemoveP(L: TZJL; OnResult: TON_Usr_RemoveP); +var + D: TDFE; + i: Integer; + tmp: TOnUsrRemove; +begin + D := TDFE.Create; + for i := 0 to L.Count - 1 do + D.WriteJson(L[i]); + + tmp := TOnUsrRemove.Create; + tmp.Client := self; + tmp.OnResultP := OnResult; + + DTNoAuthClient.SendTunnel.SendStreamCmdM('Usr_Remove', D, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + + DisposeObject(D); +end; + +initialization + +RegisterC40('UserDB', TDTC40_UserDB_Service, TDTC40_UserDB_Client); +RegisterC40('UserDB0', TDTC40_UserDB_Service, TDTC40_UserDB_Client); +RegisterC40('UserDB1', TDTC40_UserDB_Service, TDTC40_UserDB_Client); +RegisterC40('UserDB2', TDTC40_UserDB_Service, TDTC40_UserDB_Client); +RegisterC40('UserDB3', TDTC40_UserDB_Service, TDTC40_UserDB_Client); +RegisterC40('UserDB4', TDTC40_UserDB_Service, TDTC40_UserDB_Client); +RegisterC40('UserDB5', TDTC40_UserDB_Service, TDTC40_UserDB_Client); +RegisterC40('UserDB6', TDTC40_UserDB_Service, TDTC40_UserDB_Client); +RegisterC40('UserDB7', TDTC40_UserDB_Service, TDTC40_UserDB_Client); +RegisterC40('UserDB8', TDTC40_UserDB_Service, TDTC40_UserDB_Client); +RegisterC40('UserDB9', TDTC40_UserDB_Service, TDTC40_UserDB_Client); + +end. diff --git a/Source/DTC40_Var.pas b/Source/DTC40_Var.pas new file mode 100644 index 00000000..d79bf767 --- /dev/null +++ b/Source/DTC40_Var.pas @@ -0,0 +1,1348 @@ +{ ****************************************************************************** } +{ * cloud 4.0 Network Variant * } +{ ****************************************************************************** } +{ * https://zpascal.net * } +{ * https://github.com/PassByYou888/zAI * } +{ * https://github.com/PassByYou888/ZServer4D * } +{ * https://github.com/PassByYou888/PascalString * } +{ * https://github.com/PassByYou888/zRasterization * } +{ * https://github.com/PassByYou888/CoreCipher * } +{ * https://github.com/PassByYou888/zSound * } +{ * https://github.com/PassByYou888/zChinese * } +{ * https://github.com/PassByYou888/zExpression * } +{ * https://github.com/PassByYou888/zGameWare * } +{ * https://github.com/PassByYou888/zAnalysis * } +{ * https://github.com/PassByYou888/FFMPEG-Header * } +{ * https://github.com/PassByYou888/zTranslate * } +{ * https://github.com/PassByYou888/InfiniteIoT * } +{ * https://github.com/PassByYou888/FastMD5 * } +{ ****************************************************************************** } +unit DTC40_Var; + +{$INCLUDE zDefine.inc} + +interface + +uses +{$IFDEF FPC} + FPCGenericStructlist, +{$ENDIF FPC} + CoreClasses, PascalStrings, DoStatusIO, UnicodeMixedLib, + Geometry2DUnit, DataFrameEngine, + TextParsing, zExpression, OpCode, + ZJson, GHashList, NumberBase, + NotifyObjectBase, CoreCipher, MemoryStream64, + ObjectData, ObjectDataManager, ItemStream, + CommunicationFramework, PhysicsIO, CommunicationFrameworkDoubleTunnelIO_NoAuth, DTC40; + +type + TDTC40_Var_Service = class; + TDTC40_Var_Client = class; + + TDTC40_PhysicsServicePool_Decl = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + + TDTC40_VarService_NM_Pool = class(TNumberModulePool) + public + Name: U_String; + Service: TDTC40_Var_Service; + Client: TDTC40_Var_Client; + IO_ID_List: TIO_ID_List; + IsTemp, IsFreeing: Boolean; + LifeTime, OverTime: TTimeTick; + LastAccessTime: TDateTime; + + constructor Create; override; + destructor Destroy; override; + procedure DoNMChange(Sender: TNumberModule; OLD_, New_: Variant); override; + end; + + TOnDTC40_Var_NM_Change = procedure(NMPool_: TDTC40_VarService_NM_Pool; NM: TNumberModule) of object; + TOnDTC40_Var_NMPool_Event = procedure(NMPool_: TDTC40_VarService_NM_Pool) of object; + + TVAR_Service_NMBigPool = {$IFDEF FPC}specialize {$ENDIF FPC}TGenericHashList; + TDTC40_Var_NumberModulePool_List = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + + TDTC40_Var_Service_IO_Define = class(TPeerClientUserDefineForRecvTunnel_NoAuth) + public + NM_List: TDTC40_Var_NumberModulePool_List; + constructor Create(Owner_: TPeerIO); override; + destructor Destroy; override; + end; + + TDTC40_Var_Service = class(TDTC40_Base_NoAuth_Service) + protected + // init build-in data + IsLoading: Boolean; + IsSaveing: Boolean; + procedure DoLoading(); + procedure DoBackground_Save(thSender: TCompute); + protected + procedure DoUserOut_Event(Sender: TDTService_NoAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth); override; + protected + procedure cmd_NM_Init(Sender: TPeerIO; InData: TDFE); + procedure cmd_NM_InitAsTemp(Sender: TPeerIO; InData: TDFE); + procedure cmd_NM_Remove(Sender: TPeerIO; InData: TDFE); + procedure cmd_NM_Get(Sender: TPeerIO; InData, OutData: TDFE); + procedure cmd_NM_GetValue(Sender: TPeerIO; InData, OutData: TDFE); + procedure cmd_NM_Open(Sender: TPeerIO; InData, OutData: TDFE); + procedure cmd_NM_Close(Sender: TPeerIO; InData: TDFE); + procedure cmd_NM_CloseAll(Sender: TPeerIO; InData: TDFE); + procedure cmd_NM_Change(Sender: TPeerIO; InData: TDFE); + procedure cmd_NM_Keep(Sender: TPeerIO; InData: TDFE); + procedure cmd_NM_Script(Sender: TPeerIO; InData, OutData: TDFE); + protected + ProgressTempNMList: TDTC40_Var_NumberModulePool_List; + procedure Progress_NMPool(const Name: PSystemString; Obj: TDTC40_VarService_NM_Pool); + public + DTC40_Var_FileName: U_String; + NMBigPool: TVAR_Service_NMBigPool; + OnChange: TOnDTC40_Var_NM_Change; + OnRemove: TOnDTC40_Var_NMPool_Event; + constructor Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); override; + destructor Destroy; override; + procedure SafeCheck; override; + procedure Progress; override; + function GetNM(Name_: U_String): TDTC40_VarService_NM_Pool; + procedure RemoveNumberModulePool(NM: TDTC40_VarService_NM_Pool); + procedure SaveNMBigPoolAsDFE(DFE: TDFE); + procedure PrintError(v: SystemString); overload; + procedure PrintError(v: SystemString; const Args: array of const); overload; + end; + + TON_NM_GetC = procedure(Sender: TDTC40_Var_Client; NMPool_: TDTC40_VarService_NM_Pool); + TON_NM_GetM = procedure(Sender: TDTC40_Var_Client; NMPool_: TDTC40_VarService_NM_Pool) of object; +{$IFDEF FPC} + TON_NM_GetP = procedure(Sender: TDTC40_Var_Client; NMPool_: TDTC40_VarService_NM_Pool) is nested; +{$ELSE FPC} + TON_NM_GetP = reference to procedure(Sender: TDTC40_Var_Client; NMPool_: TDTC40_VarService_NM_Pool); +{$ENDIF FPC} + + TON_NM_Get = class(TOnResultBridge) + public + Client: TDTC40_Var_Client; + OnResultC: TON_NM_GetC; + OnResultM: TON_NM_GetM; + OnResultP: TON_NM_GetP; + constructor Create; override; + procedure DoStreamParamEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); override; + procedure DoStreamFailedEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); override; + end; + + TON_NM_GetValueC = procedure(Sender: TDTC40_Var_Client; NM: TNumberModule); + TON_NM_GetValueM = procedure(Sender: TDTC40_Var_Client; NM: TNumberModule) of object; +{$IFDEF FPC} + TON_NM_GetValueP = procedure(Sender: TDTC40_Var_Client; NM: TNumberModule) is nested; +{$ELSE FPC} + TON_NM_GetValueP = reference to procedure(Sender: TDTC40_Var_Client; NM: TNumberModule); +{$ENDIF FPC} + + TON_NM_GetValue = class(TOnResultBridge) + public + Client: TDTC40_Var_Client; + NM_Name: U_String; + OnResultC: TON_NM_GetValueC; + OnResultM: TON_NM_GetValueM; + OnResultP: TON_NM_GetValueP; + constructor Create; override; + procedure DoStreamParamEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); override; + procedure DoStreamFailedEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); override; + end; + + TON_NM_OpenC = procedure(Sender: TDTC40_Var_Client; NMPool_: TDTC40_VarService_NM_Pool); + TON_NM_OpenM = procedure(Sender: TDTC40_Var_Client; NMPool_: TDTC40_VarService_NM_Pool) of object; +{$IFDEF FPC} + TON_NM_OpenP = procedure(Sender: TDTC40_Var_Client; NMPool_: TDTC40_VarService_NM_Pool) is nested; +{$ELSE FPC} + TON_NM_OpenP = reference to procedure(Sender: TDTC40_Var_Client; NMPool_: TDTC40_VarService_NM_Pool); +{$ENDIF FPC} + + TON_NM_Open = class(TOnResultBridge) + public + Client: TDTC40_Var_Client; + OnResultC: TON_NM_OpenC; + OnResultM: TON_NM_OpenM; + OnResultP: TON_NM_OpenP; + constructor Create; override; + procedure DoStreamParamEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); override; + procedure DoStreamFailedEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); override; + end; + + TON_NM_ScriptC = procedure(Sender: TDTC40_Var_Client; Result_: TExpressionValueVector); + TON_NM_ScriptM = procedure(Sender: TDTC40_Var_Client; Result_: TExpressionValueVector) of object; +{$IFDEF FPC} + TON_NM_ScriptP = procedure(Sender: TDTC40_Var_Client; Result_: TExpressionValueVector) is nested; +{$ELSE FPC} + TON_NM_ScriptP = reference to procedure(Sender: TDTC40_Var_Client; Result_: TExpressionValueVector); +{$ENDIF FPC} + + TON_NM_Script = class(TOnResultBridge) + public + Client: TDTC40_Var_Client; + OnResultC: TON_NM_ScriptC; + OnResultM: TON_NM_ScriptM; + OnResultP: TON_NM_ScriptP; + constructor Create; override; + procedure DoStreamParamEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); override; + procedure DoStreamFailedEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); override; + end; + + TDTC40_Var_Client = class(TDTC40_Base_NoAuth_Client) + protected + procedure cmd_NM_Change(Sender: TPeerIO; InData: TDFE); + public + NMBigPool: TVAR_Service_NMBigPool; + OnChange: TOnDTC40_Var_NM_Change; + constructor Create(source_: TDTC40_Info; Param_: U_String); override; + destructor Destroy; override; + function GetNM(Name_: U_String): TDTC40_VarService_NM_Pool; + + procedure NM_Init(Name_: U_String; Open_: Boolean; NMPool_: TNumberModulePool); + procedure NM_InitAsTemp(Name_: U_String; TimeOut_: TTimeTick; Open_: Boolean; NMPool_: TNumberModulePool); + procedure NM_Remove(Name_: U_String); + procedure NM_GetC(NMNames_: U_StringArray; OnResult: TON_NM_GetC); + procedure NM_GetM(NMNames_: U_StringArray; OnResult: TON_NM_GetM); + procedure NM_GetP(NMNames_: U_StringArray; OnResult: TON_NM_GetP); + procedure NM_GetValueC(NMName_: U_String; ValueNames_: U_StringArray; OnResult: TON_NM_GetValueC); + procedure NM_GetValueM(NMName_: U_String; ValueNames_: U_StringArray; OnResult: TON_NM_GetValueM); + procedure NM_GetValueP(NMName_: U_String; ValueNames_: U_StringArray; OnResult: TON_NM_GetValueP); + procedure NM_OpenC(NMNames_: U_StringArray; OnResult: TON_NM_OpenC); + procedure NM_OpenM(NMNames_: U_StringArray; OnResult: TON_NM_OpenM); + procedure NM_OpenP(NMNames_: U_StringArray; OnResult: TON_NM_OpenP); + procedure NM_Close(NMNames_: U_StringArray); + procedure NM_CloseAll; + procedure NM_Change(NMName_, ValueName_: U_String; Variant_: Variant); + procedure NM_Keep(NMName_: U_String); + procedure NM_ScriptC(NMName_: U_String; ExpressionTexts_: U_StringArray; OnResult: TON_NM_ScriptC); + procedure NM_ScriptM(NMName_: U_String; ExpressionTexts_: U_StringArray; OnResult: TON_NM_ScriptM); + procedure NM_ScriptP(NMName_: U_String; ExpressionTexts_: U_StringArray; OnResult: TON_NM_ScriptP); + end; + +implementation + +constructor TDTC40_VarService_NM_Pool.Create; +begin + inherited Create; + Name := ''; + Service := nil; + IO_ID_List := TIO_ID_List.Create; + IsTemp := False; + IsFreeing := False; + LifeTime := 0; + OverTime := 0; + LastAccessTime := 0; +end; + +destructor TDTC40_VarService_NM_Pool.Destroy; +begin + DisposeObject(IO_ID_List); + inherited Destroy; +end; + +procedure TDTC40_VarService_NM_Pool.DoNMChange(Sender: TNumberModule; OLD_, New_: Variant); +var + d: TDFE; + i: Integer; +begin + inherited DoNMChange(Sender, OLD_, New_); + if (Service <> nil) and (IO_ID_List.Count > 0) then + begin + d := TDFE.Create; + d.WriteString(Name); + d.WriteString(Sender.Name); + d.WriteNM(Sender); + for i := 0 to IO_ID_List.Count - 1 do + Service.DTNoAuthService.SendTunnel.SendDirectStreamCmd(IO_ID_List[i], 'NM_Change', d); + DisposeObject(d); + try + if Assigned(Service.OnChange) then + Service.OnChange(self, Sender); + except + end; + end; + if Client <> nil then + begin + try + if Assigned(Client.OnChange) then + Client.OnChange(self, Sender); + except + end; + end; +end; + +constructor TDTC40_Var_Service_IO_Define.Create(Owner_: TPeerIO); +begin + inherited Create(Owner_); + NM_List := TDTC40_Var_NumberModulePool_List.Create; +end; + +destructor TDTC40_Var_Service_IO_Define.Destroy; +begin + DisposeObject(NM_List); + inherited Destroy; +end; + +procedure TDTC40_Var_Service.DoLoading; +var + d: TDFE; + NMPool_: TDTC40_VarService_NM_Pool; +begin + IsLoading := True; + IsSaveing := False; + + NMBigPool.Clear; + + // run + try + d := TDFE.Create; + if umlFileExists(DTC40_Var_FileName) then + begin + d.LoadFromFile(DTC40_Var_FileName); + DoStatus('Load Variant database "%s"', [DTC40_Var_FileName.Text]); + end; + DoStatus('extract variant Database.'); + while d.R.NotEnd do + begin + NMPool_ := GetNM(d.R.ReadString); + d.R.ReadNMPool(NMPool_); + end; + DisposeObject(d); + DoStatus('extract variant Database done.'); + except + end; + + // done + IsLoading := False; +end; + +procedure TDTC40_Var_Service.DoBackground_Save(thSender: TCompute); +var + d: TDFE; +begin + try + d := TDFE(thSender.UserObject); + d.SaveToFile(DTC40_Var_FileName); + DisposeObject(d); + DoStatus('Save Variant Database Done.'); + except + end; + IsSaveing := False; +end; + +procedure TDTC40_Var_Service.DoUserOut_Event(Sender: TDTService_NoAuth; UserDefineIO: TPeerClientUserDefineForRecvTunnel_NoAuth); +var + IO_Def_: TDTC40_Var_Service_IO_Define; + i: Integer; +begin + inherited DoUserOut_Event(Sender, UserDefineIO); + IO_Def_ := UserDefineIO as TDTC40_Var_Service_IO_Define; + for i := 0 to IO_Def_.NM_List.Count - 1 do + IO_Def_.NM_List[i].IO_ID_List.Remove(IO_Def_.SendTunnelID); +end; + +procedure TDTC40_Var_Service.cmd_NM_Init(Sender: TPeerIO; InData: TDFE); +var + IODef_: TDTC40_Var_Service_IO_Define; + NM_Name: U_String; + Open_: Boolean; + NM: TDTC40_VarService_NM_Pool; +begin + IODef_ := DTNoAuthService.GetUserDefineRecvTunnel(Sender) as TDTC40_Var_Service_IO_Define; + if not IODef_.LinkOk then + begin + PrintError('no link'); + exit; + end; + NM_Name := InData.R.ReadString; + if NMBigPool.Exists(NM_Name) then + begin + PrintError('repeat number module "%s"', [NM_Name.Text]); + exit; + end; + // open change + NM := GetNM(NM_Name); + Open_ := InData.R.ReadBool; + if Open_ then + begin + if IODef_.NM_List.IndexOf(NM) < 0 then + IODef_.NM_List.Add(NM); + if NM.IO_ID_List.IndexOf(IODef_.SendTunnelID) < 0 then + NM.IO_ID_List.Add(IODef_.SendTunnelID); + end; + // load NM + InData.R.ReadNMPool(NM); +end; + +procedure TDTC40_Var_Service.cmd_NM_InitAsTemp(Sender: TPeerIO; InData: TDFE); +var + IODef_: TDTC40_Var_Service_IO_Define; + NM_Name: U_String; + NM_TimeOut: TTimeTick; + Open_: Boolean; + NM: TDTC40_VarService_NM_Pool; +begin + IODef_ := DTNoAuthService.GetUserDefineRecvTunnel(Sender) as TDTC40_Var_Service_IO_Define; + if not IODef_.LinkOk then + begin + PrintError('no link'); + exit; + end; + NM_Name := InData.R.ReadString; + NM_TimeOut := InData.R.ReadUInt64; + if NMBigPool.Exists(NM_Name) then + begin + PrintError('repeat number module "%s"', [NM_Name.Text]); + exit; + end; + // init temp NM + NM := GetNM(NM_Name); + NM.IsTemp := True; + NM.LifeTime := NM_TimeOut; + NM.OverTime := GetTimeTick + NM.LifeTime; + // open change + Open_ := InData.R.ReadBool; + if Open_ then + begin + if IODef_.NM_List.IndexOf(NM) < 0 then + IODef_.NM_List.Add(NM); + if NM.IO_ID_List.IndexOf(IODef_.SendTunnelID) < 0 then + NM.IO_ID_List.Add(IODef_.SendTunnelID); + end; + // load NM + InData.R.ReadNMPool(NM); +end; + +procedure TDTC40_Var_Service.cmd_NM_Remove(Sender: TPeerIO; InData: TDFE); +var + IODef_: TDTC40_Var_Service_IO_Define; + NM_Name: U_String; +begin + IODef_ := DTNoAuthService.GetUserDefineRecvTunnel(Sender) as TDTC40_Var_Service_IO_Define; + if not IODef_.LinkOk then + begin + PrintError('no link'); + exit; + end; + NM_Name := InData.R.ReadString; + if not NMBigPool.Exists(NM_Name) then + begin + PrintError('no exists number module "%s"', [NM_Name.Text]); + exit; + end; + try + if Assigned(OnRemove) then + OnRemove(GetNM(NM_Name)); + except + end; + NMBigPool.Delete(NM_Name); +end; + +procedure TDTC40_Var_Service.cmd_NM_Get(Sender: TPeerIO; InData, OutData: TDFE); +var + IODef_: TDTC40_Var_Service_IO_Define; + NM_Name: U_String; + NM: TDTC40_VarService_NM_Pool; +begin + IODef_ := DTNoAuthService.GetUserDefineRecvTunnel(Sender) as TDTC40_Var_Service_IO_Define; + if not IODef_.LinkOk then + begin + PrintError('no link'); + exit; + end; + while InData.R.NotEnd do + begin + NM_Name := InData.R.ReadString; + if NMBigPool.Exists(NM_Name) then + begin + NM := GetNM(NM_Name); + OutData.WriteString(NM_Name); + OutData.WriteNMPool(NM); + end + else + begin + PrintError('no exists number module "%s"', [NM_Name.Text]); + end; + end; +end; + +procedure TDTC40_Var_Service.cmd_NM_GetValue(Sender: TPeerIO; InData, OutData: TDFE); +var + IODef_: TDTC40_Var_Service_IO_Define; + NM_Name: U_String; + NM: TDTC40_VarService_NM_Pool; + VName_: U_String; +begin + IODef_ := DTNoAuthService.GetUserDefineRecvTunnel(Sender) as TDTC40_Var_Service_IO_Define; + if not IODef_.LinkOk then + begin + PrintError('no link'); + exit; + end; + NM_Name := InData.R.ReadString; + if not NMBigPool.Exists(NM_Name) then + begin + PrintError('no exists number module "%s"', [NM_Name.Text]); + exit; + end; + NM := GetNM(NM_Name); + while InData.R.NotEnd do + begin + VName_ := InData.R.ReadString; + if NM.Exists(VName_) then + begin + OutData.WriteString(VName_); + OutData.WriteNM(NM[VName_]); + end + else + begin + PrintError('no exists number module "%s" Name "%s"', [NM_Name.Text, VName_.Text]); + end; + end; +end; + +procedure TDTC40_Var_Service.cmd_NM_Open(Sender: TPeerIO; InData, OutData: TDFE); +var + IODef_: TDTC40_Var_Service_IO_Define; + NM_Name: U_String; + NM: TDTC40_VarService_NM_Pool; +begin + IODef_ := DTNoAuthService.GetUserDefineRecvTunnel(Sender) as TDTC40_Var_Service_IO_Define; + if not IODef_.LinkOk then + begin + PrintError('no link'); + exit; + end; + while InData.R.NotEnd do + begin + NM_Name := InData.R.ReadString; + if NMBigPool.Exists(NM_Name) then + begin + NM := GetNM(NM_Name); + OutData.WriteString(NM_Name); + OutData.WriteNMPool(NM); + if IODef_.NM_List.IndexOf(NM) < 0 then + IODef_.NM_List.Add(NM); + if NM.IO_ID_List.IndexOf(IODef_.SendTunnelID) < 0 then + NM.IO_ID_List.Add(IODef_.SendTunnelID); + end + else + begin + PrintError('no exists number module "%s"', [NM_Name.Text]); + end; + end; +end; + +procedure TDTC40_Var_Service.cmd_NM_Close(Sender: TPeerIO; InData: TDFE); +var + IODef_: TDTC40_Var_Service_IO_Define; + NM_Name: U_String; + NM: TDTC40_VarService_NM_Pool; +begin + IODef_ := DTNoAuthService.GetUserDefineRecvTunnel(Sender) as TDTC40_Var_Service_IO_Define; + if not IODef_.LinkOk then + begin + PrintError('no link'); + exit; + end; + while InData.R.NotEnd do + begin + NM_Name := InData.R.ReadString; + if NMBigPool.Exists(NM_Name) then + begin + NM := GetNM(NM_Name); + NM.IO_ID_List.Remove(IODef_.SendTunnelID); + IODef_.NM_List.Remove(NM); + end + else + begin + PrintError('no exists number module "%s"', [NM_Name.Text]); + end; + end; +end; + +procedure TDTC40_Var_Service.cmd_NM_CloseAll(Sender: TPeerIO; InData: TDFE); +var + IODef_: TDTC40_Var_Service_IO_Define; + i: Integer; +begin + IODef_ := DTNoAuthService.GetUserDefineRecvTunnel(Sender) as TDTC40_Var_Service_IO_Define; + if not IODef_.LinkOk then + begin + PrintError('no link'); + exit; + end; + for i := 0 to IODef_.NM_List.Count - 1 do + IODef_.NM_List[i].IO_ID_List.Remove(IODef_.SendTunnelID); + IODef_.NM_List.Clear; +end; + +procedure TDTC40_Var_Service.cmd_NM_Change(Sender: TPeerIO; InData: TDFE); +var + IODef_: TDTC40_Var_Service_IO_Define; + NM_Name: U_String; + NM: TDTC40_VarService_NM_Pool; + VName_: U_String; + v: Variant; +begin + IODef_ := DTNoAuthService.GetUserDefineRecvTunnel(Sender) as TDTC40_Var_Service_IO_Define; + if not IODef_.LinkOk then + begin + PrintError('no link'); + exit; + end; + NM_Name := InData.R.ReadString; + if not NMBigPool.Exists(NM_Name) then + begin + PrintError('no exists number module "%s"', [NM_Name.Text]); + exit; + end; + NM := GetNM(NM_Name); + VName_ := InData.R.ReadString; + v := InData.R.ReadVariant; + if NM.Exists(VName_) then + NM[VName_].CurrentValue := v + else + NM[VName_].OriginValue := v; + if NM.IsTemp then + NM.OverTime := GetTimeTick + NM.LifeTime; +end; + +procedure TDTC40_Var_Service.cmd_NM_Keep(Sender: TPeerIO; InData: TDFE); +var + IODef_: TDTC40_Var_Service_IO_Define; + NM_Name: U_String; + NM: TDTC40_VarService_NM_Pool; +begin + IODef_ := DTNoAuthService.GetUserDefineRecvTunnel(Sender) as TDTC40_Var_Service_IO_Define; + if not IODef_.LinkOk then + begin + PrintError('no link'); + exit; + end; + NM_Name := InData.R.ReadString; + if not NMBigPool.Exists(NM_Name) then + begin + PrintError('no exists number module "%s"', [NM_Name.Text]); + exit; + end; + NM := GetNM(NM_Name); + if NM.IsTemp then + NM.OverTime := GetTimeTick + NM.LifeTime; +end; + +procedure TDTC40_Var_Service.cmd_NM_Script(Sender: TPeerIO; InData, OutData: TDFE); +var + IODef_: TDTC40_Var_Service_IO_Define; + NM_Name: U_String; + NM: TDTC40_VarService_NM_Pool; + Exp_: U_String; + Vec_: TExpressionValueVector; + i: Integer; +begin + IODef_ := DTNoAuthService.GetUserDefineRecvTunnel(Sender) as TDTC40_Var_Service_IO_Define; + if not IODef_.LinkOk then + begin + PrintError('no link'); + exit; + end; + NM_Name := InData.R.ReadString; + NM := GetNM(NM_Name); + try + while InData.R.NotEnd do + begin + Exp_ := InData.R.ReadString; + if NM.IsVectorScript(Exp_) then + begin + Vec_ := NM.RunVectorScript(Exp_); + for i := 0 to length(Vec_) - 1 do + OutData.WriteVariant(Vec_[i]); + SetLength(Vec_, 0); + end + else + OutData.WriteVariant(NM.RunScript(Exp_)); + end; + except + end; + if NM.IsTemp then + NM.OverTime := GetTimeTick + NM.LifeTime; +end; + +procedure TDTC40_Var_Service.Progress_NMPool(const Name: PSystemString; Obj: TDTC40_VarService_NM_Pool); +begin + if (Obj.IsTemp) and (not Obj.IsFreeing) and (Obj.OverTime < GetTimeTick) then + begin + Obj.IsFreeing := True; + ProgressTempNMList.Add(Obj); + end; +end; + +constructor TDTC40_Var_Service.Create(PhysicsService_: TDTC40_PhysicsService; ServiceTyp, Param_: U_String); +begin + inherited Create(PhysicsService_, ServiceTyp, Param_); + ServiceInfo.OnlyInstance := True; + DTNoAuthService.RecvTunnel.RegisterDirectStream('NM_Init').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_NM_Init; + DTNoAuthService.RecvTunnel.RegisterDirectStream('NM_InitAsTemp').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_NM_InitAsTemp; + DTNoAuthService.RecvTunnel.RegisterDirectStream('NM_Remove').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_NM_Remove; + DTNoAuthService.RecvTunnel.RegisterStream('NM_Get').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_NM_Get; + DTNoAuthService.RecvTunnel.RegisterStream('NM_GetValue').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_NM_GetValue; + DTNoAuthService.RecvTunnel.RegisterStream('NM_Open').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_NM_Open; + DTNoAuthService.RecvTunnel.RegisterDirectStream('NM_Close').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_NM_Close; + DTNoAuthService.RecvTunnel.RegisterDirectStream('NM_CloseAll').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_NM_CloseAll; + DTNoAuthService.RecvTunnel.RegisterDirectStream('NM_Change').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_NM_Change; + DTNoAuthService.RecvTunnel.RegisterDirectStream('NM_Keep').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_NM_Keep; + DTNoAuthService.RecvTunnel.RegisterStream('NM_Script').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_NM_Script; + DTNoAuthService.RecvTunnel.PeerIOUserDefineClass := TDTC40_Var_Service_IO_Define; + UpdateToGlobalDispatch; + ProgressTempNMList := TDTC40_Var_NumberModulePool_List.Create; + DTC40_Var_FileName := umlCombineFileName(DTNoAuthService.PublicFileDirectory, PFormat('DTC40_%s.DFE', [ServiceInfo.ServiceTyp.Text])); + NMBigPool := TVAR_Service_NMBigPool.Create(True, 1024 * 1024, nil); + OnChange := nil; + OnRemove := nil; + + if umlFileExists(DTC40_Var_FileName) then + DoLoading(); +end; + +destructor TDTC40_Var_Service.Destroy; +begin + DisposeObject(ProgressTempNMList); + DisposeObject(NMBigPool); + inherited Destroy; +end; + +procedure TDTC40_Var_Service.SafeCheck; +var + d: TDFE; +begin + inherited SafeCheck; + if IsSaveing then + exit; + DoStatus('Extract Variant data.'); + IsSaveing := True; + d := TDFE.Create; + SaveNMBigPoolAsDFE(d); + DoStatus('Save Variant Database.'); + TCompute.RunM(nil, d, {$IFDEF FPC}@{$ENDIF FPC}DoBackground_Save); +end; + +procedure TDTC40_Var_Service.Progress; +var + i: Integer; +begin + inherited Progress; + + ProgressTempNMList.Clear; + NMBigPool.ProgressM({$IFDEF FPC}@{$ENDIF FPC}Progress_NMPool); + try + for i := 0 to ProgressTempNMList.Count - 1 do + begin + try + if Assigned(OnRemove) then + OnRemove(ProgressTempNMList[i]); + except + end; + RemoveNumberModulePool(ProgressTempNMList[i]); + NMBigPool.Delete(ProgressTempNMList[i].Name); + end; + except + end; + ProgressTempNMList.Clear; +end; + +function TDTC40_Var_Service.GetNM(Name_: U_String): TDTC40_VarService_NM_Pool; +begin + Result := NMBigPool[Name_]; + if Result = nil then + begin + Result := TDTC40_VarService_NM_Pool.Create; + Result.Name := Name_; + Result.Service := self; + NMBigPool.FastAdd(Name_, Result); + end; + Result.LastAccessTime := umlNow; +end; + +procedure TDTC40_Var_Service.RemoveNumberModulePool(NM: TDTC40_VarService_NM_Pool); +var + Arry: TIO_Array; + ID_: Cardinal; + IO_: TPeerIO; + IODef_: TDTC40_Var_Service_IO_Define; +begin + DoStatus('remove NM "%s"', [NM.Name.Text]); + DTNoAuthService.RecvTunnel.GetIO_Array(Arry); + for ID_ in Arry do + begin + IO_ := DTNoAuthService.RecvTunnel[ID_]; + if IO_ <> nil then + begin + IODef_ := IO_.IODefine as TDTC40_Var_Service_IO_Define; + IODef_.NM_List.Remove(NM); + end; + end; +end; + +procedure TDTC40_Var_Service.SaveNMBigPoolAsDFE(DFE: TDFE); +{$IFDEF FPC} + procedure fpc_Progress_(const Name: PSystemString; Obj: TDTC40_VarService_NM_Pool); + begin + if Obj.IsTemp then + exit; + DFE.WriteString(Obj.Name); + DFE.WriteNMPool(Obj); + end; +{$ENDIF FPC} + + +begin +{$IFDEF FPC} + NMBigPool.ProgressP(@fpc_Progress_); +{$ELSE FPC} + NMBigPool.ProgressP( + procedure(const Name: PSystemString; Obj: TDTC40_VarService_NM_Pool) + begin + if Obj.IsTemp then + exit; + DFE.WriteString(Obj.Name); + DFE.WriteNMPool(Obj); + end); +{$ENDIF FPC} +end; + +procedure TDTC40_Var_Service.PrintError(v: SystemString); +begin + DTC40PhysicsService.PhysicsTunnel.PrintError(v); +end; + +procedure TDTC40_Var_Service.PrintError(v: SystemString; const Args: array of const); +begin + PrintError(PFormat(v, Args)); +end; + +constructor TON_NM_Get.Create; +begin + inherited Create; + Client := nil; + OnResultC := nil; + OnResultM := nil; + OnResultP := nil; +end; + +procedure TON_NM_Get.DoStreamParamEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); +var + NM_Pool_: TDTC40_VarService_NM_Pool; +begin + while Result_.R.NotEnd do + begin + NM_Pool_ := Client.GetNM(Result_.R.ReadString); + Result_.R.ReadNMPool(NM_Pool_); + + try + if Assigned(OnResultC) then + OnResultC(Client, NM_Pool_); + if Assigned(OnResultM) then + OnResultM(Client, NM_Pool_); + if Assigned(OnResultP) then + OnResultP(Client, NM_Pool_); + except + end; + end; + DelayFreeObject(1.0, self); +end; + +procedure TON_NM_Get.DoStreamFailedEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); +begin + try + if Assigned(OnResultC) then + OnResultC(Client, nil); + if Assigned(OnResultM) then + OnResultM(Client, nil); + if Assigned(OnResultP) then + OnResultP(Client, nil); + except + end; + DelayFreeObject(1.0, self); +end; + +constructor TON_NM_GetValue.Create; +begin + inherited Create; + Client := nil; + NM_Name := ''; + OnResultC := nil; + OnResultM := nil; + OnResultP := nil; +end; + +procedure TON_NM_GetValue.DoStreamParamEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); +var + NM_Pool_: TDTC40_VarService_NM_Pool; + NM_: TNumberModule; +begin + NM_Pool_ := Client.GetNM(NM_Name); + while Result_.R.NotEnd do + begin + NM_ := NM_Pool_[Result_.R.ReadString]; + Result_.R.ReadNM(NM_); + + try + if Assigned(OnResultC) then + OnResultC(Client, NM_); + if Assigned(OnResultM) then + OnResultM(Client, NM_); + if Assigned(OnResultP) then + OnResultP(Client, NM_); + except + end; + end; + DelayFreeObject(1.0, self); +end; + +procedure TON_NM_GetValue.DoStreamFailedEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); +begin + try + if Assigned(OnResultC) then + OnResultC(Client, nil); + if Assigned(OnResultM) then + OnResultM(Client, nil); + if Assigned(OnResultP) then + OnResultP(Client, nil); + except + end; + DelayFreeObject(1.0, self); +end; + +constructor TON_NM_Open.Create; +begin + inherited Create; + Client := nil; + OnResultC := nil; + OnResultM := nil; + OnResultP := nil; +end; + +procedure TON_NM_Open.DoStreamParamEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); +var + NM_Pool_: TDTC40_VarService_NM_Pool; +begin + while Result_.R.NotEnd do + begin + NM_Pool_ := Client.GetNM(Result_.R.ReadString); + Result_.R.ReadNMPool(NM_Pool_); + + try + if Assigned(OnResultC) then + OnResultC(Client, NM_Pool_); + if Assigned(OnResultM) then + OnResultM(Client, NM_Pool_); + if Assigned(OnResultP) then + OnResultP(Client, NM_Pool_); + except + end; + end; + DelayFreeObject(1.0, self); +end; + +procedure TON_NM_Open.DoStreamFailedEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); +begin + try + if Assigned(OnResultC) then + OnResultC(Client, nil); + if Assigned(OnResultM) then + OnResultM(Client, nil); + if Assigned(OnResultP) then + OnResultP(Client, nil); + except + end; + DelayFreeObject(1.0, self); +end; + +constructor TON_NM_Script.Create; +begin + inherited Create; + Client := nil; + OnResultC := nil; + OnResultM := nil; + OnResultP := nil; +end; + +procedure TON_NM_Script.DoStreamParamEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData, Result_: TDFE); +var + tmp: TExpressionValueVector; + i: Integer; +begin + SetLength(tmp, Result_.Count); + for i := 0 to Result_.Count - 1 do + tmp[i] := Result_.ReadVariant(i); + try + if Assigned(OnResultC) then + OnResultC(Client, tmp); + if Assigned(OnResultM) then + OnResultM(Client, tmp); + if Assigned(OnResultP) then + OnResultP(Client, tmp); + except + end; + SetLength(tmp, 0); + DelayFreeObject(1.0, self); +end; + +procedure TON_NM_Script.DoStreamFailedEvent(Sender: TPeerIO; Param1: Pointer; Param2: TObject; SendData: TDFE); +var + tmp: TExpressionValueVector; +begin + SetLength(tmp, 0); + try + if Assigned(OnResultC) then + OnResultC(Client, tmp); + if Assigned(OnResultM) then + OnResultM(Client, tmp); + if Assigned(OnResultP) then + OnResultP(Client, tmp); + except + end; + DelayFreeObject(1.0, self); +end; + +procedure TDTC40_Var_Client.cmd_NM_Change(Sender: TPeerIO; InData: TDFE); +var + NMPoolName_, ValueName_: U_String; + NMPool_: TDTC40_VarService_NM_Pool; + NM_: TNumberModule; +begin + NMPoolName_ := InData.R.ReadString; + ValueName_ := InData.R.ReadString; + NMPool_ := GetNM(NMPoolName_); + NM_ := NMPool_[ValueName_]; + InData.R.ReadNM(NM_); + NM_.DoChange; +end; + +constructor TDTC40_Var_Client.Create(source_: TDTC40_Info; Param_: U_String); +begin + inherited Create(source_, Param_); + DTNoAuthClient.RecvTunnel.RegisterDirectStream('NM_Change').OnExecute := {$IFDEF FPC}@{$ENDIF FPC}cmd_NM_Change; + NMBigPool := TVAR_Service_NMBigPool.Create(True, 1024, nil); + OnChange := nil; +end; + +destructor TDTC40_Var_Client.Destroy; +begin + DisposeObject(NMBigPool); + inherited Destroy; +end; + +function TDTC40_Var_Client.GetNM(Name_: U_String): TDTC40_VarService_NM_Pool; +begin + Result := NMBigPool[Name_]; + if Result = nil then + begin + Result := TDTC40_VarService_NM_Pool.Create; + Result.Name := Name_; + Result.Client := self; + NMBigPool.FastAdd(Name_, Result); + end; + Result.LastAccessTime := umlNow; +end; + +procedure TDTC40_Var_Client.NM_Init(Name_: U_String; Open_: Boolean; NMPool_: TNumberModulePool); +var + d: TDFE; +begin + d := TDFE.Create; + d.WriteString(Name_); + d.WriteBool(Open_); + d.WriteNMPool(NMPool_); + DTNoAuthClient.SendTunnel.SendDirectStreamCmd('NM_Init', d); + DisposeObject(d); +end; + +procedure TDTC40_Var_Client.NM_InitAsTemp(Name_: U_String; TimeOut_: TTimeTick; Open_: Boolean; NMPool_: TNumberModulePool); +var + d: TDFE; +begin + d := TDFE.Create; + d.WriteString(Name_); + d.WriteUInt64(TimeOut_); + d.WriteBool(Open_); + d.WriteNMPool(NMPool_); + DTNoAuthClient.SendTunnel.SendDirectStreamCmd('NM_InitAsTemp', d); + DisposeObject(d); +end; + +procedure TDTC40_Var_Client.NM_Remove(Name_: U_String); +var + d: TDFE; +begin + d := TDFE.Create; + d.WriteString(Name_); + DTNoAuthClient.SendTunnel.SendDirectStreamCmd('NM_Remove', d); + DisposeObject(d); +end; + +procedure TDTC40_Var_Client.NM_GetC(NMNames_: U_StringArray; OnResult: TON_NM_GetC); +var + d: TDFE; + i: Integer; + tmp: TON_NM_Get; +begin + d := TDFE.Create; + for i := 0 to length(NMNames_) - 1 do + d.WriteString(NMNames_[i]); + tmp := TON_NM_Get.Create; + tmp.Client := self; + tmp.OnResultC := OnResult; + DTNoAuthClient.SendTunnel.SendStreamCmdM('NM_Get', d, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + DisposeObject(d); +end; + +procedure TDTC40_Var_Client.NM_GetM(NMNames_: U_StringArray; OnResult: TON_NM_GetM); +var + d: TDFE; + i: Integer; + tmp: TON_NM_Get; +begin + d := TDFE.Create; + for i := 0 to length(NMNames_) - 1 do + d.WriteString(NMNames_[i]); + tmp := TON_NM_Get.Create; + tmp.Client := self; + tmp.OnResultM := OnResult; + DTNoAuthClient.SendTunnel.SendStreamCmdM('NM_Get', d, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + DisposeObject(d); +end; + +procedure TDTC40_Var_Client.NM_GetP(NMNames_: U_StringArray; OnResult: TON_NM_GetP); +var + d: TDFE; + i: Integer; + tmp: TON_NM_Get; +begin + d := TDFE.Create; + for i := 0 to length(NMNames_) - 1 do + d.WriteString(NMNames_[i]); + tmp := TON_NM_Get.Create; + tmp.Client := self; + tmp.OnResultP := OnResult; + DTNoAuthClient.SendTunnel.SendStreamCmdM('NM_Get', d, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + DisposeObject(d); +end; + +procedure TDTC40_Var_Client.NM_GetValueC(NMName_: U_String; ValueNames_: U_StringArray; OnResult: TON_NM_GetValueC); +var + d: TDFE; + i: Integer; + tmp: TON_NM_GetValue; +begin + d := TDFE.Create; + d.WriteString(NMName_); + for i := 0 to length(ValueNames_) - 1 do + d.WriteString(ValueNames_[i]); + tmp := TON_NM_GetValue.Create; + tmp.Client := self; + tmp.NM_Name := NMName_; + tmp.OnResultC := OnResult; + DTNoAuthClient.SendTunnel.SendStreamCmdM('NM_GetValue', d, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + DisposeObject(d); +end; + +procedure TDTC40_Var_Client.NM_GetValueM(NMName_: U_String; ValueNames_: U_StringArray; OnResult: TON_NM_GetValueM); +var + d: TDFE; + i: Integer; + tmp: TON_NM_GetValue; +begin + d := TDFE.Create; + d.WriteString(NMName_); + for i := 0 to length(ValueNames_) - 1 do + d.WriteString(ValueNames_[i]); + tmp := TON_NM_GetValue.Create; + tmp.Client := self; + tmp.NM_Name := NMName_; + tmp.OnResultM := OnResult; + DTNoAuthClient.SendTunnel.SendStreamCmdM('NM_GetValue', d, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + DisposeObject(d); +end; + +procedure TDTC40_Var_Client.NM_GetValueP(NMName_: U_String; ValueNames_: U_StringArray; OnResult: TON_NM_GetValueP); +var + d: TDFE; + i: Integer; + tmp: TON_NM_GetValue; +begin + d := TDFE.Create; + d.WriteString(NMName_); + for i := 0 to length(ValueNames_) - 1 do + d.WriteString(ValueNames_[i]); + tmp := TON_NM_GetValue.Create; + tmp.Client := self; + tmp.NM_Name := NMName_; + tmp.OnResultP := OnResult; + DTNoAuthClient.SendTunnel.SendStreamCmdM('NM_GetValue', d, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + DisposeObject(d); +end; + +procedure TDTC40_Var_Client.NM_OpenC(NMNames_: U_StringArray; OnResult: TON_NM_OpenC); +var + d: TDFE; + i: Integer; + tmp: TON_NM_Open; +begin + d := TDFE.Create; + for i := 0 to length(NMNames_) - 1 do + d.WriteString(NMNames_[i]); + tmp := TON_NM_Open.Create; + tmp.Client := self; + tmp.OnResultC := OnResult; + DTNoAuthClient.SendTunnel.SendStreamCmdM('NM_Open', d, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + DisposeObject(d); +end; + +procedure TDTC40_Var_Client.NM_OpenM(NMNames_: U_StringArray; OnResult: TON_NM_OpenM); +var + d: TDFE; + i: Integer; + tmp: TON_NM_Open; +begin + d := TDFE.Create; + for i := 0 to length(NMNames_) - 1 do + d.WriteString(NMNames_[i]); + tmp := TON_NM_Open.Create; + tmp.Client := self; + tmp.OnResultM := OnResult; + DTNoAuthClient.SendTunnel.SendStreamCmdM('NM_Open', d, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + DisposeObject(d); +end; + +procedure TDTC40_Var_Client.NM_OpenP(NMNames_: U_StringArray; OnResult: TON_NM_OpenP); +var + d: TDFE; + i: Integer; + tmp: TON_NM_Open; +begin + d := TDFE.Create; + for i := 0 to length(NMNames_) - 1 do + d.WriteString(NMNames_[i]); + tmp := TON_NM_Open.Create; + tmp.Client := self; + tmp.OnResultP := OnResult; + DTNoAuthClient.SendTunnel.SendStreamCmdM('NM_Open', d, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + DisposeObject(d); +end; + +procedure TDTC40_Var_Client.NM_Close(NMNames_: U_StringArray); +var + d: TDFE; + i: Integer; +begin + d := TDFE.Create; + for i := 0 to length(NMNames_) - 1 do + d.WriteString(NMNames_[i]); + DTNoAuthClient.SendTunnel.SendDirectStreamCmd('NM_Close', d); + DisposeObject(d); +end; + +procedure TDTC40_Var_Client.NM_CloseAll; +begin + DTNoAuthClient.SendTunnel.SendDirectStreamCmd('NM_CloseAll'); +end; + +procedure TDTC40_Var_Client.NM_Change(NMName_, ValueName_: U_String; Variant_: Variant); +var + d: TDFE; +begin + d := TDFE.Create; + d.WriteString(NMName_); + d.WriteString(ValueName_); + d.WriteVariant(Variant_); + DTNoAuthClient.SendTunnel.SendDirectStreamCmd('NM_Change', d); + DisposeObject(d); +end; + +procedure TDTC40_Var_Client.NM_Keep(NMName_: U_String); +var + d: TDFE; +begin + d := TDFE.Create; + d.WriteString(NMName_); + DTNoAuthClient.SendTunnel.SendDirectStreamCmd('NM_Keep', d); + DisposeObject(d); +end; + +procedure TDTC40_Var_Client.NM_ScriptC(NMName_: U_String; ExpressionTexts_: U_StringArray; OnResult: TON_NM_ScriptC); +var + d: TDFE; + i: Integer; + tmp: TON_NM_Script; +begin + d := TDFE.Create; + d.WriteString(NMName_); + for i := 0 to length(ExpressionTexts_) - 1 do + d.WriteString(ExpressionTexts_[i]); + tmp := TON_NM_Script.Create; + tmp.Client := self; + tmp.OnResultC := OnResult; + DTNoAuthClient.SendTunnel.SendStreamCmdM('NM_Script', d, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + DisposeObject(d); +end; + +procedure TDTC40_Var_Client.NM_ScriptM(NMName_: U_String; ExpressionTexts_: U_StringArray; OnResult: TON_NM_ScriptM); +var + d: TDFE; + i: Integer; + tmp: TON_NM_Script; +begin + d := TDFE.Create; + d.WriteString(NMName_); + for i := 0 to length(ExpressionTexts_) - 1 do + d.WriteString(ExpressionTexts_[i]); + tmp := TON_NM_Script.Create; + tmp.Client := self; + tmp.OnResultM := OnResult; + DTNoAuthClient.SendTunnel.SendStreamCmdM('NM_Script', d, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + DisposeObject(d); +end; + +procedure TDTC40_Var_Client.NM_ScriptP(NMName_: U_String; ExpressionTexts_: U_StringArray; OnResult: TON_NM_ScriptP); +var + d: TDFE; + i: Integer; + tmp: TON_NM_Script; +begin + d := TDFE.Create; + d.WriteString(NMName_); + for i := 0 to length(ExpressionTexts_) - 1 do + d.WriteString(ExpressionTexts_[i]); + tmp := TON_NM_Script.Create; + tmp.Client := self; + tmp.OnResultP := OnResult; + DTNoAuthClient.SendTunnel.SendStreamCmdM('NM_Script', d, nil, nil, +{$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamParamEvent, {$IFDEF FPC}@{$ENDIF FPC}tmp.DoStreamFailedEvent); + DisposeObject(d); +end; + +initialization + +RegisterC40('Var', TDTC40_Var_Service, TDTC40_Var_Client); +RegisterC40('Var0', TDTC40_Var_Service, TDTC40_Var_Client); +RegisterC40('Var1', TDTC40_Var_Service, TDTC40_Var_Client); +RegisterC40('Var2', TDTC40_Var_Service, TDTC40_Var_Client); +RegisterC40('Var3', TDTC40_Var_Service, TDTC40_Var_Client); +RegisterC40('Var4', TDTC40_Var_Service, TDTC40_Var_Client); +RegisterC40('Var5', TDTC40_Var_Service, TDTC40_Var_Client); +RegisterC40('Var6', TDTC40_Var_Service, TDTC40_Var_Client); +RegisterC40('Var7', TDTC40_Var_Service, TDTC40_Var_Client); +RegisterC40('Var8', TDTC40_Var_Service, TDTC40_Var_Client); +RegisterC40('Var9', TDTC40_Var_Service, TDTC40_Var_Client); + +end. diff --git a/Source/DataFrameEngine.pas b/Source/DataFrameEngine.pas index 777b0b82..d07978f2 100644 --- a/Source/DataFrameEngine.pas +++ b/Source/DataFrameEngine.pas @@ -17,11 +17,6 @@ { * https://github.com/PassByYou888/InfiniteIoT * } { * https://github.com/PassByYou888/FastMD5 * } { ****************************************************************************** } -(* - update history - 2017-12-6 - added supported pointer -*) unit DataFrameEngine; @@ -29,10 +24,10 @@ interface -uses SysUtils, CoreClasses, Types, +uses SysUtils, CoreClasses, Types, Variants, ListEngine, MemoryStream64, CoreCipher, DoStatusIO, GeometryLib, TextDataEngine, Geometry2DUnit, Geometry3DUnit, - ZJson, + ZJson, NumberBase, {$IFDEF DELPHI} ZS_JsonDataObjects, {$ENDIF DELPHI} @@ -229,15 +224,16 @@ TDataFrameArrayByte = class sealed(TDataFrameBase) procedure Clear; procedure Add(v: Byte); - procedure AddPtrBuff(p: PByte; Size: Integer); + procedure AddPtrBuff(p: PByte; Size_: Integer); procedure AddI64(v: Int64); procedure AddU64(v: UInt64); procedure Addi(v: Integer); procedure AddWord(v: Word); - function Count: Integer; + function Count: Int64; + property Size: Int64 read Count; procedure WriteArray(const a: array of Byte); procedure SetArray(const a: array of Byte); - procedure SetBuff(p: PByte; Size: Integer); + procedure SetBuff(p: PByte; Size_: Integer); procedure GetBuff(p: PByte); procedure LoadFromStream(stream: TCoreClassStream); override; @@ -458,6 +454,8 @@ TDataFrameEngineReader = class(TCoreClassObject) function ReadVec2: TVec2; function ReadRectV2: TRectV2; function ReadPointer: UInt64; + procedure ReadNM(output: TNumberModule); + procedure ReadNMPool(output: TNumberModulePool); // auto read from stream data procedure Read(var Buf_; Count_: Int64); overload; // read as TDataFrameBase @@ -466,11 +464,11 @@ TDataFrameEngineReader = class(TCoreClassObject) function Current: TDataFrameBase; end; + TRunTimeDataType = (rdtString, rdtInteger, rdtLongWord, rdtWORD, rdtByte, rdtSingle, rdtDouble, + rdtArrayInteger, rdtArraySingle, rdtArrayDouble, rdtStream, rdtVariant, rdtInt64, rdtArrayShortInt, rdtCardinal, rdtUInt64, rdtArrayByte, + rdtArrayInt64); + TDataFrameEngine = class(TCoreClassObject) - public type - TRunTimeDataType = (rdtString, rdtInteger, rdtLongWord, rdtWORD, rdtByte, rdtSingle, rdtDouble, - rdtArrayInteger, rdtArraySingle, rdtArrayDouble, rdtStream, rdtVariant, rdtInt64, rdtArrayShortInt, rdtCardinal, rdtUInt64, rdtArrayByte, - rdtArrayInt64); private FDataList: TCoreClassListForObj; FReader: TDataFrameEngineReader; @@ -556,6 +554,8 @@ TDataFrameEngine = class(TCoreClassObject) procedure WriteRectV2(v: TRectV2); procedure WritePointer(v: Pointer); overload; procedure WritePointer(v: UInt64); overload; + procedure WriteNM(NM: TNumberModule); + procedure WriteNMPool(NMPool: TNumberModulePool); // auto append new stream and write procedure write(const Buf_; Count_: Int64); // @@ -608,6 +608,8 @@ TDataFrameEngine = class(TCoreClassObject) function ReadVec2(index_: Integer): TVec2; function ReadRectV2(index_: Integer): TRectV2; function ReadPointer(index_: Integer): UInt64; + procedure ReadNM(index_: Integer; output: TNumberModule); + procedure ReadNMPool(index_: Integer; output: TNumberModulePool); // read from stream data procedure Read(index_: Integer; var Buf_; Count_: Int64); overload; // read as TDataFrameBase @@ -671,6 +673,9 @@ TDataFrameEngine = class(TCoreClassObject) procedure LoadFromStream(stream: TCoreClassStream); procedure SaveToStream(stream: TCoreClassStream); + procedure LoadFromFile(fileName_: U_String); + procedure SaveToFile(fileName_: U_String); + property Data[index_: Integer]: TDataFrameBase read GetData; default; property List: TCoreClassListForObj read FDataList; end; @@ -733,6 +738,8 @@ TDataWriter = class(TCoreClassObject) procedure WriteVec2(v: TVec2); procedure WriteRectV2(v: TRectV2); procedure WritePointer(v: Pointer); + procedure WriteNM(NM: TNumberModule); + procedure WriteNMPool(NMPool: TNumberModulePool); procedure write(const Buf_; Count_: Int64); end; @@ -790,6 +797,8 @@ TDataReader = class(TCoreClassObject) function ReadVec2: TVec2; function ReadRectV2: TRectV2; function ReadPointer: UInt64; + procedure ReadNM(output: TNumberModule); + procedure ReadNMPool(output: TNumberModulePool); procedure Read(var Buf_; Count_: Int64); end; @@ -1275,10 +1284,10 @@ procedure TDataFrameArrayByte.Add(v: Byte); FBuffer.WriteUInt8(v); end; -procedure TDataFrameArrayByte.AddPtrBuff(p: PByte; Size: Integer); +procedure TDataFrameArrayByte.AddPtrBuff(p: PByte; Size_: Integer); begin FBuffer.Position := FBuffer.Size; - FBuffer.WritePtr(p, Size); + FBuffer.WritePtr(p, Size_); end; procedure TDataFrameArrayByte.AddI64(v: Int64); @@ -1301,7 +1310,7 @@ procedure TDataFrameArrayByte.AddWord(v: Word); AddPtrBuff(@v, C_Word_Size); end; -function TDataFrameArrayByte.Count: Integer; +function TDataFrameArrayByte.Count: Int64; begin Result := FBuffer.Size; end; @@ -1319,10 +1328,10 @@ procedure TDataFrameArrayByte.SetArray(const a: array of Byte); AddPtrBuff(@a[0], length(a)); end; -procedure TDataFrameArrayByte.SetBuff(p: PByte; Size: Integer); +procedure TDataFrameArrayByte.SetBuff(p: PByte; Size_: Integer); begin Clear; - AddPtrBuff(p, Size); + AddPtrBuff(p, Size_); end; procedure TDataFrameArrayByte.GetBuff(p: PByte); @@ -1751,6 +1760,7 @@ procedure TDataFrameVariant.LoadFromStream(stream: TCoreClassStream); begin vt := TVarType(StreamReadUInt16(stream)); case vt of + varEmpty, varNull: FBuffer := NULL; varSmallInt: FBuffer := StreamReadInt16(stream); varInteger: FBuffer := StreamReadInt32(stream); varSingle: FBuffer := StreamReadSingle(stream); @@ -1775,6 +1785,7 @@ procedure TDataFrameVariant.SaveToStream(stream: TCoreClassStream); vt := TVarData(FBuffer).VType; StreamWriteUInt16(stream, Word(vt)); case vt of + varEmpty, varNull:; varSmallInt: StreamWriteInt16(stream, FBuffer); varInteger: StreamWriteInt32(stream, FBuffer); varSingle: StreamWriteSingle(stream, FBuffer); @@ -1806,6 +1817,7 @@ procedure TDataFrameVariant.SaveToJson(jarry: TZ_JsonArray; index_: Integer); function TDataFrameVariant.ComputeEncodeSize: Int64; begin case TVarData(FBuffer).VType of + varEmpty, varNull: Result := 2 + 0; varSmallInt: Result := 2 + 2; varInteger: Result := 2 + 4; varSingle: Result := 2 + 4; @@ -2208,6 +2220,18 @@ function TDataFrameEngineReader.ReadPointer: UInt64; inc(FIndex); end; +procedure TDataFrameEngineReader.ReadNM(output: TNumberModule); +begin + FOwner.ReadNM(FIndex, output); + inc(FIndex); +end; + +procedure TDataFrameEngineReader.ReadNMPool(output: TNumberModulePool); +begin + FOwner.ReadNMPool(FIndex, output); + inc(FIndex); +end; + procedure TDataFrameEngineReader.Read(var Buf_; Count_: Int64); begin FOwner.Read(FIndex, Buf_, Count_); @@ -2544,7 +2568,7 @@ function TDataFrameEngine.WriteArrayByte: TDataFrameArrayByte; procedure TDataFrameEngine.WriteMD5(md5: TMD5); begin - WriteArrayByte.WriteArray(md5); + WriteArrayByte.SetBuff(@md5[0], SizeOf(TMD5)); end; function TDataFrameEngine.WriteArraySingle: TDataFrameArraySingle; @@ -2865,6 +2889,68 @@ procedure TDataFrameEngine.WritePointer(v: UInt64); WriteUInt64(v); end; +procedure TDataFrameEngine.WriteNM(NM: TNumberModule); +var + D_: TDataFrameEngine; +begin + D_ := TDataFrameEngine.Create; + D_.WriteString(NM.Name); + D_.WriteString(NM.SymbolName); + D_.WriteString(NM.Description); + D_.WriteString(NM.DetailDescription); + D_.WriteVariant(NM.OriginValue); + D_.WriteVariant(NM.CurrentValue); + WriteDataFrame(D_); + DisposeObject(D_); +end; + +procedure TDataFrameEngine.WriteNMPool(NMPool: TNumberModulePool); + +var + D_: TDataFrameEngine; +{$IFDEF FPC} + procedure fpc_progress_(const Name: PSystemString; NM: TNumberModule); + var + Tmp_: TDataFrameEngine; + begin + Tmp_ := TDataFrameEngine.Create; + Tmp_.WriteString(NM.Name); + Tmp_.WriteString(NM.SymbolName); + Tmp_.WriteString(NM.Description); + Tmp_.WriteString(NM.DetailDescription); + Tmp_.WriteVariant(NM.OriginValue); + Tmp_.WriteVariant(NM.CurrentValue); + D_.WriteDataFrame(Tmp_); + DisposeObject(Tmp_); + end; +{$ENDIF FPC} + + +begin + D_ := TDataFrameEngine.Create; + +{$IFDEF FPC} + NMPool.List.ProgressP(@fpc_progress_); +{$ELSE FPC} + NMPool.List.ProgressP(procedure(const Name: PSystemString; NM: TNumberModule) + var + Tmp_: TDataFrameEngine; + begin + Tmp_ := TDataFrameEngine.Create; + Tmp_.WriteString(NM.Name); + Tmp_.WriteString(NM.SymbolName); + Tmp_.WriteString(NM.Description); + Tmp_.WriteString(NM.DetailDescription); + Tmp_.WriteVariant(NM.OriginValue); + Tmp_.WriteVariant(NM.CurrentValue); + D_.WriteDataFrame(Tmp_); + DisposeObject(Tmp_); + end); +{$ENDIF FPC} + WriteDataFrame(D_); + DisposeObject(D_); +end; + // append new stream and write procedure TDataFrameEngine.write(const Buf_; Count_: Int64); var @@ -3228,12 +3314,9 @@ function TDataFrameEngine.ReadArrayByte(index_: Integer): TDataFrameArrayByte; end; function TDataFrameEngine.ReadMD5(index_: Integer): TMD5; -var - i: Integer; begin with ReadArrayByte(index_) do - for i := low(TMD5) to high(TMD5) do - Result[i] := Buffer[i]; + GetBuff(@Result[0]); end; function TDataFrameEngine.ReadArraySingle(index_: Integer): TDataFrameArraySingle; @@ -3644,6 +3727,56 @@ function TDataFrameEngine.ReadPointer(index_: Integer): UInt64; Result := ReadUInt64(index_); end; +procedure TDataFrameEngine.ReadNM(index_: Integer; output: TNumberModule); +var + D_: TDataFrameEngine; +begin + D_ := TDataFrameEngine.Create; + ReadDataFrame(index_, D_); + output.Name := D_.Reader.ReadString; + output.SymbolName := D_.Reader.ReadString; + output.Description := D_.Reader.ReadString; + output.DetailDescription := D_.Reader.ReadString; + output.DirectOriginValue := D_.Reader.ReadVariant; + output.DirectCurrentValue := D_.Reader.ReadVariant; + DisposeObject(D_); +end; + +procedure TDataFrameEngine.ReadNMPool(index_: Integer; output: TNumberModulePool); +var + D_, Tmp_: TDataFrameEngine; + DM: TNumberModule; + N_: SystemString; + L_: TCoreClassListForObj; + i: Integer; +begin + L_ := TCoreClassListForObj.Create; + D_ := TDataFrameEngine.Create; + ReadDataFrame(index_, D_); + while D_.Reader.NotEnd do + begin + Tmp_ := TDataFrameEngine.Create; + D_.Reader.ReadDataFrame(Tmp_); + N_ := Tmp_.Reader.ReadString; + DM := output[N_]; + DM.Name := N_; + DM.SymbolName := Tmp_.Reader.ReadString; + DM.Description := Tmp_.Reader.ReadString; + DM.DetailDescription := Tmp_.Reader.ReadString; + DM.DirectOriginValue := Tmp_.Reader.ReadVariant; + DM.DirectCurrentValue := Tmp_.Reader.ReadVariant; + L_.Add(DM); + DisposeObject(Tmp_); + end; + DisposeObject(D_); + for i := 0 to L_.Count - 1 do + begin + DM := TNumberModule(L_[i]); + DM.DoChange; + end; + DisposeObject(L_); +end; + procedure TDataFrameEngine.Read(index_: Integer; var Buf_; Count_: Int64); var s: TMS64; @@ -4772,6 +4905,24 @@ procedure TDataFrameEngine.SaveToStream(stream: TCoreClassStream); end; end; +procedure TDataFrameEngine.LoadFromFile(fileName_: U_String); +var + fs: TCoreClassFileStream; +begin + fs := TCoreClassFileStream.Create(fileName_, fmOpenRead or fmShareDenyNone); + LoadFromStream(fs); + DisposeObject(fs); +end; + +procedure TDataFrameEngine.SaveToFile(fileName_: U_String); +var + fs: TCoreClassFileStream; +begin + fs := TCoreClassFileStream.Create(fileName_, fmCreate); + SaveToStream(fs); + DisposeObject(fs); +end; + constructor TDataWriter.Create(Stream_: TCoreClassStream); begin inherited Create; @@ -5053,6 +5204,16 @@ procedure TDataWriter.WritePointer(v: Pointer); FEngine.WritePointer(v); end; +procedure TDataWriter.WriteNM(NM: TNumberModule); +begin + FEngine.WriteNM(NM); +end; + +procedure TDataWriter.WriteNMPool(NMPool: TNumberModulePool); +begin + FEngine.WriteNMPool(NMPool); +end; + procedure TDataWriter.write(const Buf_; Count_: Int64); begin FEngine.write(Buf_, Count_); @@ -5356,6 +5517,16 @@ function TDataReader.ReadPointer: UInt64; Result := FEngine.Reader.ReadPointer; end; +procedure TDataReader.ReadNM(output: TNumberModule); +begin + FEngine.Reader.ReadNM(output); +end; + +procedure TDataReader.ReadNMPool(output: TNumberModulePool); +begin + FEngine.Reader.ReadNMPool(output); +end; + procedure TDataReader.Read(var Buf_; Count_: Int64); begin FEngine.Reader.Read(Buf_, Count_); diff --git a/Source/GHashList.pas b/Source/GHashList.pas new file mode 100644 index 00000000..daf7b89e --- /dev/null +++ b/Source/GHashList.pas @@ -0,0 +1,665 @@ +{ ****************************************************************************** } +{ * Generic hash Library * } +{ * https://zpascal.net * } +{ * https://github.com/PassByYou888/zAI * } +{ * https://github.com/PassByYou888/ZServer4D * } +{ * https://github.com/PassByYou888/PascalString * } +{ * https://github.com/PassByYou888/zRasterization * } +{ * https://github.com/PassByYou888/CoreCipher * } +{ * https://github.com/PassByYou888/zSound * } +{ * https://github.com/PassByYou888/zChinese * } +{ * https://github.com/PassByYou888/zExpression * } +{ * https://github.com/PassByYou888/zGameWare * } +{ * https://github.com/PassByYou888/zAnalysis * } +{ * https://github.com/PassByYou888/FFMPEG-Header * } +{ * https://github.com/PassByYou888/zTranslate * } +{ * https://github.com/PassByYou888/InfiniteIoT * } +{ * https://github.com/PassByYou888/FastMD5 * } +{ ****************************************************************************** } +unit GHashList; + +{$INCLUDE zDefine.inc} + +interface + +uses +{$IFDEF FPC} + FPCGenericStructlist, +{$ENDIF FPC} + DoStatusIO, + CoreClasses, PascalStrings, UnicodeMixedLib, ListEngine; + +type +{$IFDEF FPC} + generic TGenericHashList = class(TCoreClassObject) +{$ELSE FPC} + TGenericHashList = class(TCoreClassObject) +{$ENDIF FPC} + public type + TRefClass_ = {$IFDEF FPC}specialize {$ENDIF FPC}TGenericHashList; + + TGebnericHashChangeEvent = procedure(Sender: TCoreClassObject; Name: SystemString; OLD_, New_: T_) of object; + + PGebnericHashListData = ^TGebnericHashListData; + + TGebnericHashListData = record + Obj: T_; + OnChnage: TGebnericHashChangeEvent; + end; + + TGebnericHashListLoopCall = procedure(const Name_: PSystemString; Obj_: T_); + TGebnericHashListLoopMethod = procedure(const Name_: PSystemString; Obj_: T_) of object; +{$IFDEF FPC} + TGebnericHashListLoopProc = procedure(const Name_: PSystemString; Obj_: T_) is nested; +{$ELSE FPC} + TGebnericHashListLoopProc = reference to procedure(const Name_: PSystemString; Obj_: T_); +{$ENDIF FPC} + private + FAutoFreeObject: Boolean; + FHashList: THashList; + FIncremental: NativeInt; + Default_Null_Value: T_; + + function GetCount: NativeInt; + + function GetIgnoreCase: Boolean; + procedure SetIgnoreCase(const Value: Boolean); + + function GetKeyValue(const Name: SystemString): T_; + procedure SetKeyValue(const Name: SystemString; const Value: T_); + + function GetOnChange(const Name: SystemString): TGebnericHashChangeEvent; + procedure SetOnChange(const Name: SystemString; const AValue: TGebnericHashChangeEvent); + + function GetAccessOptimization: Boolean; + procedure SetAccessOptimization(const Value: Boolean); + + procedure DefaultDataFreeProc(p: Pointer); + protected + public + constructor Create(AutoFreeData_: Boolean; HashPoolSize_: Integer; Default_Null_Value_: T_); + destructor Destroy; override; + + procedure Assign(sour: TRefClass_); + + procedure ProgressC(const OnProgress: TGebnericHashListLoopCall); + procedure ProgressM(const OnProgress: TGebnericHashListLoopMethod); + procedure ProgressP(const OnProgress: TGebnericHashListLoopProc); + + procedure Clear; + procedure GetNameList(OutputList: TCoreClassStrings); overload; + procedure GetNameList(OutputList: TListString); overload; + procedure GetNameList(OutputList: TListPascalString); overload; + procedure GetListData(OutputList: TCoreClassStrings); overload; + procedure GetListData(OutputList: TListString); overload; + procedure GetListData(OutputList: TListPascalString); overload; + procedure GetAsList(OutputList: TCoreClassListForObj); + function GetObjAsName(Obj: T_): SystemString; + procedure Delete(const Name: SystemString); + function Add(const Name: SystemString; Obj_: T_): T_; + function FastAdd(const Name: SystemString; Obj_: T_): T_; + function Find(const Name: SystemString): T_; + function Exists(const Name: SystemString): Boolean; + function ExistsObject(Obj: T_): Boolean; + procedure CopyFrom(const Source: TRefClass_); + function ReName(OLD_, New_: SystemString): Boolean; + function MakeName: SystemString; + function MakeRefName(RefrenceName: SystemString): SystemString; + + property AccessOptimization: Boolean read GetAccessOptimization write SetAccessOptimization; + property IgnoreCase: Boolean read GetIgnoreCase write SetIgnoreCase; + property AutoFreeObject: Boolean read FAutoFreeObject write FAutoFreeObject; + property Count: NativeInt read GetCount; + + property KeyValue[const Name: SystemString]: T_ read GetKeyValue write SetKeyValue; default; + property NameValue[const Name: SystemString]: T_ read GetKeyValue write SetKeyValue; + property OnChange[const Name: SystemString]: TGebnericHashChangeEvent read GetOnChange write SetOnChange; + property HashList: THashList read FHashList; + end; + +procedure Test_GListEngine; + +implementation + + +function TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.GetCount: NativeInt; +begin + Result := FHashList.Count; +end; + +function TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.GetIgnoreCase: Boolean; +begin + Result := FHashList.IgnoreCase; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.SetIgnoreCase(const Value: Boolean); +begin + FHashList.IgnoreCase := Value; +end; + +function TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.GetKeyValue(const Name: SystemString): T_; +var + pObjData: PGebnericHashListData; +begin + pObjData := FHashList.NameValue[Name]; + if pObjData <> nil then + Result := pObjData^.Obj as T_ + else + Result := Default_Null_Value; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.SetKeyValue(const Name: SystemString; const Value: T_); +begin + Add(Name, Value); +end; + +function TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.GetOnChange(const Name: SystemString): TGebnericHashChangeEvent; +var + pObjData: PGebnericHashListData; +begin + pObjData := FHashList.NameValue[Name]; + if pObjData <> nil then + Result := pObjData^.OnChnage + else + Result := nil; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.SetOnChange(const Name: SystemString; const AValue: TGebnericHashChangeEvent); +var + pObjData: PGebnericHashListData; +begin + pObjData := FHashList.NameValue[Name]; + if pObjData = nil then + begin + new(pObjData); + pObjData^.OnChnage := AValue; + pObjData^.Obj := Default_Null_Value; + FHashList.Add(Name, pObjData, False); + end + else + pObjData^.OnChnage := AValue; +end; + +function TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.GetAccessOptimization: Boolean; +begin + Result := FHashList.AccessOptimization; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.SetAccessOptimization(const Value: Boolean); +begin + FHashList.AccessOptimization := Value; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.DefaultDataFreeProc(p: Pointer); +begin + Dispose(PGebnericHashListData(p)); +end; + +constructor TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.Create(AutoFreeData_: Boolean; HashPoolSize_: Integer; Default_Null_Value_: T_); +begin + inherited Create; + FHashList := THashList.CustomCreate(HashPoolSize_); + FHashList.AutoFreeData := True; + + FHashList.OnFreePtr := {$IFDEF FPC}@{$ENDIF FPC}DefaultDataFreeProc; + FAutoFreeObject := AutoFreeData_; + FIncremental := 0; + Default_Null_Value := Default_Null_Value_; +end; + +destructor TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.Destroy; +begin + Clear; + DisposeObject(FHashList); + inherited Destroy; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.Assign(sour: TRefClass_); +var + i: Integer; + p: PHashListData; +begin + Clear; + if sour.HashList.Count > 0 then + begin + i := 0; + p := sour.HashList.FirstPtr; + while i < sour.HashList.Count do + begin + FastAdd(p^.OriginName, PGebnericHashListData(p^.Data)^.Obj); + inc(i); + p := p^.Next; + end; + end; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.ProgressC(const OnProgress: TGebnericHashListLoopCall); +var + i: Integer; + p: PHashListData; +begin + if HashList.Count > 0 then + begin + i := 0; + p := HashList.FirstPtr; + while i < HashList.Count do + begin + try + OnProgress(@p^.OriginName, PGebnericHashListData(p^.Data)^.Obj); + except + end; + inc(i); + p := p^.Next; + end; + end; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.ProgressM(const OnProgress: TGebnericHashListLoopMethod); +var + i: Integer; + p: PHashListData; +begin + if HashList.Count > 0 then + begin + i := 0; + p := HashList.FirstPtr; + while i < HashList.Count do + begin + try + OnProgress(@p^.OriginName, PGebnericHashListData(p^.Data)^.Obj); + except + end; + inc(i); + p := p^.Next; + end; + end; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.ProgressP(const OnProgress: TGebnericHashListLoopProc); +var + i: Integer; + p: PHashListData; +begin + if HashList.Count > 0 then + begin + i := 0; + p := HashList.FirstPtr; + while i < HashList.Count do + begin + try + OnProgress(@p^.OriginName, PGebnericHashListData(p^.Data)^.Obj); + except + end; + inc(i); + p := p^.Next; + end; + end; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.Clear; +var + lst: TCoreClassList; + pObjData: PGebnericHashListData; + i: Integer; +begin + if AutoFreeObject then + begin + lst := TCoreClassList.Create; + FHashList.GetListData(lst); + if lst.Count > 0 then + for i := 0 to lst.Count - 1 do + with PHashListData(lst[i])^ do + begin + pObjData := Data; + if pObjData <> nil then + if pObjData^.Obj <> Default_Null_Value then + begin + try + DisposeObject(pObjData^.Obj); + except + end; + end; + end; + DisposeObject(lst); + end; + FHashList.Clear; + FIncremental := 0; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.GetNameList(OutputList: TCoreClassStrings); +var + i: Integer; + p: PHashListData; +begin + OutputList.Clear; + if HashList.Count > 0 then + begin + i := 0; + p := HashList.FirstPtr; + while i < HashList.Count do + begin + OutputList.AddObject(p^.OriginName, PGebnericHashListData(p^.Data)^.Obj); + inc(i); + p := p^.Next; + end; + end; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.GetNameList(OutputList: TListString); +var + i: Integer; + p: PHashListData; +begin + OutputList.Clear; + if HashList.Count > 0 then + begin + i := 0; + p := HashList.FirstPtr; + while i < HashList.Count do + begin + OutputList.Add(p^.OriginName, PGebnericHashListData(p^.Data)^.Obj); + inc(i); + p := p^.Next; + end; + end; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.GetNameList(OutputList: TListPascalString); +var + i: Integer; + p: PHashListData; +begin + OutputList.Clear; + if HashList.Count > 0 then + begin + i := 0; + p := HashList.FirstPtr; + while i < HashList.Count do + begin + OutputList.Add(p^.OriginName, PGebnericHashListData(p^.Data)^.Obj); + inc(i); + p := p^.Next; + end; + end; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.GetListData(OutputList: TCoreClassStrings); +var + i: Integer; + p: PHashListData; +begin + OutputList.Clear; + if HashList.Count > 0 then + begin + i := 0; + p := HashList.FirstPtr; + while i < HashList.Count do + begin + OutputList.AddObject(p^.OriginName, PGebnericHashListData(p^.Data)^.Obj); + inc(i); + p := p^.Next; + end; + end; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.GetListData(OutputList: TListString); +var + i: Integer; + p: PHashListData; +begin + OutputList.Clear; + if HashList.Count > 0 then + begin + i := 0; + p := HashList.FirstPtr; + while i < HashList.Count do + begin + OutputList.Add(p^.OriginName, PGebnericHashListData(p^.Data)^.Obj); + inc(i); + p := p^.Next; + end; + end; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.GetListData(OutputList: TListPascalString); +var + i: Integer; + p: PHashListData; +begin + OutputList.Clear; + if HashList.Count > 0 then + begin + i := 0; + p := HashList.FirstPtr; + while i < HashList.Count do + begin + OutputList.Add(p^.OriginName, PGebnericHashListData(p^.Data)^.Obj); + inc(i); + p := p^.Next; + end; + end; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.GetAsList(OutputList: TCoreClassListForObj); +var + i: Integer; + p: PHashListData; +begin + OutputList.Clear; + if HashList.Count > 0 then + begin + i := 0; + p := HashList.FirstPtr; + while i < HashList.Count do + begin + OutputList.Add(PGebnericHashListData(p^.Data)^.Obj); + inc(i); + p := p^.Next; + end; + end; +end; + +function TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.GetObjAsName(Obj: T_): SystemString; +var + i: Integer; + p: PHashListData; +begin + Result := ''; + if HashList.Count > 0 then + begin + i := 0; + p := HashList.FirstPtr; + while i < HashList.Count do + begin + if PGebnericHashListData(p^.Data)^.Obj = Obj then + begin + Result := p^.OriginName; + Exit; + end; + inc(i); + p := p^.Next; + end; + end; +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.Delete(const Name: SystemString); +var + pObjData: PGebnericHashListData; +begin + if AutoFreeObject then + begin + pObjData := FHashList.NameValue[Name]; + if pObjData <> nil then + begin + if pObjData^.Obj <> Default_Null_Value then + begin + try + DisposeObject(pObjData^.Obj); + pObjData^.Obj := Default_Null_Value; + except + end; + end; + end; + end; + FHashList.Delete(Name); +end; + +function TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.Add(const Name: SystemString; Obj_: T_): T_; +var + pObjData: PGebnericHashListData; +begin + pObjData := FHashList.NameValue[Name]; + if pObjData <> nil then + begin + try + if Assigned(pObjData^.OnChnage) then + pObjData^.OnChnage(Self, Name, pObjData^.Obj, Obj_); + except + end; + + if (FAutoFreeObject) and (pObjData^.Obj <> Default_Null_Value) then + begin + try + DisposeObject(pObjData^.Obj); + pObjData^.Obj := Default_Null_Value; + except + end; + end; + end + else + begin + new(pObjData); + pObjData^.OnChnage := nil; + FHashList.Add(Name, pObjData, False); + end; + + pObjData^.Obj := Obj_; + Result := Obj_; +end; + +function TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.FastAdd(const Name: SystemString; Obj_: T_): T_; +var + pObjData: PGebnericHashListData; +begin + new(pObjData); + pObjData^.OnChnage := nil; + FHashList.Add(Name, pObjData, False); + + pObjData^.Obj := Obj_; + Result := Obj_; +end; + +function TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.Find(const Name: SystemString): T_; +var + pObjData: PGebnericHashListData; +begin + pObjData := FHashList.Find(Name); + if pObjData <> nil then + Result := pObjData^.Obj + else + Result := Default_Null_Value; +end; + +function TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.Exists(const Name: SystemString): Boolean; +begin + Result := FHashList.Exists(Name); +end; + +function TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.ExistsObject(Obj: T_): Boolean; +var + lst: TCoreClassList; + i: Integer; +begin + Result := False; + lst := TCoreClassList.Create; + FHashList.GetListData(lst); + if lst.Count > 0 then + for i := 0 to lst.Count - 1 do + begin + with PHashListData(lst[i])^ do + begin + if PGebnericHashListData(Data)^.Obj = Obj then + begin + Result := True; + Break; + end; + end; + end; + DisposeObject(lst); +end; + +procedure TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.CopyFrom(const Source: TRefClass_); +var + lst: TCoreClassList; + pObjData: PGebnericHashListData; + i: Integer; +begin + lst := TCoreClassList.Create; + Source.HashList.GetListData(lst); + if lst.Count > 0 then + for i := 0 to lst.Count - 1 do + begin + with PHashListData(lst[i])^ do + if Data <> nil then + begin + pObjData := Data; + NameValue[OriginName] := pObjData^.Obj; + end; + end; + DisposeObject(lst); +end; + +function TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.ReName(OLD_, New_: SystemString): Boolean; +var + pObjData: PGebnericHashListData; +begin + pObjData := FHashList.NameValue[OLD_]; + Result := (OLD_ <> New_) and (pObjData <> nil) and (FHashList.NameValue[New_] = nil); + if Result then + begin + Add(New_, pObjData^.Obj); + FHashList.Delete(OLD_); + end; +end; + +function TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.MakeName: SystemString; +begin + repeat + inc(FIncremental); + Result := umlIntToStr(FIncremental); + until not Exists(Result); +end; + +function TGenericHashList{$IFNDEF FPC}{$ENDIF FPC}.MakeRefName(RefrenceName: SystemString): SystemString; +begin + Result := RefrenceName; + if not Exists(Result) then + Exit; + + repeat + inc(FIncremental); + Result := RefrenceName + umlIntToStr(FIncremental); + until not Exists(Result); +end; + +procedure Test_GListEngine; +type + TSL = {$IFDEF FPC}specialize {$ENDIF FPC}TGenericHashList; +var + L: TSL; +begin + L := TSL.Create(True, 100, nil); + L.Add('abc', TCoreClassStringList.Create).Text := '1'#10'2'#10'3'; + L.Add('abc1', TCoreClassStringList.Create).Text := '11'#10'222'#10'33'; + L.Add('abc2', TCoreClassStringList.Create).Text := '111'#10'222'#10'333'; + L.Add('abc3', TCoreClassStringList.Create).Text := '1111'#10'2222'#10'3333'; + DoStatus(L['abc'][0]); + DoStatus(L['abc'][1]); + DoStatus(L['abc'][2]); + DoStatus(L['abc1'][0]); + DoStatus(L['abc2'][0]); + DoStatus(L['abc3'][0]); + DisposeObject(L); +end; + +end. diff --git a/Source/Geometry2DUnit.pas b/Source/Geometry2DUnit.pas index 09ee401b..d13313aa 100644 --- a/Source/Geometry2DUnit.pas +++ b/Source/Geometry2DUnit.pas @@ -111,8 +111,8 @@ function Rectf(Left, Top, Right, Bottom: TGeoFloat): TRectf; {$ENDIF} {$ENDREGION 'BaseType define'} {$REGION 'API'} -function FAbs(const v: Single): Single; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function FAbs(const v: Double): Double; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function FAbs(const V: Single): Single; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function FAbs(const V: Double): Double; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function Clamp(const Value_, Min_, Max_: TGeoFloat): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function MaxF(const v1, v2: TGeoFloat): TGeoFloat; {$IFDEF INLINE_ASM} inline; {$ENDIF} function MinF(const v1, v2: TGeoFloat): TGeoFloat; {$IFDEF INLINE_ASM} inline; {$ENDIF} @@ -151,26 +151,26 @@ function LineV2(const l: TLineV2_P): TLineV2; overload; {$IFDEF INLINE_ASM} inli function LineV2(const l: PLineV2_P): TLineV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function LineV2(const l: PLineV2): TLineV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RoundVec2(const v: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RoundVec2(const V: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function MakePointf(const pt: TVec2): TPointf; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function IsZero(const v: TGeoFloat): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function IsZero(const V: TGeoFloat): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function IsZero(const pt: TVec2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function IsZero(const r: TRectV2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function IsZero(const R: TRectV2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function IsNan(const pt: TVec2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function IsNan(const X, Y: TGeoFloat): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function HypotX(const X, Y: Extended): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function PointNorm(const v: TVec2): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function PointNegate(const v: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function PointNorm(const V: TVec2): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function PointNegate(const V: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function Vec2Norm(const v: TVec2): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function Vec2Negate(const v: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function Vec2Norm(const V: TVec2): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function Vec2Negate(const V: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function vec2Inv(const v: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -procedure SetVec2(var v: TVec2; const vSrc: TVec2); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function vec2Inv(const V: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +procedure SetVec2(var V: TVec2; const vSrc: TVec2); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function Vec2Direction(sour, dest: TVec2): TVec2; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectDirection(sour, dest: TRectV2): TRectV2; {$IFDEF INLINE_ASM} inline; {$ENDIF} @@ -204,13 +204,13 @@ function Vec2Div(const v1: TVec2; const v2: TGeoFloat): TVec2; overload; {$IFDEF function Vec2Div(const v1, v2: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function Vec2Div(const v1: TGeoFloat; const v2: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function PointNormalize(const v: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function Vec2Normalize(const v: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function PointNormalize(const V: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function Vec2Normalize(const V: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function PointLength(const v: TVec2): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function Vec2Length(const v: TVec2): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function PointLength(const V: TVec2): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function Vec2Length(const V: TVec2): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -procedure PointScale(var v: TVec2; factor: TGeoFloat); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +procedure PointScale(var V: TVec2; factor: TGeoFloat); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function PointDotProduct(const v1, v2: TVec2): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function Distance(const x1, y1, x2, y2: TGeoFloat): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} @@ -232,8 +232,8 @@ function Vec2Lerp(const v1, v2: TVec2; t: TGeoFloat): TVec2; overload; {$IFDEF I function Vec2LerpTo(const sour, dest: TVec2; const d: TGeoFloat): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} procedure SwapPoint(var v1, v2: TVec2); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} procedure SwapVec2(var v1, v2: TVec2); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function Pow(v: TGeoFloat): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function Pow(const v, n: TGeoFloat): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function Pow(V: TGeoFloat): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function Pow(const V, n: TGeoFloat): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function MiddleVec2(const pt1, pt2: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function Vec2Middle(const pt1, pt2: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} @@ -269,21 +269,21 @@ function Vec2Rotation(const axis: TVec2; const Dist, Angle: TGeoFloat): TVec2; o function Vec2Rotation(const axis, pt: TVec2; const Angle: TGeoFloat): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function Vec2Rotation(const sour_r: TRectV2; const Angle: TGeoFloat; const pt: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function Vec2Rotation(const sour_r: TRectV2; const axis: TVec2; const Angle: TGeoFloat; const pt: TVec2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function Vec2Rotation(const sour_r: TRectV2; const axis: TVec2; const Angle: TGeoFloat; const r: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectRotation(const axis: TVec2; const r: TRectV2; const Angle: TGeoFloat): TRectV2; +function Vec2Rotation(const sour_r: TRectV2; const axis: TVec2; const Angle: TGeoFloat; const R: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectRotation(const axis: TVec2; const R: TRectV2; const Angle: TGeoFloat): TRectV2; function CircleInCircle(const cp1, cp2: TVec2; const r1, r2: TGeoFloat): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function CircleInRect(const cp: TVec2; const radius: TGeoFloat; r: TRectV2): Boolean; +function CircleInRect(const cp: TVec2; const radius: TGeoFloat; R: TRectV2): Boolean; function PointInRect(const Px, Py: TGeoFloat; const x1, y1, x2, y2: TGeoFloat): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function PointInRect(const Px, Py: TGeoInt; const x1, y1, x2, y2: TGeoInt): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function PointInRect(const X, Y: TGeoInt; const r: TRect): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function PointInRect(const pt: TPoint; const r: TRect): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function PointInRect(const pt: TVec2; const r: TRectV2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function PointInRect(const Px, Py: TGeoFloat; const r: TRectV2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function PointInRect(const X, Y: TGeoInt; const R: TRect): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function PointInRect(const pt: TPoint; const R: TRect): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function PointInRect(const pt: TVec2; const R: TRectV2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function PointInRect(const Px, Py: TGeoFloat; const R: TRectV2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function Vec2InRect(const Px, Py: TGeoFloat; const x1, y1, x2, y2: TGeoFloat): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function Vec2InRect(const Px, Py: TGeoInt; const x1, y1, x2, y2: TGeoInt): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function Vec2InRect(const pt: TVec2; const r: TRectV2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function Vec2InRect(const Px, Py: TGeoFloat; const r: TRectV2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function Vec2InRect(const pt: TVec2; const R: TRectV2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function Vec2InRect(const Px, Py: TGeoFloat; const R: TRectV2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectToRectIntersect(const x1, y1, x2, y2, x3, y3, x4, y4: TGeoFloat): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectToRectIntersect(const x1, y1, x2, y2, x3, y3, x4, y4: TGeoInt): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectToRectIntersect(const r1, r2: TRectV2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} @@ -303,8 +303,8 @@ function MakeRectV2(const X, Y, radius: TGeoFloat): TRectV2; overload; {$IFDEF I function MakeRectV2(const x1, y1, x2, y2: TGeoFloat): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function MakeRectV2(const p1, p2: TVec2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function MakeRectV2(const X, Y: TGeoFloat; const p2: TVec2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function MakeRectV2(const r: TRect): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function MakeRectV2(const r: TRectf): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function MakeRectV2(const R: TRect): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function MakeRectV2(const R: TRectf): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectV2(): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectV2(const centre: TVec2; const width, height: TGeoFloat): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} @@ -313,34 +313,34 @@ function RectV2(const x1, y1, x2, y2: TGeoFloat): TRectV2; overload; {$IFDEF INL function RectV2(const p1, p2: TVec2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectV2(const p1, p2: TPointf): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectV2(const X, Y: TGeoFloat; const p2: TVec2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectV2(const r: TRect): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectV2(const r: TRectf): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectV2(const r: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectV2(const R: TRect): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectV2(const R: TRectf): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectV2(const R: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function MakeRect(const centre: TVec2; const width, height: TGeoFloat): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function MakeRect(const X, Y, radius: TGeoFloat): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function MakeRect(const x1, y1, x2, y2: TGeoFloat): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function MakeRect(const p1, p2: TVec2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function MakeRect(const r: TRect): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function MakeRect(const r: TRectf): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function MakeRect(const R: TRect): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function MakeRect(const R: TRectf): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RoundRect(const r: TRectV2): TRect; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RoundRectV2(const r: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RoundRect(const R: TRectV2): TRect; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RoundRectV2(const R: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function Rect2Rect(const r: TRectV2): TRect; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function Rect2Rect(const r: TRect): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function Rect2Rect(const R: TRectV2): TRect; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function Rect2Rect(const R: TRect): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectMake(const X, Y, radius: TGeoFloat): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectMake(const x1, y1, x2, y2: TGeoFloat): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectMake(const p1, p2: TVec2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectMake(const r: TRect): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectMake(const r: TRectf): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectMake(const R: TRect): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectMake(const R: TRectf): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectAdd(const r: TRectV2; v2: TVec2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectAdd(const R: TRectV2; v2: TVec2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectAdd(const r1, r2: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectSub(const r1, r2: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectSub(const r: TRectV2; pt: TVec2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectSub(const R: TRectV2; pt: TVec2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectMul(const r1, r2: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectMul(const r1: TRectV2; v2: TVec2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} @@ -350,20 +350,20 @@ function RectDiv(const r1, r2: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} function RectDiv(const r1: TRectV2; f2: TGeoFloat): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectDiv(const r1: TRectV2; v2: TVec2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectOffset(const r: TRectV2; Offset: TVec2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectSizeLerp(const r: TRectV2; const rSizeLerp: TGeoFloat): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectCenScale(const r: TRectV2; const rSizeScale: TGeoFloat): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectEdge(const r: TRectV2; const Edge: TGeoFloat): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectEdge(const r: TRectV2; const Edge: TVec2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectCentre(const r: TRectV2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectCentre(const r: TRect): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectCentre(const r: TRectf): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectOffset(const R: TRectV2; Offset: TVec2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectSizeLerp(const R: TRectV2; const rSizeLerp: TGeoFloat): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectCenScale(const R: TRectV2; const rSizeScale: TGeoFloat): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectEdge(const R: TRectV2; const Edge: TGeoFloat): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectEdge(const R: TRectV2; const Edge: TVec2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectCentre(const R: TRectV2): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectCentre(const R: TRect): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectCentre(const R: TRectf): TVec2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function Tri(const v1, v2, v3: TVec2): TTriangle; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function TriAdd(const t: TTriangle; v: TVec2): TTriangle; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function TriSub(const t: TTriangle; v: TVec2): TTriangle; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function TriMul(const t: TTriangle; v: TVec2): TTriangle; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function TriDiv(const t: TTriangle; v: TVec2): TTriangle; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function TriAdd(const t: TTriangle; V: TVec2): TTriangle; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function TriSub(const t: TTriangle; V: TVec2): TTriangle; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function TriMul(const t: TTriangle; V: TVec2): TTriangle; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function TriDiv(const t: TTriangle; V: TVec2): TTriangle; {$IFDEF INLINE_ASM} inline; {$ENDIF} function TriCentre(const t: TTriangle): TVec2; {$IFDEF INLINE_ASM} inline; {$ENDIF} function TriExpand(const t: TTriangle; Dist: TGeoFloat): TTriangle; function TriRound(const t: TTriangle): TTriangle; {$IFDEF INLINE_ASM} inline; {$ENDIF} @@ -374,45 +374,45 @@ function RectTransform(const sour, dest, sour_rect: TRectV2): TRectV2; overload; function RectTransform(const sour, dest: TRectV2; const sour_rect: TRect): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectTransform(const sour, dest: TRectV2; const sour_rect: TRectf): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectScaleSpace(const r: TRectV2; const SS_width, SS_height: TGeoFloat): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectScaleSpace(const r: TRect; const SS_width, SS_height: TGeoInt): TRect; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function CalibrationRectInRect(const r, Area: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function CalibrationRectInRect(const r, Area: TRect): TRect; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectScaleSpace(const R: TRectV2; const SS_width, SS_height: TGeoFloat): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectScaleSpace(const R: TRect; const SS_width, SS_height: TGeoInt): TRect; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function CalibrationRectInRect(const R, Area: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function CalibrationRectInRect(const R, Area: TRect): TRect; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} procedure FixRect(var Left, Top, Right, Bottom: TGeoInt); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} procedure FixRect(var Left, Top, Right, Bottom: TGeoFloat); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function FixRect(r: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function FixRect(r: TRect): TRect; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function FixRect(R: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function FixRect(R: TRect): TRect; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} procedure FixedRect(var Left, Top, Right, Bottom: TGeoInt); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} procedure FixedRect(var Left, Top, Right, Bottom: TGeoFloat); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function FixedRect(r: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function FixedRect(r: TRect): TRect; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function FixedRect(R: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function FixedRect(R: TRect): TRect; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} procedure ForwardRect(var Left, Top, Right, Bottom: TGeoInt); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} procedure ForwardRect(var Left, Top, Right, Bottom: TGeoFloat); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function ForwardRect(r: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function ForwardRect(r: TRect): TRect; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} - -function MakeRect(const r: TRectV2): TRect; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function MakeRectf(const r: TRectV2): TRectf; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} - -function RectWidth(const r: TRectV2): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectHeight(const r: TRectV2): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectWidth(const r: TRect): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectHeight(const r: TRect): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectWidth(const r: TRectf): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectHeight(const r: TRectf): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} - -function RoundWidth(const r: TRectV2): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RoundHeight(const r: TRectV2): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RoundWidth(const r: TRect): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RoundHeight(const r: TRect): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RoundWidth(const r: TRectf): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RoundHeight(const r: TRectf): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} - -function RectArea(const r: TRectV2): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectArea(const r: TRect): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectSize(const r: TRectV2): TVec2; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function RectSizeR(const r: TRectV2): TRectV2; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function ForwardRect(R: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function ForwardRect(R: TRect): TRect; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} + +function MakeRect(const R: TRectV2): TRect; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function MakeRectf(const R: TRectV2): TRectf; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} + +function RectWidth(const R: TRectV2): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectHeight(const R: TRectV2): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectWidth(const R: TRect): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectHeight(const R: TRect): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectWidth(const R: TRectf): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectHeight(const R: TRectf): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} + +function RoundWidth(const R: TRectV2): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RoundHeight(const R: TRectV2): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RoundWidth(const R: TRect): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RoundHeight(const R: TRect): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RoundWidth(const R: TRectf): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RoundHeight(const R: TRectf): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} + +function RectArea(const R: TRectV2): TGeoFloat; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectArea(const R: TRect): TGeoInt; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectSize(const R: TRectV2): TVec2; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function RectSizeR(const R: TRectV2): TRectV2; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectFit(const sour, dest: TRectV2; const Bound: Boolean): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectFit(const sour, dest: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function RectFit(const width, height: TGeoFloat; const bk: TRectV2): TRectV2; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} @@ -509,7 +509,7 @@ procedure ProjectionPoint(const Srcx, Srcy, Dstx, Dsty, Dist: TGeoFloat; out Nx, procedure ProjectionPoint(const Srcx, Srcy, Srcz, Dstx, Dsty, Dstz, Dist: TGeoFloat; out Nx, Ny, Nz: TGeoFloat); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} procedure ProjectionPoint(const Px, Py, Angle, Distance: TGeoFloat; out Nx, Ny: TGeoFloat); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function GetCicleRadiusInPolyEdge(r: TGeoFloat; PolySlices: TGeoInt): TGeoFloat; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function GetCicleRadiusInPolyEdge(R: TGeoFloat; PolySlices: TGeoInt): TGeoFloat; {$IFDEF INLINE_ASM} inline; {$ENDIF} procedure Circle2LineIntersectionPoint(const lb, le, cp: TVec2; const radius: TGeoFloat; out pt1in, pt2in: Boolean; out ICnt: TGeoInt; out pt1, pt2: TVec2); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} @@ -525,8 +525,8 @@ function CircleCollision(const p1, p2: TVec2; const r1, r2: TGeoFloat): Boolean; function Detect_Circle2CirclePoint(const p1, p2: TVec2; const r1, r2: TGeoFloat; out op1, op2: TVec2): Boolean; // circle 2 line collision -function Detect_Circle2Line(const cp: TVec2; const r: TGeoFloat; const lb, le: TVec2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} -function Detect_Circle2Line(const cp: TVec2; const r: TGeoFloat; const l: TLineV2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function Detect_Circle2Line(const cp: TVec2; const R: TGeoFloat; const lb, le: TVec2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} +function Detect_Circle2Line(const cp: TVec2; const R: TGeoFloat; const l: TLineV2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function SameLinePtr(const lb1, le1, lb2, le2: PVec2): Boolean; @@ -552,13 +552,13 @@ TV2Rect4 = record function TransformToRect(Box: TRectV2; Edge: TGeoFloat): TV2Rect4; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function TransformToRect(Box: TRectV2; Angle, Edge: TGeoFloat): TV2Rect4; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function TransformToRect(Box: TRectV2; axis: TVec2; Angle, Edge: TGeoFloat): TV2Rect4; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} - function Add(v: TVec2): TV2Rect4; {$IFDEF INLINE_ASM} inline; {$ENDIF} - function Sub(v: TVec2): TV2Rect4; {$IFDEF INLINE_ASM} inline; {$ENDIF} - function Mul(v: TVec2): TV2Rect4; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} - function Mul(v: TGeoFloat): TV2Rect4; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} + function Add(V: TVec2): TV2Rect4; {$IFDEF INLINE_ASM} inline; {$ENDIF} + function Sub(V: TVec2): TV2Rect4; {$IFDEF INLINE_ASM} inline; {$ENDIF} + function Mul(V: TVec2): TV2Rect4; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} + function Mul(V: TGeoFloat): TV2Rect4; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function Mul(X, Y: TGeoFloat): TV2Rect4; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} - function Div_(v: TVec2): TV2Rect4; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} - function Div_(v: TGeoFloat): TV2Rect4; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} + function Div_(V: TVec2): TV2Rect4; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} + function Div_(V: TGeoFloat): TV2Rect4; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function MoveTo(Position: TVec2): TV2Rect4; {$IFDEF INLINE_ASM} inline; {$ENDIF} function BoundRect: TRectV2; {$IFDEF INLINE_ASM} inline; {$ENDIF} function BoundRectf: TRectf; {$IFDEF INLINE_ASM} inline; {$ENDIF} @@ -567,32 +567,32 @@ TV2Rect4 = record function Transform(X, Y: TGeoFloat): TV2Rect4; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function Expands(Dist: TGeoFloat): TV2Rect4; function InHere(pt: TVec2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} - function InHere(r: TRectV2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} + function InHere(R: TRectV2): Boolean; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function GetArrayVec2: TArrayVec2; function GetNear(pt: TVec2): TVec2; - function GetNearLine(const v: TVec2; out lb, le: PVec2): TVec2; overload; - function GetNearLine(const v: TVec2): TVec2; overload; + function GetNearLine(const V: TVec2; out lb, le: PVec2): TVec2; overload; + function GetNearLine(const V: TVec2): TVec2; overload; function Projection(const sour, dest: TRectV2; const sourAxis, destAxis: TVec2; const sourAngle, destAngle: TGeoFloat): TV2Rect4; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function Projection(const sour, dest: TRectV2; sourAngle, destAngle: TGeoFloat): TV2Rect4; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function Projection(const sour, dest: TRectV2): TV2Rect4; overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} class function RebuildVertex(const buff: TArrayVec2): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} class function RebuildVertex(const buff: TVec2List): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} - class function Init(r: TRectV2): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} - class function Init(r: TRectV2; axis: TVec2; Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} - class function Init(r: TRectV2; Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} - class function Init(r: TRectf; Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} - class function Init(r: TRect; Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} - class function Init(r: TRect): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} + class function Init(R: TRectV2): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} + class function Init(R: TRectV2; axis: TVec2; Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} + class function Init(R: TRectV2; Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} + class function Init(R: TRectf; Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} + class function Init(R: TRect; Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} + class function Init(R: TRect): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} class function Init(CenPos: TVec2; width, height, Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} class function Init(width, height, Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} class function Init(width, height: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} class function Init(): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} - class function Create(r: TRectV2): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} - class function Create(r: TRectV2; axis: TVec2; Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} - class function Create(r: TRectV2; Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} - class function Create(r: TRectf; Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} - class function Create(r: TRect; Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} - class function Create(r: TRect): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} + class function Create(R: TRectV2): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} + class function Create(R: TRectV2; axis: TVec2; Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} + class function Create(R: TRectV2; Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} + class function Create(R: TRectf; Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} + class function Create(R: TRect; Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} + class function Create(R: TRect): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} class function Create(CenPos: TVec2; width, height, Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} class function Create(width, height, Ang: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} class function Create(width, height: TGeoFloat): TV2Rect4; overload; static; {$IFDEF INLINE_ASM} inline; {$ENDIF} @@ -644,15 +644,15 @@ TVec2List = class(TCoreClassObject) procedure Add(pt: TPoint); overload; procedure Add(pt: TPointf); overload; procedure Add(v2l: TVec2List); overload; - procedure Add(r: TRectV2); overload; - procedure Add(r: TRect); overload; - procedure Add(r: TRectf); overload; - procedure Add(r: TV2Rect4); overload; + procedure Add(R: TRectV2); overload; + procedure Add(R: TRect); overload; + procedure Add(R: TRectf); overload; + procedure Add(R: TV2Rect4); overload; procedure Add(arry: TArrayV2Rect4); overload; procedure AddSubdivision(nbCount: TGeoInt; pt: TVec2); overload; procedure AddSubdivisionWithDistance(avgDist: TGeoFloat; pt: TVec2); overload; procedure AddCirclePoint(count_: Cardinal; axis: TVec2; dist_: TGeoFloat); - procedure AddRectangle(r: TRectV2); + procedure AddRectangle(R: TRectV2); procedure Insert(idx: TGeoInt; X, Y: TGeoFloat); overload; procedure Insert(idx: TGeoInt; pt: TVec2); overload; procedure Delete(idx: TGeoInt); overload; @@ -691,8 +691,8 @@ TVec2List = class(TCoreClassObject) function Area: TGeoFloat; function InHere(pt: TVec2): Boolean; overload; - function InRect(r: TRectV2): Boolean; - function Rect2Intersect(r: TRectV2): Boolean; + function InRect(R: TRectV2): Boolean; + function Rect2Intersect(R: TRectV2): Boolean; procedure RotateAngle(axis: TVec2; Angle: TGeoFloat); overload; procedure Scale(Scale_: TGeoFloat); overload; @@ -732,13 +732,13 @@ TVec2List = class(TCoreClassObject) procedure CutLineBeginPtToIdx(const pt: TVec2; const toidx: TGeoInt); procedure Transform(X, Y: TGeoFloat); overload; - procedure Transform(v: TVec2); overload; + procedure Transform(V: TVec2); overload; procedure Mul(X, Y: TGeoFloat); overload; - procedure Mul(v: TVec2); overload; - procedure Mul(v: TGeoFloat); overload; + procedure Mul(V: TVec2); overload; + procedure Mul(V: TGeoFloat); overload; procedure FDiv(X, Y: TGeoFloat); overload; - procedure FDiv(v: TVec2); overload; - procedure FDiv(v: TGeoFloat); overload; + procedure FDiv(V: TVec2); overload; + procedure FDiv(V: TGeoFloat); overload; property Points[index: TGeoInt]: PVec2 read GetPoints; default; function First: PVec2; @@ -826,12 +826,12 @@ T2DPolygonGraph = class(TCoreClassObject) function Line2Intersect(const lb, le: TVec2; output: T2DPolygon): Boolean; function GetNearLine(const pt: TVec2; out output: T2DPolygon; out lb, le: TGeoInt): TVec2; procedure Transform(X, Y: TGeoFloat); overload; - procedure Transform(v: TVec2); overload; + procedure Transform(V: TVec2); overload; procedure Mul(X, Y: TGeoFloat); overload; - procedure Mul(v: TVec2); overload; - procedure Mul(v: TGeoFloat); overload; + procedure Mul(V: TVec2); overload; + procedure Mul(V: TGeoFloat); overload; procedure FDiv(X, Y: TGeoFloat); overload; - procedure FDiv(v: TVec2); overload; + procedure FDiv(V: TVec2); overload; procedure VertexReduction(Epsilon_: TGeoFloat); overload; procedure Reduction(Epsilon_: TGeoFloat); overload; @@ -893,10 +893,10 @@ TDeflectionPolygon = class(TCoreClassObject) procedure AddPoint(pt: TVec2); overload; procedure AddPoint(X, Y: TGeoFloat); overload; - procedure AddRectangle(r: TRectV2); overload; + procedure AddRectangle(R: TRectV2); overload; procedure AddCirclePoint(count_: Cardinal; axis: TVec2; dist_: TGeoFloat); procedure Add(angle_, dist_: TGeoFloat); overload; - procedure AddRectangle(r: TV2Rect4); overload; + procedure AddRectangle(R: TV2Rect4); overload; procedure AddRectangle(arry: TArrayV2Rect4); overload; procedure Insert(idx: TGeoInt; angle_, dist_: TGeoFloat); overload; procedure InsertPoint(idx: TGeoInt; pt: TVec2); overload; @@ -942,9 +942,9 @@ TDeflectionPolygon = class(TCoreClassObject) function GetNearLine(const pt: TVec2; const ClosedPolyMode: Boolean; out lb, le: TGeoInt): TVec2; overload; function GetNearLine(ExpandDistance_: TGeoFloat; const pt: TVec2; const ClosedPolyMode: Boolean; out lb, le: TGeoInt): TVec2; overload; - function Collision2Circle(cp: TVec2; r: TGeoFloat; ClosedPolyMode: Boolean): Boolean; overload; - function Collision2Circle(cp: TVec2; r: TGeoFloat; ClosedPolyMode: Boolean; OutputLine: TDeflectionPolygonLines): Boolean; overload; - function Collision2Circle(ExpandDistance_: TGeoFloat; cp: TVec2; r: TGeoFloat; ClosedPolyMode: Boolean; OutputLine: TDeflectionPolygonLines): Boolean; overload; + function Collision2Circle(cp: TVec2; R: TGeoFloat; ClosedPolyMode: Boolean): Boolean; overload; + function Collision2Circle(cp: TVec2; R: TGeoFloat; ClosedPolyMode: Boolean; OutputLine: TDeflectionPolygonLines): Boolean; overload; + function Collision2Circle(ExpandDistance_: TGeoFloat; cp: TVec2; R: TGeoFloat; ClosedPolyMode: Boolean; OutputLine: TDeflectionPolygonLines): Boolean; overload; function PolygonIntersect(Poly_: TDeflectionPolygon): Boolean; overload; function PolygonIntersect(vl_: TVec2List): Boolean; overload; @@ -1035,7 +1035,7 @@ TDeflectionPolygonLines = class(TCoreClassPersistent) procedure Assign(Source: TCoreClassPersistent); override; property Items[index: TGeoInt]: PDeflectionPolygonLine read GetItems; default; - function Add(v: TDeflectionPolygonLine): TGeoInt; overload; + function Add(V: TDeflectionPolygonLine): TGeoInt; overload; function Add(lb, le: TVec2): TGeoInt; overload; function Add(lb, le: TVec2; idx1, idx2: TGeoInt; polygon: TDeflectionPolygon): TGeoInt; overload; function Count: TGeoInt; @@ -1098,7 +1098,7 @@ TRectPacking = class(TCoreClassPersistent) procedure Clear; procedure Add(const X, Y, width, height: TGeoFloat); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} procedure Add(Data1: Pointer; Data2: TCoreClassObject; X, Y, width, height: TGeoFloat); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} - procedure Add(Data1: Pointer; Data2: TCoreClassObject; r: TRectV2); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} + procedure Add(Data1: Pointer; Data2: TCoreClassObject; R: TRectV2); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} procedure Add(Data1: Pointer; Data2: TCoreClassObject; width, height: TGeoFloat); overload; {$IFDEF INLINE_ASM} inline; {$ENDIF} function Data1Exists(const Data1: Pointer): Boolean; {$IFDEF INLINE_ASM} inline; {$ENDIF} function Data2Exists(const Data2: TCoreClassObject): Boolean; {$IFDEF INLINE_ASM} inline; {$ENDIF} @@ -1291,9 +1291,9 @@ TLinkedList = record {$ENDREGION 'Hausdorf'} -function ArrayVec2(const v: TArrayVec2): TArrayVec2; overload; -function ArrayVec2(const r: TRectV2): TArrayVec2; overload; -function ArrayVec2(const r: TV2Rect4): TArrayVec2; overload; +function ArrayVec2(const V: TArrayVec2): TArrayVec2; overload; +function ArrayVec2(const R: TRectV2): TArrayVec2; overload; +function ArrayVec2(const R: TV2Rect4): TArrayVec2; overload; function ArrayVec2(const l: TLineV2): TArrayVec2; overload; function ArrayVec2(const t: TTriangle): TArrayVec2; overload; function ArrayBoundRect(arry: TArrayVec2): TRectV2; overload; @@ -1353,20 +1353,20 @@ function Rectf(Left, Top, Right, Bottom: TGeoFloat): TRectf; {$ENDIF} -function FAbs(const v: Single): Single; +function FAbs(const V: Single): Single; begin - if v < 0 then - Result := -v + if V < 0 then + Result := -V else - Result := v; + Result := V; end; -function FAbs(const v: Double): Double; +function FAbs(const V: Double): Double; begin - if v < 0 then - Result := -v + if V < 0 then + Result := -V else - Result := v; + Result := V; end; function Clamp(const Value_, Min_, Max_: TGeoFloat): TGeoFloat; @@ -1582,10 +1582,10 @@ function LineV2(const l: PLineV2): TLineV2; Result := l^; end; -function RoundVec2(const v: TVec2): TVec2; +function RoundVec2(const V: TVec2): TVec2; begin - Result[0] := Round(v[0]); - Result[1] := Round(v[1]); + Result[0] := Round(V[0]); + Result[1] := Round(V[1]); end; function MakePointf(const pt: TVec2): TPointf; @@ -1594,9 +1594,9 @@ function MakePointf(const pt: TVec2): TPointf; Result.Y := pt[1]; end; -function IsZero(const v: TGeoFloat): Boolean; +function IsZero(const V: TGeoFloat): Boolean; begin - Result := IsEqual(v, 0, C_Epsilon); + Result := IsEqual(V, 0, C_Epsilon); end; function IsZero(const pt: TVec2): Boolean; @@ -1604,9 +1604,9 @@ function IsZero(const pt: TVec2): Boolean; Result := IsEqual(pt[0], 0, C_Epsilon) and IsEqual(pt[1], 0, C_Epsilon); end; -function IsZero(const r: TRectV2): Boolean; +function IsZero(const R: TRectV2): Boolean; begin - Result := IsZero(r[0]) and IsZero(r[1]); + Result := IsZero(R[0]) and IsZero(R[1]); end; function IsNan(const pt: TVec2): Boolean; @@ -1641,38 +1641,38 @@ function HypotX(const X, Y: Extended): TGeoFloat; Result := TempY * Sqrt(1 + Sqr(TempX / TempY)); end; -function PointNorm(const v: TVec2): TGeoFloat; +function PointNorm(const V: TVec2): TGeoFloat; begin - Result := v[0] * v[0] + v[1] * v[1]; + Result := V[0] * V[0] + V[1] * V[1]; end; -function PointNegate(const v: TVec2): TVec2; +function PointNegate(const V: TVec2): TVec2; begin - Result[0] := -v[0]; - Result[1] := -v[1]; + Result[0] := -V[0]; + Result[1] := -V[1]; end; -function Vec2Norm(const v: TVec2): TGeoFloat; +function Vec2Norm(const V: TVec2): TGeoFloat; begin - Result := v[0] * v[0] + v[1] * v[1]; + Result := V[0] * V[0] + V[1] * V[1]; end; -function Vec2Negate(const v: TVec2): TVec2; +function Vec2Negate(const V: TVec2): TVec2; begin - Result[0] := -v[0]; - Result[1] := -v[1]; + Result[0] := -V[0]; + Result[1] := -V[1]; end; -function vec2Inv(const v: TVec2): TVec2; +function vec2Inv(const V: TVec2): TVec2; begin - Result[0] := v[1]; - Result[1] := v[0]; + Result[0] := V[1]; + Result[1] := V[0]; end; -procedure SetVec2(var v: TVec2; const vSrc: TVec2); +procedure SetVec2(var V: TVec2; const vSrc: TVec2); begin - v[0] := vSrc[0]; - v[1] := vSrc[1]; + V[0] := vSrc[0]; + V[1] := vSrc[1]; end; function Vec2Direction(sour, dest: TVec2): TVec2; @@ -1853,52 +1853,52 @@ function Vec2Div(const v1: TGeoFloat; const v2: TVec2): TVec2; Result[1] := v1 / v2[1]; end; -function PointNormalize(const v: TVec2): TVec2; +function PointNormalize(const V: TVec2): TVec2; var InvLen: TGeoFloat; vn: TGeoFloat; begin - vn := PointNorm(v); + vn := PointNorm(V); if vn = 0 then - SetVec2(Result, v) + SetVec2(Result, V) else begin InvLen := 1 / Sqrt(vn); - Result[0] := v[0] * InvLen; - Result[1] := v[1] * InvLen; + Result[0] := V[0] * InvLen; + Result[1] := V[1] * InvLen; end; end; -function Vec2Normalize(const v: TVec2): TVec2; +function Vec2Normalize(const V: TVec2): TVec2; var InvLen: TGeoFloat; vn: TGeoFloat; begin - vn := PointNorm(v); + vn := PointNorm(V); if vn = 0 then - SetVec2(Result, v) + SetVec2(Result, V) else begin InvLen := 1 / Sqrt(vn); - Result[0] := v[0] * InvLen; - Result[1] := v[1] * InvLen; + Result[0] := V[0] * InvLen; + Result[1] := V[1] * InvLen; end; end; -function PointLength(const v: TVec2): TGeoFloat; +function PointLength(const V: TVec2): TGeoFloat; begin - Result := Sqrt(PointNorm(v)); + Result := Sqrt(PointNorm(V)); end; -function Vec2Length(const v: TVec2): TGeoFloat; +function Vec2Length(const V: TVec2): TGeoFloat; begin - Result := Sqrt(Vec2Norm(v)); + Result := Sqrt(Vec2Norm(V)); end; -procedure PointScale(var v: TVec2; factor: TGeoFloat); +procedure PointScale(var V: TVec2; factor: TGeoFloat); begin - v[0] := v[0] * factor; - v[1] := v[1] * factor; + V[0] := V[0] * factor; + V[1] := V[1] * factor; end; function PointDotProduct(const v1, v2: TVec2): TGeoFloat; @@ -2014,30 +2014,30 @@ function Vec2LerpTo(const sour, dest: TVec2; const d: TGeoFloat): TVec2; procedure SwapPoint(var v1, v2: TVec2); var - v: TVec2; + V: TVec2; begin - v := v1; + V := v1; v1 := v2; - v2 := v; + v2 := V; end; procedure SwapVec2(var v1, v2: TVec2); var - v: TVec2; + V: TVec2; begin - v := v1; + V := v1; v1 := v2; - v2 := v; + v2 := V; end; -function Pow(v: TGeoFloat): TGeoFloat; +function Pow(V: TGeoFloat): TGeoFloat; begin - Result := v * v; + Result := V * V; end; -function Pow(const v, n: TGeoFloat): TGeoFloat; +function Pow(const V, n: TGeoFloat): TGeoFloat; begin - Result := Math.Power(v, n); + Result := Math.Power(V, n); end; function MiddleVec2(const pt1, pt2: TVec2): TVec2; @@ -2211,16 +2211,16 @@ function Vec2Rotation(const sour_r: TRectV2; const axis: TVec2; const Angle: TGe Result := Vec2Rotation(axis, pt, NormalizeDegAngle(Vec2Angle(axis, pt) - Angle)); end; -function Vec2Rotation(const sour_r: TRectV2; const axis: TVec2; const Angle: TGeoFloat; const r: TRectV2): TRectV2; +function Vec2Rotation(const sour_r: TRectV2; const axis: TVec2; const Angle: TGeoFloat; const R: TRectV2): TRectV2; begin - Result[0] := Vec2Rotation(sour_r, axis, Angle, r[0]); - Result[1] := Vec2Rotation(sour_r, axis, Angle, r[1]); + Result[0] := Vec2Rotation(sour_r, axis, Angle, R[0]); + Result[1] := Vec2Rotation(sour_r, axis, Angle, R[1]); end; -function RectRotation(const axis: TVec2; const r: TRectV2; const Angle: TGeoFloat): TRectV2; +function RectRotation(const axis: TVec2; const R: TRectV2; const Angle: TGeoFloat): TRectV2; begin - Result[0] := Vec2Rotation(axis, r[0], Angle); - Result[1] := Vec2Rotation(axis, r[1], Angle); + Result[0] := Vec2Rotation(axis, R[0], Angle); + Result[1] := Vec2Rotation(axis, R[1], Angle); end; function CircleInCircle(const cp1, cp2: TVec2; const r1, r2: TGeoFloat): Boolean; @@ -2228,10 +2228,10 @@ function CircleInCircle(const cp1, cp2: TVec2; const r1, r2: TGeoFloat): Boolean Result := (r2 - (PointDistance(cp1, cp2) + r1) >= Zero); end; -function CircleInRect(const cp: TVec2; const radius: TGeoFloat; r: TRectV2): Boolean; +function CircleInRect(const cp: TVec2; const radius: TGeoFloat; R: TRectV2): Boolean; begin - FixRect(r[0, 0], r[0, 1], r[1, 0], r[1, 1]); - Result := PointInRect(cp, MakeRect(Vec2Sub(r[0], radius), Vec2Add(r[1], radius))); + FixRect(R[0, 0], R[0, 1], R[1, 0], R[1, 1]); + Result := PointInRect(cp, MakeRect(Vec2Sub(R[0], radius), Vec2Add(R[1], radius))); end; function PointInRect(const Px, Py: TGeoFloat; const x1, y1, x2, y2: TGeoFloat): Boolean; @@ -2244,24 +2244,24 @@ function PointInRect(const Px, Py: TGeoInt; const x1, y1, x2, y2: TGeoInt): Bool Result := ((x1 <= Px) and (Px <= x2) and (y1 <= Py) and (Py <= y2)) or ((x2 <= Px) and (Px <= x1) and (y2 <= Py) and (Py <= y1)); end; -function PointInRect(const X, Y: TGeoInt; const r: TRect): Boolean; +function PointInRect(const X, Y: TGeoInt; const R: TRect): Boolean; begin - Result := PointInRect(X, Y, r.Left, r.Top, r.Right, r.Bottom); + Result := PointInRect(X, Y, R.Left, R.Top, R.Right, R.Bottom); end; -function PointInRect(const pt: TPoint; const r: TRect): Boolean; +function PointInRect(const pt: TPoint; const R: TRect): Boolean; begin - Result := PointInRect(pt.X, pt.Y, r.Left, r.Top, r.Right, r.Bottom); + Result := PointInRect(pt.X, pt.Y, R.Left, R.Top, R.Right, R.Bottom); end; -function PointInRect(const pt: TVec2; const r: TRectV2): Boolean; +function PointInRect(const pt: TVec2; const R: TRectV2): Boolean; begin - Result := PointInRect(pt[0], pt[1], r[0, 0], r[0, 1], r[1, 0], r[1, 1]); + Result := PointInRect(pt[0], pt[1], R[0, 0], R[0, 1], R[1, 0], R[1, 1]); end; -function PointInRect(const Px, Py: TGeoFloat; const r: TRectV2): Boolean; +function PointInRect(const Px, Py: TGeoFloat; const R: TRectV2): Boolean; begin - Result := PointInRect(Px, Py, r[0, 0], r[0, 1], r[1, 0], r[1, 1]); + Result := PointInRect(Px, Py, R[0, 0], R[0, 1], R[1, 0], R[1, 1]); end; function Vec2InRect(const Px, Py: TGeoFloat; const x1, y1, x2, y2: TGeoFloat): Boolean; @@ -2274,14 +2274,14 @@ function Vec2InRect(const Px, Py: TGeoInt; const x1, y1, x2, y2: TGeoInt): Boole Result := ((x1 <= Px) and (Px <= x2) and (y1 <= Py) and (Py <= y2)) or ((x2 <= Px) and (Px <= x1) and (y2 <= Py) and (Py <= y1)); end; -function Vec2InRect(const pt: TVec2; const r: TRectV2): Boolean; +function Vec2InRect(const pt: TVec2; const R: TRectV2): Boolean; begin - Result := Vec2InRect(pt[0], pt[1], r[0, 0], r[0, 1], r[1, 0], r[1, 1]); + Result := Vec2InRect(pt[0], pt[1], R[0, 0], R[0, 1], R[1, 0], R[1, 1]); end; -function Vec2InRect(const Px, Py: TGeoFloat; const r: TRectV2): Boolean; +function Vec2InRect(const Px, Py: TGeoFloat; const R: TRectV2): Boolean; begin - Result := Vec2InRect(Px, Py, r[0, 0], r[0, 1], r[1, 0], r[1, 1]); + Result := Vec2InRect(Px, Py, R[0, 0], R[0, 1], R[1, 0], R[1, 1]); end; function RectToRectIntersect(const x1, y1, x2, y2, x3, y3, x4, y4: TGeoFloat): Boolean; @@ -2385,20 +2385,20 @@ function MakeRectV2(const X, Y: TGeoFloat; const p2: TVec2): TRectV2; Result[1] := p2; end; -function MakeRectV2(const r: TRect): TRectV2; +function MakeRectV2(const R: TRect): TRectV2; begin - Result[0, 0] := r.Left; - Result[0, 1] := r.Top; - Result[1, 0] := r.Right; - Result[1, 1] := r.Bottom; + Result[0, 0] := R.Left; + Result[0, 1] := R.Top; + Result[1, 0] := R.Right; + Result[1, 1] := R.Bottom; end; -function MakeRectV2(const r: TRectf): TRectV2; +function MakeRectV2(const R: TRectf): TRectV2; begin - Result[0, 0] := r.Left; - Result[0, 1] := r.Top; - Result[1, 0] := r.Right; - Result[1, 1] := r.Bottom; + Result[0, 0] := R.Left; + Result[0, 1] := R.Top; + Result[1, 0] := R.Right; + Result[1, 1] := R.Bottom; end; function RectV2(): TRectV2; @@ -2448,25 +2448,25 @@ function RectV2(const X, Y: TGeoFloat; const p2: TVec2): TRectV2; Result[1] := p2; end; -function RectV2(const r: TRect): TRectV2; +function RectV2(const R: TRect): TRectV2; begin - Result[0, 0] := r.Left; - Result[0, 1] := r.Top; - Result[1, 0] := r.Right; - Result[1, 1] := r.Bottom; + Result[0, 0] := R.Left; + Result[0, 1] := R.Top; + Result[1, 0] := R.Right; + Result[1, 1] := R.Bottom; end; -function RectV2(const r: TRectf): TRectV2; +function RectV2(const R: TRectf): TRectV2; begin - Result[0, 0] := r.Left; - Result[0, 1] := r.Top; - Result[1, 0] := r.Right; - Result[1, 1] := r.Bottom; + Result[0, 0] := R.Left; + Result[0, 1] := R.Top; + Result[1, 0] := R.Right; + Result[1, 1] := R.Bottom; end; -function RectV2(const r: TRectV2): TRectV2; +function RectV2(const R: TRectV2): TRectV2; begin - Result := FixedRect(r); + Result := FixedRect(R); end; function MakeRect(const centre: TVec2; const width, height: TGeoFloat): TRectV2; @@ -2499,52 +2499,52 @@ function MakeRect(const p1, p2: TVec2): TRectV2; Result[1] := p2; end; -function MakeRect(const r: TRect): TRectV2; +function MakeRect(const R: TRect): TRectV2; begin - Result[0, 0] := r.Left; - Result[0, 1] := r.Top; - Result[1, 0] := r.Right; - Result[1, 1] := r.Bottom; + Result[0, 0] := R.Left; + Result[0, 1] := R.Top; + Result[1, 0] := R.Right; + Result[1, 1] := R.Bottom; end; -function MakeRect(const r: TRectf): TRectV2; +function MakeRect(const R: TRectf): TRectV2; begin - Result[0, 0] := r.Left; - Result[0, 1] := r.Top; - Result[1, 0] := r.Right; - Result[1, 1] := r.Bottom; + Result[0, 0] := R.Left; + Result[0, 1] := R.Top; + Result[1, 0] := R.Right; + Result[1, 1] := R.Bottom; end; -function RoundRect(const r: TRectV2): TRect; +function RoundRect(const R: TRectV2): TRect; begin - Result.Left := Round(r[0, 0]); - Result.Top := Round(r[0, 1]); - Result.Right := Round(r[1, 0]); - Result.Bottom := Round(r[1, 1]); + Result.Left := Round(R[0, 0]); + Result.Top := Round(R[0, 1]); + Result.Right := Round(R[1, 0]); + Result.Bottom := Round(R[1, 1]); end; -function RoundRectV2(const r: TRectV2): TRectV2; +function RoundRectV2(const R: TRectV2): TRectV2; begin - Result[0, 0] := Round(r[0, 0]); - Result[0, 1] := Round(r[0, 1]); - Result[1, 0] := Round(r[1, 0]); - Result[1, 1] := Round(r[1, 1]); + Result[0, 0] := Round(R[0, 0]); + Result[0, 1] := Round(R[0, 1]); + Result[1, 0] := Round(R[1, 0]); + Result[1, 1] := Round(R[1, 1]); end; -function Rect2Rect(const r: TRectV2): TRect; +function Rect2Rect(const R: TRectV2): TRect; begin - Result.Left := Round(r[0, 0]); - Result.Top := Round(r[0, 1]); - Result.Right := Round(r[1, 0]); - Result.Bottom := Round(r[1, 1]); + Result.Left := Round(R[0, 0]); + Result.Top := Round(R[0, 1]); + Result.Right := Round(R[1, 0]); + Result.Bottom := Round(R[1, 1]); end; -function Rect2Rect(const r: TRect): TRectV2; +function Rect2Rect(const R: TRect): TRectV2; begin - Result[0, 0] := r.Left; - Result[0, 1] := r.Top; - Result[1, 0] := r.Right; - Result[1, 1] := r.Bottom; + Result[0, 0] := R.Left; + Result[0, 1] := R.Top; + Result[1, 0] := R.Right; + Result[1, 1] := R.Bottom; end; function RectMake(const X, Y, radius: TGeoFloat): TRectV2; @@ -2569,26 +2569,26 @@ function RectMake(const p1, p2: TVec2): TRectV2; Result[1] := p2; end; -function RectMake(const r: TRect): TRectV2; +function RectMake(const R: TRect): TRectV2; begin - Result[0, 0] := r.Left; - Result[0, 1] := r.Top; - Result[1, 0] := r.Right; - Result[1, 1] := r.Bottom; + Result[0, 0] := R.Left; + Result[0, 1] := R.Top; + Result[1, 0] := R.Right; + Result[1, 1] := R.Bottom; end; -function RectMake(const r: TRectf): TRectV2; +function RectMake(const R: TRectf): TRectV2; begin - Result[0, 0] := r.Left; - Result[0, 1] := r.Top; - Result[1, 0] := r.Right; - Result[1, 1] := r.Bottom; + Result[0, 0] := R.Left; + Result[0, 1] := R.Top; + Result[1, 0] := R.Right; + Result[1, 1] := R.Bottom; end; -function RectAdd(const r: TRectV2; v2: TVec2): TRectV2; +function RectAdd(const R: TRectV2; v2: TVec2): TRectV2; begin - Result[0] := Vec2Add(r[0], v2); - Result[1] := Vec2Add(r[1], v2); + Result[0] := Vec2Add(R[0], v2); + Result[1] := Vec2Add(R[1], v2); end; function RectAdd(const r1, r2: TRectV2): TRectV2; @@ -2603,10 +2603,10 @@ function RectSub(const r1, r2: TRectV2): TRectV2; Result[1] := Vec2Sub(r1[1], r2[1]); end; -function RectSub(const r: TRectV2; pt: TVec2): TRectV2; +function RectSub(const R: TRectV2; pt: TVec2): TRectV2; begin - Result[0] := Vec2Sub(r[0], pt); - Result[1] := Vec2Sub(r[1], pt); + Result[0] := Vec2Sub(R[0], pt); + Result[1] := Vec2Sub(R[1], pt); end; function RectMul(const r1, r2: TRectV2): TRectV2; @@ -2645,57 +2645,57 @@ function RectDiv(const r1: TRectV2; v2: TVec2): TRectV2; Result[1] := Vec2Div(r1[1], v2); end; -function RectOffset(const r: TRectV2; Offset: TVec2): TRectV2; +function RectOffset(const R: TRectV2; Offset: TVec2): TRectV2; begin - Result[0] := Vec2Add(r[0], Offset); - Result[1] := Vec2Add(r[1], Offset); + Result[0] := Vec2Add(R[0], Offset); + Result[1] := Vec2Add(R[1], Offset); end; -function RectSizeLerp(const r: TRectV2; const rSizeLerp: TGeoFloat): TRectV2; +function RectSizeLerp(const R: TRectV2; const rSizeLerp: TGeoFloat): TRectV2; begin - Result[0] := r[0]; - Result[1] := PointLerp(r[0], r[1], rSizeLerp); + Result[0] := R[0]; + Result[1] := PointLerp(R[0], R[1], rSizeLerp); end; -function RectCenScale(const r: TRectV2; const rSizeScale: TGeoFloat): TRectV2; +function RectCenScale(const R: TRectV2; const rSizeScale: TGeoFloat): TRectV2; var cen, siz: TVec2; begin - cen := PointLerp(r[0], r[1], 0.5); - siz := Vec2Mul(RectSize(r), rSizeScale); + cen := PointLerp(R[0], R[1], 0.5); + siz := Vec2Mul(RectSize(R), rSizeScale); Result[0] := Vec2Sub(cen, Vec2Mul(siz, 0.5)); Result[1] := Vec2Add(cen, Vec2Mul(siz, 0.5)); end; -function RectEdge(const r: TRectV2; const Edge: TGeoFloat): TRectV2; +function RectEdge(const R: TRectV2; const Edge: TGeoFloat): TRectV2; begin - Result[0, 0] := r[0, 0] - Edge; - Result[0, 1] := r[0, 1] - Edge; - Result[1, 0] := r[1, 0] + Edge; - Result[1, 1] := r[1, 1] + Edge; + Result[0, 0] := R[0, 0] - Edge; + Result[0, 1] := R[0, 1] - Edge; + Result[1, 0] := R[1, 0] + Edge; + Result[1, 1] := R[1, 1] + Edge; end; -function RectEdge(const r: TRectV2; const Edge: TVec2): TRectV2; +function RectEdge(const R: TRectV2; const Edge: TVec2): TRectV2; begin - Result[0, 0] := r[0, 0] - Edge[0]; - Result[0, 1] := r[0, 1] - Edge[1]; - Result[1, 0] := r[1, 0] + Edge[0]; - Result[1, 1] := r[1, 1] + Edge[1]; + Result[0, 0] := R[0, 0] - Edge[0]; + Result[0, 1] := R[0, 1] - Edge[1]; + Result[1, 0] := R[1, 0] + Edge[0]; + Result[1, 1] := R[1, 1] + Edge[1]; end; -function RectCentre(const r: TRectV2): TVec2; +function RectCentre(const R: TRectV2): TVec2; begin - Result := PointLerp(r[0], r[1], 0.5); + Result := PointLerp(R[0], R[1], 0.5); end; -function RectCentre(const r: TRect): TVec2; +function RectCentre(const R: TRect): TVec2; begin - Result := RectCentre(RectV2(r)); + Result := RectCentre(RectV2(R)); end; -function RectCentre(const r: TRectf): TVec2; +function RectCentre(const R: TRectf): TVec2; begin - Result := RectCentre(RectV2(r)); + Result := RectCentre(RectV2(R)); end; function Tri(const v1, v2, v3: TVec2): TTriangle; @@ -2705,32 +2705,32 @@ function Tri(const v1, v2, v3: TVec2): TTriangle; Result[2] := v3; end; -function TriAdd(const t: TTriangle; v: TVec2): TTriangle; +function TriAdd(const t: TTriangle; V: TVec2): TTriangle; begin - Result[0] := Vec2Add(t[0], v); - Result[1] := Vec2Add(t[1], v); - Result[2] := Vec2Add(t[2], v); + Result[0] := Vec2Add(t[0], V); + Result[1] := Vec2Add(t[1], V); + Result[2] := Vec2Add(t[2], V); end; -function TriSub(const t: TTriangle; v: TVec2): TTriangle; +function TriSub(const t: TTriangle; V: TVec2): TTriangle; begin - Result[0] := Vec2Sub(t[0], v); - Result[1] := Vec2Sub(t[1], v); - Result[2] := Vec2Sub(t[2], v); + Result[0] := Vec2Sub(t[0], V); + Result[1] := Vec2Sub(t[1], V); + Result[2] := Vec2Sub(t[2], V); end; -function TriMul(const t: TTriangle; v: TVec2): TTriangle; +function TriMul(const t: TTriangle; V: TVec2): TTriangle; begin - Result[0] := Vec2Mul(t[0], v); - Result[1] := Vec2Mul(t[1], v); - Result[2] := Vec2Mul(t[2], v); + Result[0] := Vec2Mul(t[0], V); + Result[1] := Vec2Mul(t[1], V); + Result[2] := Vec2Mul(t[2], V); end; -function TriDiv(const t: TTriangle; v: TVec2): TTriangle; +function TriDiv(const t: TTriangle; V: TVec2): TTriangle; begin - Result[0] := Vec2Div(t[0], v); - Result[1] := Vec2Div(t[1], v); - Result[2] := Vec2Div(t[2], v); + Result[0] := Vec2Div(t[0], V); + Result[1] := Vec2Div(t[1], V); + Result[2] := Vec2Div(t[2], V); end; function TriCentre(const t: TTriangle): TVec2; @@ -2747,7 +2747,7 @@ function TriExpand(const t: TTriangle; Dist: TGeoFloat): TTriangle; var lpt, pt, rpt: TVec2; ln, rn: TVec2; - dx, dy, f, r: TGeoFloat; + dx, dy, f, R: TGeoFloat; Cx, Cy: TGeoFloat; begin if idx > 0 then @@ -2777,11 +2777,11 @@ function TriExpand(const t: TTriangle; Dist: TGeoFloat): TTriangle; // compute the expand edge dx := (ln[0] + rn[0]); dy := (ln[1] + rn[1]); - r := (ln[0] * dx) + (ln[1] * dy); - if r = 0 then - r := 1; - Cx := (dx * Dist / r); - Cy := (dy * Dist / r); + R := (ln[0] * dx) + (ln[1] * dy); + if R = 0 then + R := 1; + Cx := (dx * Dist / R); + Cy := (dy * Dist / R); Result[0] := pt[0] + Cx; Result[1] := pt[1] + Cy; @@ -2825,14 +2825,14 @@ function RectTransform(const sour, dest: TRectV2; const sour_rect: TRectf): TRec Result := RectProjection(sour, dest, RectV2(sour_rect)); end; -function RectScaleSpace(const r: TRectV2; const SS_width, SS_height: TGeoFloat): TRectV2; +function RectScaleSpace(const R: TRectV2; const SS_width, SS_height: TGeoFloat): TRectV2; var k: TGeoFloat; w, h, nw, nh: TGeoFloat; d: TVec2; begin k := SS_width / SS_height; - Result := ForwardRect(r); + Result := ForwardRect(R); w := RectWidth(Result); h := RectHeight(Result); @@ -2855,16 +2855,16 @@ function RectScaleSpace(const r: TRectV2; const SS_width, SS_height: TGeoFloat): Result := FixRect(Result); end; -function RectScaleSpace(const r: TRect; const SS_width, SS_height: TGeoInt): TRect; +function RectScaleSpace(const R: TRect; const SS_width, SS_height: TGeoInt): TRect; begin - Result := MakeRect(RectScaleSpace(RectV2(r), SS_width, SS_height)); + Result := MakeRect(RectScaleSpace(RectV2(R), SS_width, SS_height)); end; -function CalibrationRectInRect(const r, Area: TRectV2): TRectV2; +function CalibrationRectInRect(const R, Area: TRectV2): TRectV2; var nr: TRectV2; begin - nr := ForwardRect(r); + nr := ForwardRect(R); if nr[0, 0] < Area[0, 0] then nr := RectOffset(nr, vec2(Area[0, 0] - nr[0, 0], 0)); @@ -2878,9 +2878,9 @@ function CalibrationRectInRect(const r, Area: TRectV2): TRectV2; Result := Clip(nr, Area); end; -function CalibrationRectInRect(const r, Area: TRect): TRect; +function CalibrationRectInRect(const R, Area: TRect): TRect; begin - Result := MakeRect(CalibrationRectInRect(RectV2(r), RectV2(Area))); + Result := MakeRect(CalibrationRectInRect(RectV2(R), RectV2(Area))); end; procedure FixRect(var Left, Top, Right, Bottom: TGeoInt); @@ -2899,15 +2899,15 @@ procedure FixRect(var Left, Top, Right, Bottom: TGeoFloat); Swap(Right, Left); end; -function FixRect(r: TRectV2): TRectV2; +function FixRect(R: TRectV2): TRectV2; begin - Result := r; + Result := R; FixRect(Result[0, 0], Result[0, 1], Result[1, 0], Result[1, 1]); end; -function FixRect(r: TRect): TRect; +function FixRect(R: TRect): TRect; begin - Result := r; + Result := R; FixRect(Result.Left, Result.Top, Result.Right, Result.Bottom); end; @@ -2927,15 +2927,15 @@ procedure FixedRect(var Left, Top, Right, Bottom: TGeoFloat); Swap(Right, Left); end; -function FixedRect(r: TRectV2): TRectV2; +function FixedRect(R: TRectV2): TRectV2; begin - Result := r; + Result := R; FixedRect(Result[0, 0], Result[0, 1], Result[1, 0], Result[1, 1]); end; -function FixedRect(r: TRect): TRect; +function FixedRect(R: TRect): TRect; begin - Result := r; + Result := R; FixedRect(Result.Left, Result.Top, Result.Right, Result.Bottom); end; @@ -2955,152 +2955,152 @@ procedure ForwardRect(var Left, Top, Right, Bottom: TGeoFloat); Swap(Right, Left); end; -function ForwardRect(r: TRectV2): TRectV2; +function ForwardRect(R: TRectV2): TRectV2; begin - Result := r; + Result := R; ForwardRect(Result[0, 0], Result[0, 1], Result[1, 0], Result[1, 1]); end; -function ForwardRect(r: TRect): TRect; +function ForwardRect(R: TRect): TRect; begin - Result := r; + Result := R; ForwardRect(Result.Left, Result.Top, Result.Right, Result.Bottom); end; -function MakeRect(const r: TRectV2): TRect; +function MakeRect(const R: TRectV2): TRect; begin - Result.Left := Round(r[0, 0]); - Result.Top := Round(r[0, 1]); - Result.Right := Round(r[1, 0]); - Result.Bottom := Round(r[1, 1]); + Result.Left := Round(R[0, 0]); + Result.Top := Round(R[0, 1]); + Result.Right := Round(R[1, 0]); + Result.Bottom := Round(R[1, 1]); end; -function MakeRectf(const r: TRectV2): TRectf; +function MakeRectf(const R: TRectV2): TRectf; begin - Result.Left := r[0, 0]; - Result.Top := r[0, 1]; - Result.Right := r[1, 0]; - Result.Bottom := r[1, 1]; + Result.Left := R[0, 0]; + Result.Top := R[0, 1]; + Result.Right := R[1, 0]; + Result.Bottom := R[1, 1]; end; -function RectWidth(const r: TRectV2): TGeoFloat; +function RectWidth(const R: TRectV2): TGeoFloat; begin - if r[1, 0] > r[0, 0] then - Result := r[1, 0] - r[0, 0] + if R[1, 0] > R[0, 0] then + Result := R[1, 0] - R[0, 0] else - Result := r[0, 0] - r[1, 0]; + Result := R[0, 0] - R[1, 0]; end; -function RectHeight(const r: TRectV2): TGeoFloat; +function RectHeight(const R: TRectV2): TGeoFloat; begin - if r[1, 1] > r[0, 1] then - Result := r[1, 1] - r[0, 1] + if R[1, 1] > R[0, 1] then + Result := R[1, 1] - R[0, 1] else - Result := r[0, 1] - r[1, 1]; + Result := R[0, 1] - R[1, 1]; end; -function RectWidth(const r: TRect): TGeoInt; +function RectWidth(const R: TRect): TGeoInt; begin - if r.Right > r.Left then - Result := r.Right - r.Left + if R.Right > R.Left then + Result := R.Right - R.Left else - Result := r.Left - r.Right; + Result := R.Left - R.Right; end; -function RectHeight(const r: TRect): TGeoInt; +function RectHeight(const R: TRect): TGeoInt; begin - if r.Bottom > r.Top then - Result := r.Bottom - r.Top + if R.Bottom > R.Top then + Result := R.Bottom - R.Top else - Result := r.Top - r.Bottom; + Result := R.Top - R.Bottom; end; -function RectWidth(const r: TRectf): TGeoFloat; +function RectWidth(const R: TRectf): TGeoFloat; begin - if r.Right > r.Left then - Result := r.Right - r.Left + if R.Right > R.Left then + Result := R.Right - R.Left else - Result := r.Left - r.Right; + Result := R.Left - R.Right; end; -function RectHeight(const r: TRectf): TGeoFloat; +function RectHeight(const R: TRectf): TGeoFloat; begin - if r.Bottom > r.Top then - Result := r.Bottom - r.Top + if R.Bottom > R.Top then + Result := R.Bottom - R.Top else - Result := r.Top - r.Bottom; + Result := R.Top - R.Bottom; end; -function RoundWidth(const r: TRectV2): TGeoInt; +function RoundWidth(const R: TRectV2): TGeoInt; begin - if r[1, 0] > r[0, 0] then - Result := Round(r[1, 0] - r[0, 0]) + if R[1, 0] > R[0, 0] then + Result := Round(R[1, 0] - R[0, 0]) else - Result := Round(r[0, 0] - r[1, 0]); + Result := Round(R[0, 0] - R[1, 0]); end; -function RoundHeight(const r: TRectV2): TGeoInt; +function RoundHeight(const R: TRectV2): TGeoInt; begin - if r[1, 1] > r[0, 1] then - Result := Round(r[1, 1] - r[0, 1]) + if R[1, 1] > R[0, 1] then + Result := Round(R[1, 1] - R[0, 1]) else - Result := Round(r[0, 1] - r[1, 1]); + Result := Round(R[0, 1] - R[1, 1]); end; -function RoundWidth(const r: TRect): TGeoInt; +function RoundWidth(const R: TRect): TGeoInt; begin - if r.Right > r.Left then - Result := r.Right - r.Left + if R.Right > R.Left then + Result := R.Right - R.Left else - Result := r.Left - r.Right; + Result := R.Left - R.Right; end; -function RoundHeight(const r: TRect): TGeoInt; +function RoundHeight(const R: TRect): TGeoInt; begin - if r.Bottom > r.Top then - Result := r.Bottom - r.Top + if R.Bottom > R.Top then + Result := R.Bottom - R.Top else - Result := r.Top - r.Bottom; + Result := R.Top - R.Bottom; end; -function RoundWidth(const r: TRectf): TGeoInt; +function RoundWidth(const R: TRectf): TGeoInt; begin - if r.Right > r.Left then - Result := Round(r.Right - r.Left) + if R.Right > R.Left then + Result := Round(R.Right - R.Left) else - Result := Round(r.Left - r.Right); + Result := Round(R.Left - R.Right); end; -function RoundHeight(const r: TRectf): TGeoInt; +function RoundHeight(const R: TRectf): TGeoInt; begin - if r.Bottom > r.Top then - Result := Round(r.Bottom - r.Top) + if R.Bottom > R.Top then + Result := Round(R.Bottom - R.Top) else - Result := Round(r.Top - r.Bottom); + Result := Round(R.Top - R.Bottom); end; -function RectArea(const r: TRectV2): TGeoFloat; +function RectArea(const R: TRectV2): TGeoFloat; begin - Result := RectWidth(r) * RectHeight(r); + Result := RectWidth(R) * RectHeight(R); end; -function RectArea(const r: TRect): TGeoInt; +function RectArea(const R: TRect): TGeoInt; begin - Result := RoundWidth(r) * RoundHeight(r); + Result := RoundWidth(R) * RoundHeight(R); end; -function RectSize(const r: TRectV2): TVec2; +function RectSize(const R: TRectV2): TVec2; var n: TRectV2; begin - n := FixRect(r); + n := FixRect(R); Result := Vec2Sub(n[1], n[0]); end; -function RectSizeR(const r: TRectV2): TRectV2; +function RectSizeR(const R: TRectV2): TRectV2; begin Result[0] := ZeroVec2; - Result[1] := RectSize(r) + Result[1] := RectSize(R) end; function RectFit(const sour, dest: TRectV2; const Bound: Boolean): TRectV2; @@ -4201,9 +4201,9 @@ procedure ProjectionPoint(const Px, Py, Angle, Distance: TGeoFloat; out Nx, Ny: Ny := Py + dy; end; -function GetCicleRadiusInPolyEdge(r: TGeoFloat; PolySlices: TGeoInt): TGeoFloat; +function GetCicleRadiusInPolyEdge(R: TGeoFloat; PolySlices: TGeoInt): TGeoFloat; begin - Result := r / Sin((180 - 360 / PolySlices) * 0.5 / 180 * pi); + Result := R / Sin((180 - 360 / PolySlices) * 0.5 / 180 * pi); end; procedure Circle2LineIntersectionPoint(const lb, le, cp: TVec2; const radius: TGeoFloat; @@ -4398,24 +4398,24 @@ function Detect_Circle2CirclePoint(const p1, p2: TVec2; const r1, r2: TGeoFloat; // circle 2 line collision -function Detect_Circle2Line(const cp: TVec2; const r: TGeoFloat; const lb, le: TVec2): Boolean; +function Detect_Circle2Line(const cp: TVec2; const R: TGeoFloat; const lb, le: TVec2): Boolean; var lineCen, v1, v2: TVec2; begin lineCen := PointLerp(lb, le, 0.5); - if Detect_Circle2Circle(cp, lineCen, r, PointDistance(lb, le) * 0.5) then + if Detect_Circle2Circle(cp, lineCen, R, PointDistance(lb, le) * 0.5) then begin v1 := Vec2Sub(lb, cp); v2 := Vec2Sub(le, cp); - Result := GreaterThanOrEqual(((r * r) * PointLayDistance(v1, v2) - Sqr(v1[0] * v2[1] - v1[1] * v2[0])), Zero); + Result := GreaterThanOrEqual(((R * R) * PointLayDistance(v1, v2) - Sqr(v1[0] * v2[1] - v1[1] * v2[0])), Zero); end else Result := False; end; -function Detect_Circle2Line(const cp: TVec2; const r: TGeoFloat; const l: TLineV2): Boolean; +function Detect_Circle2Line(const cp: TVec2; const R: TGeoFloat; const l: TLineV2): Boolean; begin - Result := Detect_Circle2Line(cp, r, l[0], l[1]); + Result := Detect_Circle2Line(cp, R, l[0], l[1]); end; function SameLinePtr(const lb1, le1, lb2, le2: PVec2): Boolean; @@ -4554,36 +4554,36 @@ function TV2Rect4.TransformToRect(Box: TRectV2; axis: TVec2; Angle, Edge: TGeoFl Result.LeftBottom := RectProjectionRotationDest(boxSelf, nArea, axis, Angle, LeftBottom); end; -function TV2Rect4.Add(v: TVec2): TV2Rect4; +function TV2Rect4.Add(V: TVec2): TV2Rect4; begin - Result.LeftTop := Vec2Add(LeftTop, v); - Result.RightTop := Vec2Add(RightTop, v); - Result.RightBottom := Vec2Add(RightBottom, v); - Result.LeftBottom := Vec2Add(LeftBottom, v); + Result.LeftTop := Vec2Add(LeftTop, V); + Result.RightTop := Vec2Add(RightTop, V); + Result.RightBottom := Vec2Add(RightBottom, V); + Result.LeftBottom := Vec2Add(LeftBottom, V); end; -function TV2Rect4.Sub(v: TVec2): TV2Rect4; +function TV2Rect4.Sub(V: TVec2): TV2Rect4; begin - Result.LeftTop := Vec2Sub(LeftTop, v); - Result.RightTop := Vec2Sub(RightTop, v); - Result.RightBottom := Vec2Sub(RightBottom, v); - Result.LeftBottom := Vec2Sub(LeftBottom, v); + Result.LeftTop := Vec2Sub(LeftTop, V); + Result.RightTop := Vec2Sub(RightTop, V); + Result.RightBottom := Vec2Sub(RightBottom, V); + Result.LeftBottom := Vec2Sub(LeftBottom, V); end; -function TV2Rect4.Mul(v: TVec2): TV2Rect4; +function TV2Rect4.Mul(V: TVec2): TV2Rect4; begin - Result.LeftTop := Vec2Mul(LeftTop, v); - Result.RightTop := Vec2Mul(RightTop, v); - Result.RightBottom := Vec2Mul(RightBottom, v); - Result.LeftBottom := Vec2Mul(LeftBottom, v); + Result.LeftTop := Vec2Mul(LeftTop, V); + Result.RightTop := Vec2Mul(RightTop, V); + Result.RightBottom := Vec2Mul(RightBottom, V); + Result.LeftBottom := Vec2Mul(LeftBottom, V); end; -function TV2Rect4.Mul(v: TGeoFloat): TV2Rect4; +function TV2Rect4.Mul(V: TGeoFloat): TV2Rect4; begin - Result.LeftTop := Vec2Mul(LeftTop, v); - Result.RightTop := Vec2Mul(RightTop, v); - Result.RightBottom := Vec2Mul(RightBottom, v); - Result.LeftBottom := Vec2Mul(LeftBottom, v); + Result.LeftTop := Vec2Mul(LeftTop, V); + Result.RightTop := Vec2Mul(RightTop, V); + Result.RightBottom := Vec2Mul(RightBottom, V); + Result.LeftBottom := Vec2Mul(LeftBottom, V); end; function TV2Rect4.Mul(X, Y: TGeoFloat): TV2Rect4; @@ -4594,20 +4594,20 @@ function TV2Rect4.Mul(X, Y: TGeoFloat): TV2Rect4; Result.LeftBottom := Vec2Mul(LeftBottom, X, Y); end; -function TV2Rect4.Div_(v: TVec2): TV2Rect4; +function TV2Rect4.Div_(V: TVec2): TV2Rect4; begin - Result.LeftTop := Vec2Div(LeftTop, v); - Result.RightTop := Vec2Div(RightTop, v); - Result.RightBottom := Vec2Div(RightBottom, v); - Result.LeftBottom := Vec2Div(LeftBottom, v); + Result.LeftTop := Vec2Div(LeftTop, V); + Result.RightTop := Vec2Div(RightTop, V); + Result.RightBottom := Vec2Div(RightBottom, V); + Result.LeftBottom := Vec2Div(LeftBottom, V); end; -function TV2Rect4.Div_(v: TGeoFloat): TV2Rect4; +function TV2Rect4.Div_(V: TGeoFloat): TV2Rect4; begin - Result.LeftTop := Vec2Div(LeftTop, v); - Result.RightTop := Vec2Div(RightTop, v); - Result.RightBottom := Vec2Div(RightBottom, v); - Result.LeftBottom := Vec2Div(LeftBottom, v); + Result.LeftTop := Vec2Div(LeftTop, V); + Result.RightTop := Vec2Div(RightTop, V); + Result.RightBottom := Vec2Div(RightBottom, V); + Result.LeftBottom := Vec2Div(LeftBottom, V); end; function TV2Rect4.MoveTo(Position: TVec2): TV2Rect4; @@ -4671,12 +4671,12 @@ function TV2Rect4.InHere(pt: TVec2): Boolean; SetLength(buff, 0); end; -function TV2Rect4.InHere(r: TRectV2): Boolean; +function TV2Rect4.InHere(R: TRectV2): Boolean; var buff: TArrayVec2; begin buff := GetArrayVec2; - Result := PointInPolygon(r[0], buff) and PointInPolygon(r[1], buff); + Result := PointInPolygon(R[0], buff) and PointInPolygon(R[1], buff); SetLength(buff, 0); end; @@ -4724,7 +4724,7 @@ function TV2Rect4.GetNear(pt: TVec2): TVec2; end; end; -function TV2Rect4.GetNearLine(const v: TVec2; out lb, le: PVec2): TVec2; +function TV2Rect4.GetNearLine(const V: TVec2; out lb, le: PVec2): TVec2; var Arry_: array [0 .. 4] of PVec2; i: TGeoInt; @@ -4743,8 +4743,8 @@ function TV2Rect4.GetNearLine(const v: TVec2; out lb, le: PVec2): TVec2; for i := 1 to 4 do begin pt2 := Arry_[i]; - opt := ClosestPointOnSegmentFromPoint(pt1^, pt2^, v); - d2 := PointDistance(v, opt); + opt := ClosestPointOnSegmentFromPoint(pt1^, pt2^, V); + d2 := PointDistance(V, opt); if (i = 1) or (d2 < d) then begin Result := opt; @@ -4756,7 +4756,7 @@ function TV2Rect4.GetNearLine(const v: TVec2; out lb, le: PVec2): TVec2; end; end; -function TV2Rect4.GetNearLine(const v: TVec2): TVec2; +function TV2Rect4.GetNearLine(const V: TVec2): TVec2; var Arry_: array [0 .. 4] of PVec2; i: TGeoInt; @@ -4775,8 +4775,8 @@ function TV2Rect4.GetNearLine(const v: TVec2): TVec2; for i := 1 to 4 do begin pt2 := Arry_[i]; - opt := ClosestPointOnSegmentFromPoint(pt1^, pt2^, v); - d2 := PointDistance(v, opt); + opt := ClosestPointOnSegmentFromPoint(pt1^, pt2^, V); + d2 := PointDistance(V, opt); if (i = 1) or (d2 < d) then begin Result := opt; @@ -4842,67 +4842,67 @@ class function TV2Rect4.RebuildVertex(const buff: TVec2List): TV2Rect4; end; end; -class function TV2Rect4.Init(r: TRectV2): TV2Rect4; +class function TV2Rect4.Init(R: TRectV2): TV2Rect4; begin with Result do begin - LeftTop := PointMake(r[0, 0], r[0, 1]); - RightTop := PointMake(r[1, 0], r[0, 1]); - RightBottom := PointMake(r[1, 0], r[1, 1]); - LeftBottom := PointMake(r[0, 0], r[1, 1]); + LeftTop := PointMake(R[0, 0], R[0, 1]); + RightTop := PointMake(R[1, 0], R[0, 1]); + RightBottom := PointMake(R[1, 0], R[1, 1]); + LeftBottom := PointMake(R[0, 0], R[1, 1]); end; end; -class function TV2Rect4.Init(r: TRectV2; axis: TVec2; Ang: TGeoFloat): TV2Rect4; +class function TV2Rect4.Init(R: TRectV2; axis: TVec2; Ang: TGeoFloat): TV2Rect4; begin with Result do begin - LeftTop := PointMake(r[0, 0], r[0, 1]); - RightTop := PointMake(r[1, 0], r[0, 1]); - RightBottom := PointMake(r[1, 0], r[1, 1]); - LeftBottom := PointMake(r[0, 0], r[1, 1]); + LeftTop := PointMake(R[0, 0], R[0, 1]); + RightTop := PointMake(R[1, 0], R[0, 1]); + RightBottom := PointMake(R[1, 0], R[1, 1]); + LeftBottom := PointMake(R[0, 0], R[1, 1]); end; if Ang <> 0 then Result := Result.Rotation(axis, Ang); end; -class function TV2Rect4.Init(r: TRectV2; Ang: TGeoFloat): TV2Rect4; +class function TV2Rect4.Init(R: TRectV2; Ang: TGeoFloat): TV2Rect4; begin with Result do begin - LeftTop := PointMake(r[0, 0], r[0, 1]); - RightTop := PointMake(r[1, 0], r[0, 1]); - RightBottom := PointMake(r[1, 0], r[1, 1]); - LeftBottom := PointMake(r[0, 0], r[1, 1]); + LeftTop := PointMake(R[0, 0], R[0, 1]); + RightTop := PointMake(R[1, 0], R[0, 1]); + RightBottom := PointMake(R[1, 0], R[1, 1]); + LeftBottom := PointMake(R[0, 0], R[1, 1]); end; if Ang <> 0 then Result := Result.Rotation(Ang); end; -class function TV2Rect4.Init(r: TRectf; Ang: TGeoFloat): TV2Rect4; +class function TV2Rect4.Init(R: TRectf; Ang: TGeoFloat): TV2Rect4; begin - Result := Init(MakeRectV2(r), Ang); + Result := Init(MakeRectV2(R), Ang); end; -class function TV2Rect4.Init(r: TRect; Ang: TGeoFloat): TV2Rect4; +class function TV2Rect4.Init(R: TRect; Ang: TGeoFloat): TV2Rect4; begin - Result := Init(MakeRectV2(r), Ang); + Result := Init(MakeRectV2(R), Ang); end; -class function TV2Rect4.Init(r: TRect): TV2Rect4; +class function TV2Rect4.Init(R: TRect): TV2Rect4; begin - Result := Init(MakeRectV2(r), 0); + Result := Init(MakeRectV2(R), 0); end; class function TV2Rect4.Init(CenPos: TVec2; width, height, Ang: TGeoFloat): TV2Rect4; var - r: TRectV2; + R: TRectV2; begin - r[0, 0] := CenPos[0] - width * 0.5; - r[0, 1] := CenPos[1] - height * 0.5; - r[1, 0] := CenPos[0] + width * 0.5; - r[1, 1] := CenPos[1] + height * 0.5; - Result := Init(r, Ang); + R[0, 0] := CenPos[0] - width * 0.5; + R[0, 1] := CenPos[1] - height * 0.5; + R[1, 0] := CenPos[0] + width * 0.5; + R[1, 1] := CenPos[1] + height * 0.5; + Result := Init(R, Ang); end; class function TV2Rect4.Init(width, height, Ang: TGeoFloat): TV2Rect4; @@ -4926,67 +4926,67 @@ class function TV2Rect4.Init(): TV2Rect4; end; end; -class function TV2Rect4.Create(r: TRectV2): TV2Rect4; +class function TV2Rect4.Create(R: TRectV2): TV2Rect4; begin with Result do begin - LeftTop := PointMake(r[0, 0], r[0, 1]); - RightTop := PointMake(r[1, 0], r[0, 1]); - RightBottom := PointMake(r[1, 0], r[1, 1]); - LeftBottom := PointMake(r[0, 0], r[1, 1]); + LeftTop := PointMake(R[0, 0], R[0, 1]); + RightTop := PointMake(R[1, 0], R[0, 1]); + RightBottom := PointMake(R[1, 0], R[1, 1]); + LeftBottom := PointMake(R[0, 0], R[1, 1]); end; end; -class function TV2Rect4.Create(r: TRectV2; axis: TVec2; Ang: TGeoFloat): TV2Rect4; +class function TV2Rect4.Create(R: TRectV2; axis: TVec2; Ang: TGeoFloat): TV2Rect4; begin with Result do begin - LeftTop := PointMake(r[0, 0], r[0, 1]); - RightTop := PointMake(r[1, 0], r[0, 1]); - RightBottom := PointMake(r[1, 0], r[1, 1]); - LeftBottom := PointMake(r[0, 0], r[1, 1]); + LeftTop := PointMake(R[0, 0], R[0, 1]); + RightTop := PointMake(R[1, 0], R[0, 1]); + RightBottom := PointMake(R[1, 0], R[1, 1]); + LeftBottom := PointMake(R[0, 0], R[1, 1]); end; if Ang <> 0 then Result := Result.Rotation(axis, Ang); end; -class function TV2Rect4.Create(r: TRectV2; Ang: TGeoFloat): TV2Rect4; +class function TV2Rect4.Create(R: TRectV2; Ang: TGeoFloat): TV2Rect4; begin with Result do begin - LeftTop := PointMake(r[0, 0], r[0, 1]); - RightTop := PointMake(r[1, 0], r[0, 1]); - RightBottom := PointMake(r[1, 0], r[1, 1]); - LeftBottom := PointMake(r[0, 0], r[1, 1]); + LeftTop := PointMake(R[0, 0], R[0, 1]); + RightTop := PointMake(R[1, 0], R[0, 1]); + RightBottom := PointMake(R[1, 0], R[1, 1]); + LeftBottom := PointMake(R[0, 0], R[1, 1]); end; if Ang <> 0 then Result := Result.Rotation(Ang); end; -class function TV2Rect4.Create(r: TRectf; Ang: TGeoFloat): TV2Rect4; +class function TV2Rect4.Create(R: TRectf; Ang: TGeoFloat): TV2Rect4; begin - Result := Create(MakeRectV2(r), Ang); + Result := Create(MakeRectV2(R), Ang); end; -class function TV2Rect4.Create(r: TRect; Ang: TGeoFloat): TV2Rect4; +class function TV2Rect4.Create(R: TRect; Ang: TGeoFloat): TV2Rect4; begin - Result := Create(MakeRectV2(r), Ang); + Result := Create(MakeRectV2(R), Ang); end; -class function TV2Rect4.Create(r: TRect): TV2Rect4; +class function TV2Rect4.Create(R: TRect): TV2Rect4; begin - Result := Create(MakeRectV2(r), 0); + Result := Create(MakeRectV2(R), 0); end; class function TV2Rect4.Create(CenPos: TVec2; width, height, Ang: TGeoFloat): TV2Rect4; var - r: TRectV2; + R: TRectV2; begin - r[0, 0] := CenPos[0] - width * 0.5; - r[0, 1] := CenPos[1] - height * 0.5; - r[1, 0] := CenPos[0] + width * 0.5; - r[1, 1] := CenPos[1] + height * 0.5; - Result := Create(r, Ang); + R[0, 0] := CenPos[0] - width * 0.5; + R[0, 1] := CenPos[1] - height * 0.5; + R[1, 0] := CenPos[0] + width * 0.5; + R[1, 1] := CenPos[1] + height * 0.5; + Result := Create(R, Ang); end; class function TV2Rect4.Create(width, height, Ang: TGeoFloat): TV2Rect4; @@ -5133,30 +5133,30 @@ procedure TVec2List.Add(v2l: TVec2List); Add(v2l[i]^); end; -procedure TVec2List.Add(r: TRectV2); +procedure TVec2List.Add(R: TRectV2); begin - Add(r[0, 0], r[0, 1]); - Add(r[1, 0], r[0, 1]); - Add(r[1, 0], r[1, 1]); - Add(r[0, 0], r[1, 1]); + Add(R[0, 0], R[0, 1]); + Add(R[1, 0], R[0, 1]); + Add(R[1, 0], R[1, 1]); + Add(R[0, 0], R[1, 1]); end; -procedure TVec2List.Add(r: TRect); +procedure TVec2List.Add(R: TRect); begin - Add(RectV2(r)); + Add(RectV2(R)); end; -procedure TVec2List.Add(r: TRectf); +procedure TVec2List.Add(R: TRectf); begin - Add(RectV2(r)); + Add(RectV2(R)); end; -procedure TVec2List.Add(r: TV2Rect4); +procedure TVec2List.Add(R: TV2Rect4); begin - Add(r.LeftTop); - Add(r.RightTop); - Add(r.RightBottom); - Add(r.LeftBottom); + Add(R.LeftTop); + Add(R.RightTop); + Add(R.RightBottom); + Add(R.LeftBottom); end; procedure TVec2List.Add(arry: TArrayV2Rect4); @@ -5209,12 +5209,12 @@ procedure TVec2List.AddCirclePoint(count_: Cardinal; axis: TVec2; dist_: TGeoFlo Add(PointRotation(axis, dist_, 360 / count_ * i)); end; -procedure TVec2List.AddRectangle(r: TRectV2); +procedure TVec2List.AddRectangle(R: TRectV2); begin - Add(r[0, 0], r[0, 1]); - Add(r[1, 0], r[0, 1]); - Add(r[1, 0], r[1, 1]); - Add(r[0, 0], r[1, 1]); + Add(R[0, 0], R[0, 1]); + Add(R[1, 0], R[0, 1]); + Add(R[1, 0], R[1, 1]); + Add(R[0, 0], R[1, 1]); end; procedure TVec2List.Insert(idx: TGeoInt; X, Y: TGeoFloat); @@ -5464,15 +5464,15 @@ procedure TVec2List.LoadFromStream(stream: TMemoryStream64); var c: TGeoInt; i: TGeoInt; - v: TVec2; + V: TVec2; begin Clear; c := stream.ReadInt32; for i := 0 to c - 1 do begin - v[0] := stream.ReadSingle; - v[1] := stream.ReadSingle; - Add(v); + V[0] := stream.ReadSingle; + V[1] := stream.ReadSingle; + Add(V); end; end; @@ -5618,27 +5618,27 @@ function TVec2List.InHere(pt: TVec2): Boolean; end; end; -function TVec2List.InRect(r: TRectV2): Boolean; +function TVec2List.InRect(R: TRectV2): Boolean; var i: TGeoInt; begin Result := False; for i := 0 to Count - 1 do - Result := Result or PointInRect(Points[i]^, r); + Result := Result or PointInRect(Points[i]^, R); end; -function TVec2List.Rect2Intersect(r: TRectV2): Boolean; +function TVec2List.Rect2Intersect(R: TRectV2): Boolean; var i: TGeoInt; r4: TV2Rect4; begin Result := False; for i := 0 to Count - 1 do - Result := Result or PointInRect(Points[i]^, r); + Result := Result or PointInRect(Points[i]^, R); if not Result then begin - r4 := TV2Rect4.Init(r); + r4 := TV2Rect4.Init(R); Result := Result or Line2Intersect(r4.LeftTop, r4.RightTop, True); Result := Result or Line2Intersect(r4.RightTop, r4.RightBottom, True); Result := Result or Line2Intersect(r4.RightBottom, r4.LeftBottom, True); @@ -5919,7 +5919,7 @@ procedure TVec2List.ConvexHull; procedure TVec2List.SplineSmoothInSideClosed(output: TVec2List); var i, j, idx, pre: TGeoInt; - ptPrev, ptPrev2, ptNext, ptNext2, v: TVec2; + ptPrev, ptPrev2, ptNext, ptNext2, V: TVec2; t: TGeoFloat; begin if Count < 3 then @@ -5946,12 +5946,12 @@ procedure TVec2List.SplineSmoothInSideClosed(output: TVec2List); while j <= pre do begin t := j / pre; - v := Vec2Mul(ptPrev2, Interpolation_InSide(t + 1)); - v := Vec2Add(v, Vec2Mul(ptPrev, Interpolation_InSide(t))); - v := Vec2Add(v, Vec2Mul(ptNext, Interpolation_InSide(t - 1))); - v := Vec2Add(v, Vec2Mul(ptNext2, Interpolation_InSide(t - 2))); - if not IsNan(v) then - output.Add(v); + V := Vec2Mul(ptPrev2, Interpolation_InSide(t + 1)); + V := Vec2Add(V, Vec2Mul(ptPrev, Interpolation_InSide(t))); + V := Vec2Add(V, Vec2Mul(ptNext, Interpolation_InSide(t - 1))); + V := Vec2Add(V, Vec2Mul(ptNext2, Interpolation_InSide(t - 2))); + if not IsNan(V) then + output.Add(V); inc(idx); inc(j); end; @@ -5972,7 +5972,7 @@ procedure TVec2List.SplineSmoothInSideClosed; procedure TVec2List.SplineSmoothOutSideClosed(output: TVec2List); var i, j, idx, pre: TGeoInt; - ptPrev, ptPrev2, ptNext, ptNext2, v: TVec2; + ptPrev, ptPrev2, ptNext, ptNext2, V: TVec2; t: TGeoFloat; begin if Count < 3 then @@ -5999,12 +5999,12 @@ procedure TVec2List.SplineSmoothOutSideClosed(output: TVec2List); while j <= pre do begin t := j / pre; - v := Vec2Mul(ptPrev2, Interpolation_OutSide(t + 1)); - v := Vec2Add(v, Vec2Mul(ptPrev, Interpolation_OutSide(t))); - v := Vec2Add(v, Vec2Mul(ptNext, Interpolation_OutSide(t - 1))); - v := Vec2Add(v, Vec2Mul(ptNext2, Interpolation_OutSide(t - 2))); - if not IsNan(v) then - output.Add(v); + V := Vec2Mul(ptPrev2, Interpolation_OutSide(t + 1)); + V := Vec2Add(V, Vec2Mul(ptPrev, Interpolation_OutSide(t))); + V := Vec2Add(V, Vec2Mul(ptNext, Interpolation_OutSide(t - 1))); + V := Vec2Add(V, Vec2Mul(ptNext2, Interpolation_OutSide(t - 2))); + if not IsNan(V) then + output.Add(V); inc(idx); inc(j); end; @@ -6027,7 +6027,7 @@ procedure TVec2List.SplineSmoothOpened(output: TVec2List); EndCoeff = 0; var i, j, idx, pre: TGeoInt; - ptPrev, ptPrev2, ptNext, ptNext2, v: TVec2; + ptPrev, ptPrev2, ptNext, ptNext2, V: TVec2; t: TGeoFloat; begin if Count < 3 then @@ -6063,12 +6063,12 @@ procedure TVec2List.SplineSmoothOpened(output: TVec2List); while j <= pre do begin t := j / pre; - v := Vec2Mul(ptPrev2, Interpolation_OutSide(t + 1)); - v := Vec2Add(v, Vec2Mul(ptPrev, Interpolation_OutSide(t))); - v := Vec2Add(v, Vec2Mul(ptNext, Interpolation_OutSide(t - 1))); - v := Vec2Add(v, Vec2Mul(ptNext2, Interpolation_OutSide(t - 2))); - if not IsNan(v) then - output.Add(v); + V := Vec2Mul(ptPrev2, Interpolation_OutSide(t + 1)); + V := Vec2Add(V, Vec2Mul(ptPrev, Interpolation_OutSide(t))); + V := Vec2Add(V, Vec2Mul(ptNext, Interpolation_OutSide(t - 1))); + V := Vec2Add(V, Vec2Mul(ptNext2, Interpolation_OutSide(t - 2))); + if not IsNan(V) then + output.Add(V); inc(idx); inc(j); end; @@ -6320,15 +6320,15 @@ procedure TVec2List.SortOfNear(const lb, le: TVec2); Result := CompareFloat(d1, d2); end; - procedure fastSort_(var Arry_: TCoreClassPointerList; l, r: TGeoInt); + procedure fastSort_(var Arry_: TCoreClassPointerList; l, R: TGeoInt); var i, j: TGeoInt; p: Pointer; begin repeat i := l; - j := r; - p := Arry_[(l + r) shr 1]; + j := R; + p := Arry_[(l + R) shr 1]; repeat while Compare_(Arry_[i], p) < 0 do inc(i); @@ -6345,7 +6345,7 @@ procedure TVec2List.SortOfNear(const lb, le: TVec2); if l < j then fastSort_(Arry_, l, j); l := i; - until i >= r; + until i >= R; end; begin @@ -6364,15 +6364,15 @@ procedure TVec2List.SortOfNear(const pt: TVec2); Result := CompareFloat(d1, d2); end; - procedure fastSort_(var Arry_: TCoreClassPointerList; l, r: TGeoInt); + procedure fastSort_(var Arry_: TCoreClassPointerList; l, R: TGeoInt); var i, j: TGeoInt; p: Pointer; begin repeat i := l; - j := r; - p := Arry_[(l + r) shr 1]; + j := R; + p := Arry_[(l + R) shr 1]; repeat while Compare_(Arry_[i], p) < 0 do inc(i); @@ -6389,7 +6389,7 @@ procedure TVec2List.SortOfNear(const pt: TVec2); if l < j then fastSort_(Arry_, l, j); l := i; - until i >= r; + until i >= R; end; begin @@ -6592,9 +6592,9 @@ procedure TVec2List.Transform(X, Y: TGeoFloat); end; end; -procedure TVec2List.Transform(v: TVec2); +procedure TVec2List.Transform(V: TVec2); begin - Transform(v[0], v[1]); + Transform(V[0], V[1]); end; procedure TVec2List.Mul(X, Y: TGeoFloat); @@ -6610,14 +6610,14 @@ procedure TVec2List.Mul(X, Y: TGeoFloat); end; end; -procedure TVec2List.Mul(v: TVec2); +procedure TVec2List.Mul(V: TVec2); begin - Mul(v[0], v[1]); + Mul(V[0], V[1]); end; -procedure TVec2List.Mul(v: TGeoFloat); +procedure TVec2List.Mul(V: TGeoFloat); begin - Mul(v, v); + Mul(V, V); end; procedure TVec2List.FDiv(X, Y: TGeoFloat); @@ -6633,14 +6633,14 @@ procedure TVec2List.FDiv(X, Y: TGeoFloat); end; end; -procedure TVec2List.FDiv(v: TVec2); +procedure TVec2List.FDiv(V: TVec2); begin - FDiv(v[0], v[1]); + FDiv(V[0], V[1]); end; -procedure TVec2List.FDiv(v: TGeoFloat); +procedure TVec2List.FDiv(V: TGeoFloat); begin - FDiv(v, v); + FDiv(V, V); end; function TVec2List.First: PVec2; @@ -6691,7 +6691,7 @@ function TVec2List.GetExpands(idx: TGeoInt; ExpandDist: TGeoFloat): TVec2; var lpt, pt, rpt: TVec2; ln, rn: TVec2; - dx, dy, f, r: TGeoFloat; + dx, dy, f, R: TGeoFloat; Cx, Cy: TGeoFloat; begin if (ExpandDist = 0) or (Count < 2) then @@ -6727,11 +6727,11 @@ function TVec2List.GetExpands(idx: TGeoInt; ExpandDist: TGeoFloat): TVec2; // compute the expand edge dx := (ln[0] + rn[0]); dy := (ln[1] + rn[1]); - r := (ln[0] * dx) + (ln[1] * dy); - if r = 0 then - r := 1; - Cx := (dx * ExpandDist / r); - Cy := (dy * ExpandDist / r); + R := (ln[0] * dx) + (ln[1] * dy); + if R = 0 then + R := 1; + Cx := (dx * ExpandDist / R); + Cy := (dy * ExpandDist / R); Result[0] := pt[0] + Cx; Result[1] := pt[1] + Cy; @@ -7155,9 +7155,9 @@ procedure T2DPolygonGraph.Transform(X, Y: TGeoFloat); Collapses[i].Transform(X, Y); end; -procedure T2DPolygonGraph.Transform(v: TVec2); +procedure T2DPolygonGraph.Transform(V: TVec2); begin - Transform(v[0], v[1]); + Transform(V[0], V[1]); end; procedure T2DPolygonGraph.Mul(X, Y: TGeoFloat); @@ -7169,14 +7169,14 @@ procedure T2DPolygonGraph.Mul(X, Y: TGeoFloat); Collapses[i].Mul(X, Y); end; -procedure T2DPolygonGraph.Mul(v: TVec2); +procedure T2DPolygonGraph.Mul(V: TVec2); begin - Mul(v[0], v[1]); + Mul(V[0], V[1]); end; -procedure T2DPolygonGraph.Mul(v: TGeoFloat); +procedure T2DPolygonGraph.Mul(V: TGeoFloat); begin - Mul(v, v); + Mul(V, V); end; procedure T2DPolygonGraph.FDiv(X, Y: TGeoFloat); @@ -7188,9 +7188,9 @@ procedure T2DPolygonGraph.FDiv(X, Y: TGeoFloat); Collapses[i].FDiv(X, Y); end; -procedure T2DPolygonGraph.FDiv(v: TVec2); +procedure T2DPolygonGraph.FDiv(V: TVec2); begin - FDiv(v[0], v[1]); + FDiv(V[0], V[1]); end; procedure T2DPolygonGraph.VertexReduction(Epsilon_: TGeoFloat); @@ -7454,12 +7454,12 @@ procedure TDeflectionPolygon.AddPoint(X, Y: TGeoFloat); Add(PointAngle(FPosition, pt), PointDistance(FPosition, pt)); end; -procedure TDeflectionPolygon.AddRectangle(r: TRectV2); +procedure TDeflectionPolygon.AddRectangle(R: TRectV2); begin - AddPoint(r[0, 0], r[0, 1]); - AddPoint(r[1, 0], r[0, 1]); - AddPoint(r[1, 0], r[1, 1]); - AddPoint(r[0, 0], r[1, 1]); + AddPoint(R[0, 0], R[0, 1]); + AddPoint(R[1, 0], R[0, 1]); + AddPoint(R[1, 0], R[1, 1]); + AddPoint(R[0, 0], R[1, 1]); end; procedure TDeflectionPolygon.AddCirclePoint(count_: Cardinal; axis: TVec2; dist_: TGeoFloat); @@ -7483,12 +7483,12 @@ procedure TDeflectionPolygon.Add(angle_, dist_: TGeoFloat); FList.Add(p); end; -procedure TDeflectionPolygon.AddRectangle(r: TV2Rect4); +procedure TDeflectionPolygon.AddRectangle(R: TV2Rect4); begin - AddPoint(r.LeftTop); - AddPoint(r.RightTop); - AddPoint(r.RightBottom); - AddPoint(r.LeftBottom); + AddPoint(R.LeftTop); + AddPoint(R.RightTop); + AddPoint(R.RightBottom); + AddPoint(R.LeftBottom); end; procedure TDeflectionPolygon.AddRectangle(arry: TArrayV2Rect4); @@ -8461,42 +8461,42 @@ function TDeflectionPolygon.GetNearLine(ExpandDistance_: TGeoFloat; const pt: TV end; end; -function TDeflectionPolygon.Collision2Circle(cp: TVec2; r: TGeoFloat; ClosedPolyMode: Boolean): Boolean; +function TDeflectionPolygon.Collision2Circle(cp: TVec2; R: TGeoFloat; ClosedPolyMode: Boolean): Boolean; var i: TGeoInt; curpt, destpt: TVec2; begin - if (Detect_Circle2Circle(FPosition, cp, FMaxRadius * FScale, r)) and (Count > 0) then + if (Detect_Circle2Circle(FPosition, cp, FMaxRadius * FScale, R)) and (Count > 0) then begin Result := True; curpt := Points[0]; for i := 1 to Count - 1 do begin destpt := Points[i]; - if Detect_Circle2Line(cp, r, curpt, destpt) then + if Detect_Circle2Line(cp, R, curpt, destpt) then exit; curpt := destpt; end; if ClosedPolyMode and (Count >= 3) then - if Detect_Circle2Line(cp, r, curpt, Points[0]) then + if Detect_Circle2Line(cp, R, curpt, Points[0]) then exit; end; Result := False; end; -function TDeflectionPolygon.Collision2Circle(cp: TVec2; r: TGeoFloat; ClosedPolyMode: Boolean; OutputLine: TDeflectionPolygonLines): Boolean; +function TDeflectionPolygon.Collision2Circle(cp: TVec2; R: TGeoFloat; ClosedPolyMode: Boolean; OutputLine: TDeflectionPolygonLines): Boolean; var i: TGeoInt; curpt, destpt: TVec2; begin Result := False; - if (Detect_Circle2Circle(FPosition, cp, FMaxRadius * FScale, r)) and (Count > 0) then + if (Detect_Circle2Circle(FPosition, cp, FMaxRadius * FScale, R)) and (Count > 0) then begin curpt := Points[0]; for i := 1 to Count - 1 do begin destpt := Points[i]; - if Detect_Circle2Line(cp, r, curpt, destpt) then + if Detect_Circle2Line(cp, R, curpt, destpt) then begin OutputLine.Add(curpt, destpt, i - 1, i, Self); Result := True; @@ -8504,7 +8504,7 @@ function TDeflectionPolygon.Collision2Circle(cp: TVec2; r: TGeoFloat; ClosedPoly curpt := destpt; end; if ClosedPolyMode and (Count >= 3) then - if Detect_Circle2Line(cp, r, curpt, Points[0]) then + if Detect_Circle2Line(cp, R, curpt, Points[0]) then begin OutputLine.Add(curpt, Points[0], Count - 1, 0, Self); Result := True; @@ -8512,19 +8512,19 @@ function TDeflectionPolygon.Collision2Circle(cp: TVec2; r: TGeoFloat; ClosedPoly end; end; -function TDeflectionPolygon.Collision2Circle(ExpandDistance_: TGeoFloat; cp: TVec2; r: TGeoFloat; ClosedPolyMode: Boolean; OutputLine: TDeflectionPolygonLines): Boolean; +function TDeflectionPolygon.Collision2Circle(ExpandDistance_: TGeoFloat; cp: TVec2; R: TGeoFloat; ClosedPolyMode: Boolean; OutputLine: TDeflectionPolygonLines): Boolean; var i: TGeoInt; curpt, destpt: TVec2; begin Result := False; - if (Detect_Circle2Circle(FPosition, cp, FMaxRadius * FScale + ExpandDistance_, r)) and (Count > 0) then + if (Detect_Circle2Circle(FPosition, cp, FMaxRadius * FScale + ExpandDistance_, R)) and (Count > 0) then begin curpt := Expands[0, ExpandDistance_]; for i := 1 to Count - 1 do begin destpt := Expands[i, ExpandDistance_]; - if Detect_Circle2Line(cp, r, curpt, destpt) then + if Detect_Circle2Line(cp, R, curpt, destpt) then begin OutputLine.Add(curpt, destpt, i - 1, i, Self); Result := True; @@ -8532,7 +8532,7 @@ function TDeflectionPolygon.Collision2Circle(ExpandDistance_: TGeoFloat; cp: TVe curpt := destpt; end; if ClosedPolyMode and (Count >= 3) then - if Detect_Circle2Line(cp, r, curpt, Expands[0, ExpandDistance_]) then + if Detect_Circle2Line(cp, R, curpt, Expands[0, ExpandDistance_]) then begin OutputLine.Add(curpt, Expands[0, ExpandDistance_], Count - 1, 0, Self); Result := True; @@ -8696,7 +8696,7 @@ function TDeflectionPolygon.GetExpands(idx: TGeoInt; ExpandDist: TGeoFloat): TVe var lpt, pt, rpt: TVec2; ln, rn: TVec2; - dx, dy, f, r: TGeoFloat; + dx, dy, f, R: TGeoFloat; Cx, Cy: TGeoFloat; begin if (ExpandDist = 0) or (Count < 2) then @@ -8732,11 +8732,11 @@ function TDeflectionPolygon.GetExpands(idx: TGeoInt; ExpandDist: TGeoFloat): TVe // compute the expand edge dx := (ln[0] + rn[0]); dy := (ln[1] + rn[1]); - r := (ln[0] * dx) + (ln[1] * dy); - if r = 0 then - r := 1; - Cx := (dx * ExpandDist / r); - Cy := (dy * ExpandDist / r); + R := (ln[0] * dx) + (ln[1] * dy); + if R = 0 then + R := 1; + Cx := (dx * ExpandDist / R); + Cy := (dy * ExpandDist / R); if FExpandMode = emConcave then begin @@ -9029,12 +9029,12 @@ procedure TDeflectionPolygonLines.Assign(Source: TCoreClassPersistent); end; end; -function TDeflectionPolygonLines.Add(v: TDeflectionPolygonLine): TGeoInt; +function TDeflectionPolygonLines.Add(V: TDeflectionPolygonLine): TGeoInt; var p: PDeflectionPolygonLine; begin new(p); - p^ := v; + p^ := V; Result := FList.Add(p); p^.index := Result; end; @@ -9176,15 +9176,15 @@ procedure TDeflectionPolygonLines.SortOfNear(const pt: TVec2); Result := CompareFloat(d1, d2); end; - procedure fastSort_(var Arry_: TCoreClassPointerList; l, r: TGeoInt); + procedure fastSort_(var Arry_: TCoreClassPointerList; l, R: TGeoInt); var i, j: TGeoInt; p: Pointer; begin repeat i := l; - j := r; - p := Arry_[(l + r) shr 1]; + j := R; + p := Arry_[(l + R) shr 1]; repeat while Compare_(Arry_[i], p) < 0 do inc(i); @@ -9201,7 +9201,7 @@ procedure TDeflectionPolygonLines.SortOfNear(const pt: TVec2); if l < j then fastSort_(Arry_, l, j); l := i; - until i >= r; + until i >= R; end; var @@ -9224,15 +9224,15 @@ procedure TDeflectionPolygonLines.SortOfFar(const pt: TVec2); Result := CompareFloat(d2, d1); end; - procedure fastSort_(var Arry_: TCoreClassPointerList; l, r: TGeoInt); + procedure fastSort_(var Arry_: TCoreClassPointerList; l, R: TGeoInt); var i, j: TGeoInt; p: Pointer; begin repeat i := l; - j := r; - p := Arry_[(l + r) shr 1]; + j := R; + p := Arry_[(l + R) shr 1]; repeat while Compare_(Arry_[i], p) < 0 do inc(i); @@ -9249,7 +9249,7 @@ procedure TDeflectionPolygonLines.SortOfFar(const pt: TVec2); if l < j then fastSort_(Arry_, l, j); l := i; - until i >= r; + until i >= R; end; var @@ -9593,7 +9593,7 @@ function TRectPacking.Pack(width, height: TGeoFloat; var X, Y: TGeoFloat): Boole var i: TGeoInt; p: PRectPackData; - r, b: TGeoFloat; + R, b: TGeoFloat; begin MaxWidth := Max(MaxWidth, width); MaxHeight := Max(MaxHeight, height); @@ -9607,13 +9607,13 @@ function TRectPacking.Pack(width, height: TGeoFloat; var X, Y: TGeoFloat): Boole FList.Delete(i); X := p^.Rect[0, 0]; Y := p^.Rect[0, 1]; - r := X + width; + R := X + width; b := Y + height; - MaxWidth := Max(MaxWidth, Max(width, r)); + MaxWidth := Max(MaxWidth, Max(width, R)); MaxHeight := Max(MaxHeight, Max(height, b)); Add(X, b, width, p^.Rect[1, 1] - b); - Add(r, Y, p^.Rect[1, 0] - r, height); - Add(r, b, p^.Rect[1, 0] - r, p^.Rect[1, 1] - b); + Add(R, Y, p^.Rect[1, 0] - R, height); + Add(R, b, p^.Rect[1, 0] - R, p^.Rect[1, 1] - b); Result := True; Dispose(p); exit; @@ -9685,9 +9685,9 @@ procedure TRectPacking.Add(Data1: Pointer; Data2: TCoreClassObject; X, Y, width, FList.Add(p); end; -procedure TRectPacking.Add(Data1: Pointer; Data2: TCoreClassObject; r: TRectV2); +procedure TRectPacking.Add(Data1: Pointer; Data2: TCoreClassObject; R: TRectV2); begin - Add(Data1, Data2, 0, 0, RectWidth(r), RectHeight(r)); + Add(Data1, Data2, 0, 0, RectWidth(R), RectHeight(R)); end; procedure TRectPacking.Add(Data1: Pointer; Data2: TCoreClassObject; width, height: TGeoFloat); @@ -9724,15 +9724,15 @@ procedure TRectPacking.Build(SpaceWidth, SpaceHeight: TGeoFloat); Result := CompareFloat(RectArea(PRectPackData(Right)^.Rect), RectArea(PRectPackData(Left)^.Rect)); end; - procedure fastSort_(var Arry_: TCoreClassPointerList; l, r: TGeoInt); + procedure fastSort_(var Arry_: TCoreClassPointerList; l, R: TGeoInt); var i, j: TGeoInt; p: Pointer; begin repeat i := l; - j := r; - p := Arry_[(l + r) shr 1]; + j := R; + p := Arry_[(l + R) shr 1]; repeat while Compare_(Arry_[i], p) < 0 do inc(i); @@ -9749,7 +9749,7 @@ procedure TRectPacking.Build(SpaceWidth, SpaceHeight: TGeoFloat); if l < j then fastSort_(Arry_, l, j); l := i; - until i >= r; + until i >= R; end; var @@ -10493,31 +10493,31 @@ class procedure THausdorf.Test2; DisposeObject(vl2); end; -function ArrayVec2(const v: TArrayVec2): TArrayVec2; +function ArrayVec2(const V: TArrayVec2): TArrayVec2; var i: Integer; begin - SetLength(Result, length(v)); - for i := 0 to length(v) - 1 do - Result[i] := v[i]; + SetLength(Result, length(V)); + for i := 0 to length(V) - 1 do + Result[i] := V[i]; end; -function ArrayVec2(const r: TRectV2): TArrayVec2; +function ArrayVec2(const R: TRectV2): TArrayVec2; begin SetLength(Result, 4); - Result[0] := PointMake(r[0, 0], r[0, 1]); - Result[1] := PointMake(r[1, 0], r[0, 1]); - Result[2] := PointMake(r[1, 0], r[1, 1]); - Result[3] := PointMake(r[0, 0], r[1, 1]); + Result[0] := PointMake(R[0, 0], R[0, 1]); + Result[1] := PointMake(R[1, 0], R[0, 1]); + Result[2] := PointMake(R[1, 0], R[1, 1]); + Result[3] := PointMake(R[0, 0], R[1, 1]); end; -function ArrayVec2(const r: TV2Rect4): TArrayVec2; +function ArrayVec2(const R: TV2Rect4): TArrayVec2; begin SetLength(Result, 4); - Result[0] := r.LeftTop; - Result[1] := r.RightTop; - Result[2] := r.RightBottom; - Result[3] := r.LeftBottom; + Result[0] := R.LeftTop; + Result[1] := R.RightTop; + Result[2] := R.RightBottom; + Result[3] := R.LeftBottom; end; function ArrayVec2(const l: TLineV2): TArrayVec2; diff --git a/Source/ListEngine.pas b/Source/ListEngine.pas index 6ff69231..c6d19e15 100644 --- a/Source/ListEngine.pas +++ b/Source/ListEngine.pas @@ -16,20 +16,6 @@ { * https://github.com/PassByYou888/InfiniteIoT * } { * https://github.com/PassByYou888/FastMD5 * } { ****************************************************************************** } - -(* - update history - 2017-11-26 - "String" define change as "SystemString" - - 2017-12-5 - added support int64 hash object : TInt64HashObjectList - added support pointer-NativeUInt hash : TPointerHashNativeUIntList - - 2018-4-17 - added support big StringList with TListString and TListPascalString -*) - unit ListEngine; {$INCLUDE zDefine.inc} @@ -567,7 +553,7 @@ TPointerHashNativeUIntList = class(TCoreClassObject) {$ENDREGION 'TPointerHashNativeUIntList'} {$REGION 'THashObjectList'} - THashObjectChangeEvent = procedure(Sender: THashObjectList; Name: SystemString; _OLD, _New: TCoreClassObject) of object; + THashObjectChangeEvent = procedure(Sender: THashObjectList; Name: SystemString; OLD_, New_: TCoreClassObject) of object; THashObjectListData = record Obj: TCoreClassObject; @@ -627,8 +613,8 @@ THashObjectList = class(TCoreClassObject) procedure GetAsList(OutputList: TCoreClassListForObj); function GetObjAsName(Obj: TCoreClassObject): SystemString; procedure Delete(const Name: SystemString); - function Add(const Name: SystemString; _Object: TCoreClassObject): TCoreClassObject; - function FastAdd(const Name: SystemString; _Object: TCoreClassObject): TCoreClassObject; + function Add(const Name: SystemString; Obj_: TCoreClassObject): TCoreClassObject; + function FastAdd(const Name: SystemString; Obj_: TCoreClassObject): TCoreClassObject; function Find(const Name: SystemString): TCoreClassObject; function Exists(const Name: SystemString): Boolean; function ExistsObject(Obj: TCoreClassObject): Boolean; @@ -650,7 +636,7 @@ THashObjectList = class(TCoreClassObject) {$ENDREGION 'THashObjectList'} {$REGION 'THashStringList'} - THashStringChangeEvent = procedure(Sender: THashStringList; Name: SystemString; _OLD, _New: SystemString) of object; + THashStringChangeEvent = procedure(Sender: THashStringList; Name: SystemString; OLD_, New_: SystemString) of object; THashStringListData = record v: SystemString; @@ -786,7 +772,7 @@ THashStringTextStream = class(TCoreClassObject) PHashStringList = ^THashStringList; {$ENDREGION 'THashStringList'} {$REGION 'THashVariantList'} - THashVariantChangeEvent = procedure(Sender: THashVariantList; Name: SystemString; _OLD, _New: Variant) of object; + THashVariantChangeEvent = procedure(Sender: THashVariantList; Name: SystemString; OLD_, New_: Variant) of object; THashVariantListData = record v: Variant; @@ -6227,7 +6213,7 @@ procedure THashObjectList.Delete(const Name: SystemString); FHashList.Delete(Name); end; -function THashObjectList.Add(const Name: SystemString; _Object: TCoreClassObject): TCoreClassObject; +function THashObjectList.Add(const Name: SystemString; Obj_: TCoreClassObject): TCoreClassObject; var pObjData: PHashObjectListData; begin @@ -6236,7 +6222,7 @@ function THashObjectList.Add(const Name: SystemString; _Object: TCoreClassObject begin try if Assigned(pObjData^.OnChnage) then - pObjData^.OnChnage(Self, Name, pObjData^.Obj, _Object); + pObjData^.OnChnage(Self, Name, pObjData^.Obj, Obj_); except end; @@ -6256,11 +6242,11 @@ function THashObjectList.Add(const Name: SystemString; _Object: TCoreClassObject FHashList.Add(Name, pObjData, False); end; - pObjData^.Obj := _Object; - Result := _Object; + pObjData^.Obj := Obj_; + Result := Obj_; end; -function THashObjectList.FastAdd(const Name: SystemString; _Object: TCoreClassObject): TCoreClassObject; +function THashObjectList.FastAdd(const Name: SystemString; Obj_: TCoreClassObject): TCoreClassObject; var pObjData: PHashObjectListData; begin @@ -6268,8 +6254,8 @@ function THashObjectList.FastAdd(const Name: SystemString; _Object: TCoreClassOb pObjData^.OnChnage := nil; FHashList.Add(Name, pObjData, False); - pObjData^.Obj := _Object; - Result := _Object; + pObjData^.Obj := Obj_; + Result := Obj_; end; function THashObjectList.Find(const Name: SystemString): TCoreClassObject; diff --git a/Source/NotifyObjectBase.pas b/Source/NotifyObjectBase.pas index 150d5b11..fa0201bf 100644 --- a/Source/NotifyObjectBase.pas +++ b/Source/NotifyObjectBase.pas @@ -37,14 +37,9 @@ TNotifyBase = class(TCoreClassInterfacedObject) public constructor Create; virtual; destructor Destroy; override; - procedure RegisterNotify(v: TNotifyBase); procedure UnRegisterNotify(v: TNotifyBase); - - // trigger procedure DoExecute(const State: Variant); virtual; - - // on execute procedure NotifyExecute(Sender: TNotifyBase; const State: Variant); virtual; end; @@ -105,34 +100,26 @@ TNProgressPost = class(TCoreClassInterfacedObject) public constructor Create; destructor Destroy; override; - procedure ResetPost; - function PostExecute(): TNPostExecute; overload; - function PostExecute(DataEng: TDataFrameEngine): TNPostExecute; overload; function PostExecute(Delay: Double): TNPostExecute; overload; function PostExecute(Delay: Double; DataEng: TDataFrameEngine): TNPostExecute; overload; - function PostExecuteM(DataEng: TDataFrameEngine; OnExecuteMethod: TNPostExecuteMethod): TNPostExecute; overload; function PostExecuteM(Delay: Double; DataEng: TDataFrameEngine; OnExecuteMethod: TNPostExecuteMethod): TNPostExecute; overload; function PostExecuteM(Delay: Double; OnExecuteMethod: TNPostExecuteMethod): TNPostExecute; overload; function PostExecuteM_NP(Delay: Double; OnExecuteMethod: TNPostExecuteMethod_NP): TNPostExecute; overload; - function PostExecuteC(DataEng: TDataFrameEngine; OnExecuteCall: TNPostExecuteCall): TNPostExecute; overload; function PostExecuteC(Delay: Double; DataEng: TDataFrameEngine; OnExecuteCall: TNPostExecuteCall): TNPostExecute; overload; function PostExecuteC(Delay: Double; OnExecuteCall: TNPostExecuteCall): TNPostExecute; overload; function PostExecuteC_NP(Delay: Double; OnExecuteCall: TNPostExecuteCall_NP): TNPostExecute; overload; - function PostExecuteP(DataEng: TDataFrameEngine; OnExecuteProc: TNPostExecuteProc): TNPostExecute; overload; function PostExecuteP(Delay: Double; DataEng: TDataFrameEngine; OnExecuteProc: TNPostExecuteProc): TNPostExecute; overload; function PostExecuteP(Delay: Double; OnExecuteProc: TNPostExecuteProc): TNPostExecute; overload; function PostExecuteP_NP(Delay: Double; OnExecuteProc: TNPostExecuteProc_NP): TNPostExecute; overload; - + procedure PostDelayFreeObject(Delay: Double; Obj1_, Obj2_: TCoreClassObject); procedure Delete(p: TNPostExecute); overload; virtual; - procedure Progress(deltaTime: Double); - property Paused: Boolean read FPaused write FPaused; property Busy: Boolean read FBusy; property CurrentExecute: TNPostExecute read FCurrentExecute; @@ -146,14 +133,17 @@ TNProgressPostWithCadencer = class(TNProgressPost, ICadencerProgressInterface) public constructor Create; destructor Destroy; override; - procedure Progress; - property CadencerEngine: TCadencer read FCadencerEngine; end; var - ProgressCadencer: TNProgressPostWithCadencer; + SystemPostProgress: TNProgressPostWithCadencer; + +function SysPostProgress: TNProgressPostWithCadencer; +function SysPost: TNProgressPostWithCadencer; +procedure DelayFreeObject(Delay: Double; Obj1_, Obj2_: TCoreClassObject); overload; +procedure DelayFreeObject(Delay: Double; Obj1_: TCoreClassObject); overload; implementation @@ -169,7 +159,33 @@ procedure DoCheckThreadSynchronize(); except end; end; - ProgressCadencer.Progress; + SystemPostProgress.Progress; +end; + +function SysPostProgress: TNProgressPostWithCadencer; +begin + Result := SystemPostProgress; +end; + +function SysPost: TNProgressPostWithCadencer; +begin + Result := SystemPostProgress; +end; + +procedure DelayFreeObject(Delay: Double; Obj1_, Obj2_: TCoreClassObject); +begin + SystemPostProgress.PostDelayFreeObject(Delay, Obj1_, Obj2_); +end; + +procedure DelayFreeObject(Delay: Double; Obj1_: TCoreClassObject); +begin + SystemPostProgress.PostDelayFreeObject(Delay, Obj1_, nil); +end; + +procedure DoDelayFreeObject(Sender: TNPostExecute); +begin + DisposeObject(Sender.Data1); + DisposeObject(Sender.Data2); end; procedure TNotifyBase.DeleteSaveNotifyIntf(p: TNotifyBase); @@ -277,7 +293,6 @@ destructor TNPostExecute.Destroy; begin if FOwner.CurrentExecute = Self then FOwner.FBreakProgress := True; - i := 0; while i < FOwner.FPostExecuteList.Count do begin @@ -495,6 +510,16 @@ function TNProgressPost.PostExecuteP_NP(Delay: Double; OnExecuteProc: TNPostExec Result.OnExecuteProc_NP := OnExecuteProc; end; +procedure TNProgressPost.PostDelayFreeObject(Delay: Double; Obj1_, Obj2_: TCoreClassObject); +var + tmp: TNPostExecute; +begin + tmp := PostExecute(Delay); + tmp.Data1 := Obj1_; + tmp.Data2 := Obj2_; + tmp.OnExecuteCall := {$IFDEF FPC}@{$ENDIF FPC}DoDelayFreeObject; +end; + procedure TNProgressPost.Delete(p: TNPostExecute); var i: Integer; @@ -609,11 +634,11 @@ initialization Hooked_OnCheckThreadSynchronize := CoreClasses.OnCheckThreadSynchronize; CoreClasses.OnCheckThreadSynchronize := {$IFDEF FPC}@{$ENDIF FPC}DoCheckThreadSynchronize; -ProgressCadencer := TNProgressPostWithCadencer.Create; +SystemPostProgress := TNProgressPostWithCadencer.Create; finalization CoreClasses.OnCheckThreadSynchronize := Hooked_OnCheckThreadSynchronize; -DisposeObject(ProgressCadencer); +DisposeObject(SystemPostProgress); end. diff --git a/Source/NumberBase.pas b/Source/NumberBase.pas index 5c353269..2a432b8a 100644 --- a/Source/NumberBase.pas +++ b/Source/NumberBase.pas @@ -1,3 +1,6 @@ +{ ****************************************************************************** } +{ * Number Module system, create by.qq600585 * } +{ ****************************************************************************** } { * https://zpascal.net * } { * https://github.com/PassByYou888/zAI * } { * https://github.com/PassByYou888/ZServer4D * } @@ -20,82 +23,84 @@ interface -uses ListEngine, CoreClasses, DataFrameEngine, PascalStrings; +uses +{$IFDEF FPC} + FPCGenericStructlist, +{$ENDIF FPC} + CoreClasses, GHashList, ListEngine, PascalStrings, TextParsing, zExpression, OpCode; type - TNumberModuleHookInterface = class; - TNumberModuleEventInterface = class; - TNumberModuleList = class; - TNumberModule = class; + TNumberModuleHookPool = class; + TNumberModuleEventPool = class; + TNumberModulePool = class; + TNumberModule = class; + TNumberModuleHookPoolList = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + TNumberModuleEventPoolList = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + TNumberModulePool_Decl = {$IFDEF FPC}specialize {$ENDIF FPC}TGenericHashList; - TNumberModuleHook = procedure(Sender: TNumberModuleHookInterface; OldValue: Variant; var NewValue: Variant) of object; + TNumberModuleHook = procedure(Sender: TNumberModuleHookPool; OLD_: Variant; var New_: Variant) of object; - TNumberModuleHookInterface = class(TCoreClassObject) + TNumberModuleHookPool = class(TCoreClassObject) private FOwner: TNumberModule; - FOwnerList: TCoreClassListForObj; + FOwnerList: TNumberModuleHookPoolList; FOnCurrentDMHook: TNumberModuleHook; + FTag: SystemString; protected public - constructor Create(AOwner: TNumberModule; AOwnerList: TCoreClassListForObj); + constructor Create(Owner_: TNumberModule; OwnerList_: TNumberModuleHookPoolList); destructor Destroy; override; - property Owner: TNumberModule read FOwner; property OnCurrentDMHook: TNumberModuleHook read FOnCurrentDMHook write FOnCurrentDMHook; + property Tag: SystemString read FTag write FTag; end; - TNumberModuleEvent = procedure(Sender: TNumberModuleEventInterface; NewValue: Variant) of object; + TNumberModuleEvent = procedure(Sender: TNumberModuleEventPool; New_: Variant) of object; - TNumberModuleEventInterface = class(TCoreClassObject) + TNumberModuleEventPool = class(TCoreClassObject) private FOwner: TNumberModule; - FOwnerList: TCoreClassListForObj; + FOwnerList: TNumberModuleEventPoolList; FOnCurrentDMEvent: TNumberModuleEvent; + FTag: SystemString; protected public - constructor Create(AOwner: TNumberModule; AOwnerList: TCoreClassListForObj); + constructor Create(Owner_: TNumberModule; OwnerList_: TNumberModuleEventPoolList); destructor Destroy; override; - property Owner: TNumberModule read FOwner; property OnCurrentDMEvent: TNumberModuleEvent read FOnCurrentDMEvent write FOnCurrentDMEvent; + property Tag: SystemString read FTag write FTag; end; - TNumberModuleNotifyEvent = procedure(); - TNumberModuleChangeEvent = procedure(const OldValue, NewValue: Variant); + TNumberModuleChangeEvent = procedure(Sender: TNumberModule; OLD_, New_: Variant); TNumberModule = class(TCoreClassObject) private - FOwner: TNumberModuleList; + FOwner: TNumberModulePool; FName, FSymbolName, FDescription, FDetailDescription: SystemString; - - FCurrentValueHookList: TCoreClassListForObj; - FCurrentValueChangeAfterEventList: TCoreClassListForObj; - + FCurrentValueHookPool: TNumberModuleHookPoolList; + FCurrentValueChangeAfterEventPool: TNumberModuleEventPoolList; FCurrentValue: Variant; FOriginValue: Variant; - - FCustomObjects: THashObjectList; - FCustomValues: THashVariantList; - FEnabledHook: Boolean; FEnabledEvent: Boolean; - FOnChange: TNumberModuleChangeEvent; private + // prop procedure SetName(const Value: SystemString); - function GetCurrentValue: Variant; procedure SetCurrentValue(const Value: Variant); - function GetOriginValue: Variant; procedure SetOriginValue(const Value: Variant); - - function GetCustomObjects: THashObjectList; - function GetCustomValues: THashVariantList; - private - procedure DoCurrentValueHook(OldValue: Variant; NewValue: Variant); + // change + procedure DoCurrentValueHook(const OLD_, New_: Variant); procedure Clear; + // opRunTime + procedure DoRegOpProc(); + procedure DoRemoveOpProc(); + function OP_DoProc(Sender: TOpCustomRunTime; var OP_Param: TOpParam): Variant; private + // get current function GetCurrentAsCardinal: Cardinal; function GetCurrentAsDouble: Double; function GetCurrentAsInt64: Int64; @@ -103,7 +108,7 @@ TNumberModule = class(TCoreClassObject) function GetCurrentAsSingle: Single; function GetCurrentAsString: SystemString; function GetCurrentAsBool: Boolean; - + // set current procedure SetCurrentAsCardinal(const Value: Cardinal); procedure SetCurrentAsDouble(const Value: Double); procedure SetCurrentAsInt64(const Value: Int64); @@ -111,7 +116,7 @@ TNumberModule = class(TCoreClassObject) procedure SetCurrentAsSingle(const Value: Single); procedure SetCurrentAsString(const Value: SystemString); procedure SetCurrentAsBool(const Value: Boolean); - + // get origin function GetOriginAsCardinal: Cardinal; function GetOriginAsDouble: Double; function GetOriginAsInt64: Int64; @@ -119,7 +124,7 @@ TNumberModule = class(TCoreClassObject) function GetOriginAsSingle: Single; function GetOriginAsString: SystemString; function GetOriginAsBool: Boolean; - + // set origin procedure SetOriginAsCardinal(const Value: Cardinal); procedure SetOriginAsDouble(const Value: Double); procedure SetOriginAsInt64(const Value: Int64); @@ -128,31 +133,29 @@ TNumberModule = class(TCoreClassObject) procedure SetOriginAsString(const Value: SystemString); procedure SetOriginAsBool(const Value: Boolean); public - constructor Create(AOwner: TNumberModuleList); + UserObject: TCoreClassObject; + UserData: Pointer; + UserVariant: Variant; + Tag: Integer; + constructor Create(Owner_: TNumberModulePool); destructor Destroy; override; - - // value changed - procedure UpdateValue; - // reg hook interface - function RegisterCurrentValueHook: TNumberModuleHookInterface; + // base prop + property OnChange: TNumberModuleChangeEvent read FOnChange write FOnChange; + property EnabledHook: Boolean read FEnabledHook write FEnabledHook; + property EnabledEvent: Boolean read FEnabledEvent write FEnabledEvent; + property Owner: TNumberModulePool read FOwner; + property Name: SystemString read FName write SetName; + property SymbolName: SystemString read FSymbolName write FSymbolName; + property Description: SystemString read FDescription write FDescription; + property DetailDescription: SystemString read FDetailDescription write FDetailDescription; + // api + procedure DoChange; + function RegisterCurrentValueHook: TNumberModuleHookPool; procedure CopyHookInterfaceFrom(sour: TNumberModule); - // reg change after event - function RegisterCurrentValueChangeAfterEvent: TNumberModuleEventInterface; + function RegisterCurrentValueChangeAfterEvent: TNumberModuleEventPool; procedure CopyChangeAfterEventInterfaceFrom(sour: TNumberModule); - // copy procedure Assign(sour: TNumberModule); - // use hook change - property CurrentValue: Variant read GetCurrentValue write SetCurrentValue; - property OriginValue: Variant read GetOriginValue write SetOriginValue; - - property CurrentAsSingle: Single read GetCurrentAsSingle write SetCurrentAsSingle; - property CurrentAsDouble: Double read GetCurrentAsDouble write SetCurrentAsDouble; - property CurrentAsInteger: Integer read GetCurrentAsInteger write SetCurrentAsInteger; - property CurrentAsInt64: Int64 read GetCurrentAsInt64 write SetCurrentAsInt64; - property CurrentAsCardinal: Cardinal read GetCurrentAsCardinal write SetCurrentAsCardinal; - property CurrentAsString: SystemString read GetCurrentAsString write SetCurrentAsString; - property CurrentAsBool: Boolean read GetCurrentAsBool write SetCurrentAsBool; - + // current property AsValue: Variant read GetCurrentValue write SetCurrentValue; property AsSingle: Single read GetCurrentAsSingle write SetCurrentAsSingle; property AsDouble: Double read GetCurrentAsDouble write SetCurrentAsDouble; @@ -161,7 +164,16 @@ TNumberModule = class(TCoreClassObject) property AsCardinal: Cardinal read GetCurrentAsCardinal write SetCurrentAsCardinal; property AsString: SystemString read GetCurrentAsString write SetCurrentAsString; property AsBool: Boolean read GetCurrentAsBool write SetCurrentAsBool; - + property CurrentValue: Variant read GetCurrentValue write SetCurrentValue; + property CurrentAsSingle: Single read GetCurrentAsSingle write SetCurrentAsSingle; + property CurrentAsDouble: Double read GetCurrentAsDouble write SetCurrentAsDouble; + property CurrentAsInteger: Integer read GetCurrentAsInteger write SetCurrentAsInteger; + property CurrentAsInt64: Int64 read GetCurrentAsInt64 write SetCurrentAsInt64; + property CurrentAsCardinal: Cardinal read GetCurrentAsCardinal write SetCurrentAsCardinal; + property CurrentAsString: SystemString read GetCurrentAsString write SetCurrentAsString; + property CurrentAsBool: Boolean read GetCurrentAsBool write SetCurrentAsBool; + // origin + property OriginValue: Variant read GetOriginValue write SetOriginValue; property OriginAsSingle: Single read GetOriginAsSingle write SetOriginAsSingle; property OriginAsDouble: Double read GetOriginAsDouble write SetOriginAsDouble; property OriginAsInteger: Integer read GetOriginAsInteger write SetOriginAsInteger; @@ -169,157 +181,99 @@ TNumberModule = class(TCoreClassObject) property OriginAsCardinal: Cardinal read GetOriginAsCardinal write SetOriginAsCardinal; property OriginAsString: SystemString read GetOriginAsString write SetOriginAsString; property OriginAsBool: Boolean read GetOriginAsBool write SetOriginAsBool; - - // skip hook - property DirectCurrentValue: Variant read FCurrentValue write FCurrentValue; + // direct,no trigger property DirectValue: Variant read FCurrentValue write FCurrentValue; + property DirectCurrentValue: Variant read FCurrentValue write FCurrentValue; property DirectOriginValue: Variant read FOriginValue write FOriginValue; - // custom object - property CustomObjects: THashObjectList read GetCustomObjects; - // custom value - property CustomValues: THashVariantList read GetCustomValues; - - property EnabledHook: Boolean read FEnabledHook write FEnabledHook; - property EnabledEvent: Boolean read FEnabledEvent write FEnabledEvent; - - property Owner: TNumberModuleList read FOwner; - property Name: SystemString read FName write SetName; - property SymbolName: SystemString read FSymbolName write FSymbolName; - property Description: SystemString read FDescription write FDescription; - property DetailDescription: SystemString read FDetailDescription write FDetailDescription; end; - TGetDMAsString = function(key: SystemString; DM: TNumberModule): SystemString; + TGetDMAsString = function(key: SystemString; NM: TNumberModule): SystemString; - TNumberModuleList = class(TCoreClassObject) + TNumberModulePool = class(TCoreClassObject) protected - FList: THashObjectList; - function GetItems(AName: SystemString): TNumberModule; + FList: TNumberModulePool_Decl; + FExpOpRunTime: TOpCustomRunTime; + function OP_DoNewNM(Sender: TOpCustomRunTime; var OP_Param: TOpParam): Variant; + procedure SwapInstance_Progress(const Name: PSystemString; Obj: TNumberModule); + procedure RebuildOpRunTime_Progress(const Name: PSystemString; Obj: TNumberModule); + procedure DoChangeAll_Progress(const Name: PSystemString; Obj: TNumberModule); + function GetExpOpRunTime: TOpCustomRunTime; public - constructor Create; + constructor Create; virtual; destructor Destroy; override; - - procedure Delete(AName: SystemString); - function Exists(AName: SystemString): Boolean; - function ExistsIntf(ADM: TNumberModule): Boolean; - procedure Clear; - - function Macro(const AText, HeadToken, TailToken, OwnerFlag: SystemString; out output: SystemString): Boolean; - function ManualMacro(const AText, HeadToken, TailToken, OwnerFlag: SystemString; OnDM2Text: TGetDMAsString; out output: SystemString): Boolean; - - procedure Assign(Source: TNumberModuleList); // create by 2011-6-17 - - // can merge current - procedure LoadFromStream(stream: TCoreClassStream); + // instance + procedure SwapInstance(source: TNumberModulePool); + // script + procedure RebuildOpRunTime; + property ExpOpRunTime: TOpCustomRunTime read GetExpOpRunTime; + function IsVectorScript(ExpressionText_: SystemString; TS_: TTextStyle): Boolean; overload; + function IsVectorScript(ExpressionText_: SystemString): Boolean; overload; + function RunScript(ExpressionText_: SystemString; TS_: TTextStyle): Variant; overload; + function RunScript(ExpressionText_: SystemString): Variant; overload; + function RunVectorScript(ExpressionText_: SystemString; TS_: TTextStyle): TExpressionValueVector; overload; + function RunVectorScript(ExpressionText_: SystemString): TExpressionValueVector; overload; + // trigger + procedure DoNMChange(Sender: TNumberModule; OLD_, New_: Variant); virtual; + // api + procedure Delete(Name_: SystemString); virtual; + function Exists(Name_: SystemString): Boolean; virtual; + function ExistsIntf(NM_: TNumberModule): Boolean; virtual; + procedure Clear; virtual; + function Macro(const text_, HeadToken, TailToken, OwnerFlag: SystemString; out output: SystemString): Boolean; virtual; + function ManualMacro(const text_, HeadToken, TailToken, OwnerFlag: SystemString; OnDM2Text: TGetDMAsString; out output: SystemString): Boolean; virtual; + procedure Assign(source: TNumberModulePool); virtual; + procedure DoChangeAll; virtual; + // load and merge from DFE + procedure LoadFromStream(stream: TCoreClassStream); virtual; // save - procedure SaveToStream(stream: TCoreClassStream); - - // laod form text, auto merge current - procedure LoadFromVariantList(v: THashVariantList); + procedure SaveToStream(stream: TCoreClassStream); virtual; + // load merge current from HashVariant + procedure LoadFromVariantList(L: THashVariantList); virtual; // save as text - procedure SaveToVariantList(v: THashVariantList); - - property Items[AName: SystemString]: TNumberModule read GetItems; default; - property List: THashObjectList read FList; - end; - - TNMAutomatedManager = class; - - TNumberProcessStyle = (npsInc, npsDec, npsIncMul, npsDecMul); - - TNumberProcessingData = record - token: TCoreClassObject; - opValue: Variant; - Style: TNumberProcessStyle; - CancelDelayTime: Double; - Overlap: Boolean; - TypeID: Integer; - Priority: Cardinal; - Processed: Boolean; - end; - - PDMProcessingData = ^TNumberProcessingData; - - TNMAutomated = class(TCoreClassPersistent) - private - FOwner: TNMAutomatedManager; - FDMSource: TNumberModule; - FCurrentValueHookIntf: TNumberModuleHookInterface; - FCurrentValueCalcList: TCoreClassList; - protected - procedure DMCurrentValueHook(Sender: TNumberModuleHookInterface; OldValue: Variant; var NewValue: Variant); - private - function GetCurrentValueCalcData(token: TCoreClassObject): PDMProcessingData; - public - constructor Create(AOwner: TNMAutomatedManager; ADMSource: TNumberModule); - destructor Destroy; override; - - property Owner: TNMAutomatedManager read FOwner write FOwner; - - procedure Progress(deltaTime: Double); - procedure ChangeProcessStyle(token: TCoreClassObject; - opValue: Variant; Style: TNumberProcessStyle; CancelDelayTime: Double; Overlap: Boolean; TypeID: Integer; Priority: Cardinal); - procedure Cancel(token: TCoreClassObject); - procedure Clear; - end; - - TNMAutomatedManager = class(TCoreClassPersistent) - private - FList: TCoreClassListForObj; - - function GetOrCreate(ADMSource: TNumberModule): TNMAutomated; - public - constructor Create; - destructor Destroy; override; - - procedure Progress(deltaTime: Double); - procedure Clear; - - procedure PostAutomatedProcess(Style: TNumberProcessStyle; - ADMSource: TNumberModule; token: TCoreClassPersistent; - opValue: Variant; Overlap: Boolean; TypeID: Integer; Priority: Cardinal); - procedure PostAutomatedDelayCancelProcess(Style: TNumberProcessStyle; - ADMSource: TNumberModule; token: TCoreClassPersistent; - opValue: Variant; Overlap: Boolean; TypeID: Integer; Priority: Cardinal; CancelDelayTime: Double); - procedure Delete(ADMSource: TNumberModule; token: TCoreClassObject); overload; - procedure Delete(token: TCoreClassObject); overload; + procedure SaveToVariantList(L: THashVariantList); virtual; + function GetItems(Name_: SystemString): TNumberModule; virtual; + property Items[Name_: SystemString]: TNumberModule read GetItems; default; + property List: TNumberModulePool_Decl read FList; + class procedure test; end; implementation -uses SysUtils, Variants, UnicodeMixedLib, DoStatusIO; +uses SysUtils, Variants, + UnicodeMixedLib, DataFrameEngine, DoStatusIO; -function __GetDMAsString(key: SystemString; DM: TNumberModule): SystemString; +function __GetNMAsString(key: SystemString; NM: TNumberModule): SystemString; begin if key = '' then - Result := DM.CurrentAsString + Result := NM.CurrentAsString else if SameText(key, 'Value') then - Result := DM.CurrentAsString + Result := NM.CurrentAsString else if SameText(key, 'Origin') then - Result := DM.OriginAsString + Result := NM.OriginAsString else if SameText(key, 'Name') then - Result := DM.Name + Result := NM.Name else if SameText(key, 'Symbol') then - Result := DM.SymbolName + Result := NM.SymbolName else if SameText(key, 'Description') then - Result := DM.Description + Result := NM.Description else if SameText(key, 'Detail') then - Result := DM.DetailDescription + Result := NM.DetailDescription else - Result := DM.CurrentAsString; + Result := NM.CurrentAsString; end; -constructor TNumberModuleHookInterface.Create(AOwner: TNumberModule; AOwnerList: TCoreClassListForObj); +constructor TNumberModuleHookPool.Create(Owner_: TNumberModule; OwnerList_: TNumberModuleHookPoolList); begin inherited Create; - FOwner := AOwner; - FOwnerList := AOwnerList; + FOwner := Owner_; + FOwnerList := OwnerList_; FOnCurrentDMHook := nil; + FTag := ''; if FOwnerList <> nil then FOwnerList.Add(Self); end; -destructor TNumberModuleHookInterface.Destroy; +destructor TNumberModuleHookPool.Destroy; var i: Integer; begin @@ -335,17 +289,18 @@ destructor TNumberModuleHookInterface.Destroy; inherited Destroy; end; -constructor TNumberModuleEventInterface.Create(AOwner: TNumberModule; AOwnerList: TCoreClassListForObj); +constructor TNumberModuleEventPool.Create(Owner_: TNumberModule; OwnerList_: TNumberModuleEventPoolList); begin inherited Create; - FOwner := AOwner; - FOwnerList := AOwnerList; + FOwner := Owner_; + FOwnerList := OwnerList_; FOnCurrentDMEvent := nil; + FTag := ''; if FOwnerList <> nil then FOwnerList.Add(Self); end; -destructor TNumberModuleEventInterface.Destroy; +destructor TNumberModuleEventPool.Destroy; var i: Integer; begin @@ -369,6 +324,7 @@ procedure TNumberModule.SetName(const Value: SystemString); begin if FOwner.FList.ReName(FName, Value) then FName := Value; + FOwner.RebuildOpRunTime; end else FName := Value; @@ -382,7 +338,13 @@ function TNumberModule.GetCurrentValue: Variant; procedure TNumberModule.SetCurrentValue(const Value: Variant); begin - DoCurrentValueHook(FCurrentValue, Value); + if VarIsNull(FOriginValue) then + begin + FOriginValue := Value; + DoCurrentValueHook(FCurrentValue, FOriginValue); + end + else + DoCurrentValueHook(FCurrentValue, Value); end; function TNumberModule.GetOriginValue: Variant; @@ -396,66 +358,86 @@ procedure TNumberModule.SetOriginValue(const Value: Variant); DoCurrentValueHook(FCurrentValue, FOriginValue); end; -function TNumberModule.GetCustomObjects: THashObjectList; -begin - if FCustomObjects = nil then - FCustomObjects := THashObjectList.Create(False); - Result := FCustomObjects; -end; - -function TNumberModule.GetCustomValues: THashVariantList; -begin - if FCustomValues = nil then - FCustomValues := THashVariantList.Create; - Result := FCustomValues; -end; - -procedure TNumberModule.DoCurrentValueHook(OldValue: Variant; NewValue: Variant); +procedure TNumberModule.DoCurrentValueHook(const OLD_, New_: Variant); var i: Integer; - _H: TNumberModuleHookInterface; - _e: TNumberModuleEventInterface; - - _New: Variant; + H_: TNumberModuleHookPool; + E_: TNumberModuleEventPool; + N_: Variant; begin - _New := NewValue; + N_ := New_; if (FEnabledHook) then - for i := 0 to FCurrentValueHookList.Count - 1 do + for i := 0 to FCurrentValueHookPool.Count - 1 do begin - _H := TNumberModuleHookInterface(FCurrentValueHookList[i]); - if Assigned(_H.FOnCurrentDMHook) then + H_ := TNumberModuleHookPool(FCurrentValueHookPool[i]); + if Assigned(H_.FOnCurrentDMHook) then begin try - _H.FOnCurrentDMHook(_H, FCurrentValue, _New); + H_.FOnCurrentDMHook(H_, FCurrentValue, N_); except end; end; end; - FCurrentValue := _New; - // trigger change after event + FCurrentValue := N_; + // trigger change event if (FEnabledEvent) then - for i := 0 to FCurrentValueChangeAfterEventList.Count - 1 do + for i := 0 to FCurrentValueChangeAfterEventPool.Count - 1 do begin - _e := TNumberModuleEventInterface(FCurrentValueChangeAfterEventList[i]); - if Assigned(_e.FOnCurrentDMEvent) then + E_ := FCurrentValueChangeAfterEventPool[i]; + if Assigned(E_.FOnCurrentDMEvent) then begin try - _e.FOnCurrentDMEvent(_e, FCurrentValue); + E_.FOnCurrentDMEvent(E_, FCurrentValue); except end; end; end; if Assigned(FOnChange) then - FOnChange(OldValue, NewValue); + begin + try + FOnChange(Self, OLD_, N_); + except + end; + end; + + if FOwner <> nil then + Owner.DoNMChange(Self, OLD_, N_); end; procedure TNumberModule.Clear; begin - while FCurrentValueHookList.Count > 0 do - DisposeObject(TNumberModuleHookInterface(FCurrentValueHookList[0])); - while FCurrentValueChangeAfterEventList.Count > 0 do - DisposeObject(TNumberModuleEventInterface(FCurrentValueChangeAfterEventList[0])); + while FCurrentValueHookPool.Count > 0 do + DisposeObject(FCurrentValueHookPool[0]); + while FCurrentValueChangeAfterEventPool.Count > 0 do + DisposeObject(FCurrentValueChangeAfterEventPool[0]); +end; + +procedure TNumberModule.DoRegOpProc; +begin + if Owner <> nil then + Owner.ExpOpRunTime.RegObjectOpM(Name, Description, {$IFDEF FPC}@{$ENDIF FPC}OP_DoProc); +end; + +procedure TNumberModule.DoRemoveOpProc; +begin + if Owner <> nil then + Owner.ExpOpRunTime.ProcList.Delete(Name); +end; + +function TNumberModule.OP_DoProc(Sender: TOpCustomRunTime; var OP_Param: TOpParam): Variant; +var + i: Integer; +begin + if Length(OP_Param) > 0 then + begin + Result := OP_Param[0]; + for i := 1 to Length(OP_Param) - 1 do + Result := Result + OP_Param[i]; + AsValue := Result; + end + else + Result := AsValue; end; function TNumberModule.GetCurrentAsCardinal: Cardinal; @@ -601,52 +583,44 @@ procedure TNumberModule.SetOriginAsBool(const Value: Boolean); OriginAsInteger := 0; end; -constructor TNumberModule.Create(AOwner: TNumberModuleList); +constructor TNumberModule.Create(Owner_: TNumberModulePool); begin inherited Create; - FOwner := AOwner; + FOwner := Owner_; FName := ''; FSymbolName := ''; FDescription := ''; FDetailDescription := ''; - - FCurrentValueHookList := TCoreClassListForObj.Create; - - FCurrentValueChangeAfterEventList := TCoreClassListForObj.Create; - - FCustomObjects := nil; - FCustomValues := nil; - - FCurrentValue := Null; - FOriginValue := Null; - + FCurrentValueHookPool := TNumberModuleHookPoolList.Create; + FCurrentValueChangeAfterEventPool := TNumberModuleEventPoolList.Create; + FCurrentValue := NULL; + FOriginValue := NULL; FEnabledHook := True; FEnabledEvent := True; - FOnChange := nil; + + UserObject := nil; + UserData := nil; + UserVariant := NULL; + Tag := 0; end; destructor TNumberModule.Destroy; begin Clear; - DisposeObject(FCurrentValueChangeAfterEventList); - DisposeObject(FCurrentValueHookList); - - if FCustomObjects <> nil then - DisposeObject(FCustomObjects); - if FCustomValues <> nil then - DisposeObject(FCustomValues); + DisposeObject(FCurrentValueChangeAfterEventPool); + DisposeObject(FCurrentValueHookPool); inherited Destroy; end; -procedure TNumberModule.UpdateValue; +procedure TNumberModule.DoChange; begin - DoCurrentValueHook(FCurrentValue, FOriginValue); + DoCurrentValueHook(FCurrentValue, FCurrentValue); end; -function TNumberModule.RegisterCurrentValueHook: TNumberModuleHookInterface; +function TNumberModule.RegisterCurrentValueHook: TNumberModuleHookPool; begin - Result := TNumberModuleHookInterface.Create(Self, FCurrentValueHookList); + Result := TNumberModuleHookPool.Create(Self, FCurrentValueHookPool); end; procedure TNumberModule.CopyHookInterfaceFrom(sour: TNumberModule); @@ -654,13 +628,13 @@ procedure TNumberModule.CopyHookInterfaceFrom(sour: TNumberModule); i: Integer; begin // copy new interface - for i := 0 to sour.FCurrentValueHookList.Count - 1 do - RegisterCurrentValueHook.OnCurrentDMHook := TNumberModuleHookInterface(sour.FCurrentValueHookList[i]).OnCurrentDMHook; + for i := 0 to sour.FCurrentValueHookPool.Count - 1 do + RegisterCurrentValueHook.OnCurrentDMHook := TNumberModuleHookPool(sour.FCurrentValueHookPool[i]).OnCurrentDMHook; end; -function TNumberModule.RegisterCurrentValueChangeAfterEvent: TNumberModuleEventInterface; +function TNumberModule.RegisterCurrentValueChangeAfterEvent: TNumberModuleEventPool; begin - Result := TNumberModuleEventInterface.Create(Self, FCurrentValueChangeAfterEventList); + Result := TNumberModuleEventPool.Create(Self, FCurrentValueChangeAfterEventPool); end; procedure TNumberModule.CopyChangeAfterEventInterfaceFrom(sour: TNumberModule); @@ -668,8 +642,8 @@ procedure TNumberModule.CopyChangeAfterEventInterfaceFrom(sour: TNumberModule); i: Integer; begin // copy new interface - for i := 0 to sour.FCurrentValueChangeAfterEventList.Count - 1 do - RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := TNumberModuleEventInterface(sour.FCurrentValueChangeAfterEventList[i]).OnCurrentDMEvent; + for i := 0 to sour.FCurrentValueChangeAfterEventPool.Count - 1 do + RegisterCurrentValueChangeAfterEvent.OnCurrentDMEvent := sour.FCurrentValueChangeAfterEventPool[i].OnCurrentDMEvent; end; procedure TNumberModule.Assign(sour: TNumberModule); @@ -682,55 +656,142 @@ procedure TNumberModule.Assign(sour: TNumberModule); FDetailDescription := sour.FDetailDescription; end; -function TNumberModuleList.GetItems(AName: SystemString): TNumberModule; +function TNumberModulePool.OP_DoNewNM(Sender: TOpCustomRunTime; var OP_Param: TOpParam): Variant; +var + N_: SystemString; begin - Result := TNumberModule(FList[AName]); - if Result = nil then + N_ := VarToStr(OP_Param[0]); + if FList.Exists(N_) then + Items[N_].AsValue := OP_Param[1] + else + Items[N_].OriginValue := OP_Param[1]; + Result := OP_Param[1]; +end; + +procedure TNumberModulePool.SwapInstance_Progress(const Name: PSystemString; Obj: TNumberModule); +begin + Obj.FOwner := Self; +end; + +procedure TNumberModulePool.RebuildOpRunTime_Progress(const Name: PSystemString; Obj: TNumberModule); +begin + Obj.DoRegOpProc; +end; + +procedure TNumberModulePool.DoChangeAll_Progress(const Name: PSystemString; Obj: TNumberModule); +begin + Obj.DoChange; +end; + +function TNumberModulePool.GetExpOpRunTime: TOpCustomRunTime; +begin + if FExpOpRunTime = nil then begin - Result := TNumberModule.Create(Self); - FList[AName] := Result; - Result.FName := AName; + FExpOpRunTime := TOpCustomRunTime.CustomCreate($FF); + FExpOpRunTime.RegObjectOpM('Set', 'Init NM, Set(Name, Value)', {$IFDEF FPC}@{$ENDIF FPC}OP_DoNewNM); + FExpOpRunTime.RegObjectOpM('Init', 'Init NM, Init(Name, Value)', {$IFDEF FPC}@{$ENDIF FPC}OP_DoNewNM); + FExpOpRunTime.RegObjectOpM('New', 'Init NM, New(Name, Value)', {$IFDEF FPC}@{$ENDIF FPC}OP_DoNewNM); + FList.ProgressM({$IFDEF FPC}@{$ENDIF FPC}RebuildOpRunTime_Progress); end; + Result := FExpOpRunTime; end; -constructor TNumberModuleList.Create; +constructor TNumberModulePool.Create; begin inherited Create; - FList := THashObjectList.CustomCreate(True, 256); + FList := TNumberModulePool_Decl.Create(True, 1024, nil); + FExpOpRunTime := nil; end; -destructor TNumberModuleList.Destroy; +destructor TNumberModulePool.Destroy; begin + DisposeObject(FExpOpRunTime); DisposeObject(FList); inherited Destroy; end; -procedure TNumberModuleList.Delete(AName: SystemString); +procedure TNumberModulePool.SwapInstance(source: TNumberModulePool); +var + tmp_FList: TNumberModulePool_Decl; + tmp_FExpOpRunTime: TOpCustomRunTime; +begin + tmp_FList := FList; + tmp_FExpOpRunTime := FExpOpRunTime; + FList := source.FList; + FExpOpRunTime := source.FExpOpRunTime; + source.FList := tmp_FList; + source.FExpOpRunTime := tmp_FExpOpRunTime; + // Update Owner + FList.ProgressM({$IFDEF FPC}@{$ENDIF FPC}SwapInstance_Progress); + source.FList.ProgressM({$IFDEF FPC}@{$ENDIF FPC}source.SwapInstance_Progress); +end; + +procedure TNumberModulePool.RebuildOpRunTime; begin - FList.Delete(AName); + DisposeObjectAndNil(FExpOpRunTime); end; -function TNumberModuleList.Exists(AName: SystemString): Boolean; +function TNumberModulePool.IsVectorScript(ExpressionText_: SystemString; TS_: TTextStyle): Boolean; begin - Result := FList.Exists(AName); + Result := IsSymbolVectorExpression(ExpressionText_, TS_, nil); end; -function TNumberModuleList.ExistsIntf(ADM: TNumberModule): Boolean; +function TNumberModulePool.IsVectorScript(ExpressionText_: SystemString): Boolean; begin - Result := FList.ExistsObject(ADM); + Result := IsVectorScript(ExpressionText_, tsPascal); end; -procedure TNumberModuleList.Clear; +function TNumberModulePool.RunScript(ExpressionText_: SystemString; TS_: TTextStyle): Variant; +begin + Result := EvaluateExpressionValue(True, TS_, ExpressionText_, ExpOpRunTime); +end; + +function TNumberModulePool.RunScript(ExpressionText_: SystemString): Variant; +begin + Result := RunScript(ExpressionText_, tsPascal); +end; + +function TNumberModulePool.RunVectorScript(ExpressionText_: SystemString; TS_: TTextStyle): TExpressionValueVector; +begin + Result := EvaluateExpressionVector(False, True, nil, TS_, ExpressionText_, ExpOpRunTime, nil); +end; + +function TNumberModulePool.RunVectorScript(ExpressionText_: SystemString): TExpressionValueVector; +begin + Result := RunVectorScript(ExpressionText_, tsPascal); +end; + +procedure TNumberModulePool.DoNMChange(Sender: TNumberModule; OLD_, New_: Variant); +begin + +end; + +procedure TNumberModulePool.Delete(Name_: SystemString); +begin + FList.Delete(Name_); +end; + +function TNumberModulePool.Exists(Name_: SystemString): Boolean; +begin + Result := FList.Exists(Name_); +end; + +function TNumberModulePool.ExistsIntf(NM_: TNumberModule): Boolean; +begin + Result := FList.ExistsObject(NM_); +end; + +procedure TNumberModulePool.Clear; begin FList.Clear; end; -function TNumberModuleList.Macro(const AText, HeadToken, TailToken, OwnerFlag: SystemString; out output: SystemString): Boolean; +function TNumberModulePool.Macro(const text_, HeadToken, TailToken, OwnerFlag: SystemString; out output: SystemString): Boolean; begin - Result := ManualMacro(AText, HeadToken, TailToken, OwnerFlag, {$IFDEF FPC}@{$ENDIF FPC}__GetDMAsString, output); + Result := ManualMacro(text_, HeadToken, TailToken, OwnerFlag, {$IFDEF FPC}@{$ENDIF FPC}__GetNMAsString, output); end; -function TNumberModuleList.ManualMacro(const AText, HeadToken, TailToken, OwnerFlag: SystemString; OnDM2Text: TGetDMAsString; out output: SystemString): Boolean; +function TNumberModulePool.ManualMacro(const text_, HeadToken, TailToken, OwnerFlag: SystemString; OnDM2Text: TGetDMAsString; out output: SystemString): Boolean; var lst: TCoreClassListForObj; @@ -742,7 +803,7 @@ function TNumberModuleList.ManualMacro(const AText, HeadToken, TailToken, OwnerF begin Result := TNumberModule(lst[i]); if (SameText(Result.FSymbolName, k)) or (SameText(Result.FName, k)) then - Exit; + exit; end; Result := nil; end; @@ -753,12 +814,12 @@ function TNumberModuleList.ManualMacro(const AText, HeadToken, TailToken, OwnerF bPos, ePos, OwnerPos, nPos: Integer; KeyText, OwnerKey, SubKey: U_String; i: Integer; - DM: TNumberModule; + NM: TNumberModule; begin lst := TCoreClassListForObj.Create; FList.GetAsList(lst); output := ''; - sour.Text := AText; + sour.Text := text_; hf.Text := HeadToken; TF.Text := TailToken; owf.Text := OwnerFlag; @@ -782,10 +843,10 @@ function TNumberModuleList.ManualMacro(const AText, HeadToken, TailToken, OwnerF nPos := OwnerPos + owf.Len; SubKey := KeyText.Copy(nPos, KeyText.Len - nPos + 1); - DM := _GetDM(OwnerKey.Text); - if DM <> nil then + NM := _GetDM(OwnerKey.Text); + if NM <> nil then begin - output := output + OnDM2Text(SubKey.Text, DM); + output := output + OnDM2Text(SubKey.Text, NM); i := ePos + TF.Len; Continue; end @@ -796,10 +857,10 @@ function TNumberModuleList.ManualMacro(const AText, HeadToken, TailToken, OwnerF end else begin - DM := _GetDM(KeyText.Text); - if DM <> nil then + NM := _GetDM(KeyText.Text); + if NM <> nil then begin - output := output + OnDM2Text('', DM); + output := output + OnDM2Text('', NM); i := ePos + TF.Len; Continue; end @@ -817,33 +878,38 @@ function TNumberModuleList.ManualMacro(const AText, HeadToken, TailToken, OwnerF DisposeObject(lst); end; -procedure TNumberModuleList.Assign(Source: TNumberModuleList); // create by,zfy, 2011-6-17 +procedure TNumberModulePool.Assign(source: TNumberModulePool); var lst: TCoreClassListForObj; i: Integer; - newdm, DM: TNumberModule; + NewDM, NM: TNumberModule; begin lst := TCoreClassListForObj.Create; - Source.FList.GetAsList(lst); + source.FList.GetAsList(lst); for i := 0 to lst.Count - 1 do begin - DM := lst[i] as TNumberModule; - newdm := Items[DM.Name]; - newdm.Assign(DM); + NM := lst[i] as TNumberModule; + NewDM := Items[NM.Name]; + NewDM.Assign(NM); end; for i := 0 to lst.Count - 1 do begin - DM := lst[i] as TNumberModule; - DM.UpdateValue; + NM := lst[i] as TNumberModule; + NM.DoChange; end; DisposeObject(lst); end; -procedure TNumberModuleList.LoadFromStream(stream: TCoreClassStream); +procedure TNumberModulePool.DoChangeAll; +begin + FList.ProgressM({$IFDEF FPC}@{$ENDIF FPC}DoChangeAll_Progress); +end; + +procedure TNumberModulePool.LoadFromStream(stream: TCoreClassStream); var - df: TDataFrameEngine; - DM: TNumberModule; + df: TDFE; + NM: TNumberModule; n: SystemString; lst: TCoreClassListForObj; i: Integer; @@ -851,345 +917,132 @@ procedure TNumberModuleList.LoadFromStream(stream: TCoreClassStream); // format // name,current value,origin value lst := TCoreClassListForObj.Create; - df := TDataFrameEngine.Create; + df := TDFE.Create; df.DecodeFrom(stream); while not df.Reader.IsEnd do begin n := df.Reader.ReadString; - DM := GetItems(n); - DM.SymbolName := df.Reader.ReadString; - DM.Description := df.Reader.ReadString; - DM.DetailDescription := df.Reader.ReadString; - DM.DirectOriginValue := df.Reader.ReadVariant; - DM.DirectOriginValue := df.Reader.ReadVariant; - lst.Add(DM); + NM := GetItems(n); + NM.SymbolName := df.Reader.ReadString; + NM.Description := df.Reader.ReadString; + NM.DetailDescription := df.Reader.ReadString; + NM.DirectOriginValue := df.Reader.ReadVariant; + NM.DirectCurrentValue := df.Reader.ReadVariant; + lst.Add(NM); end; DisposeObject(df); for i := 0 to lst.Count - 1 do begin - DM := TNumberModule(lst[i]); - DM.UpdateValue; + NM := TNumberModule(lst[i]); + NM.DoChange; end; DisposeObject(lst); end; -procedure TNumberModuleList.SaveToStream(stream: TCoreClassStream); +procedure TNumberModulePool.SaveToStream(stream: TCoreClassStream); var - df: TDataFrameEngine; + df: TDFE; lst: TCoreClassListForObj; i: Integer; - DM: TNumberModule; + NM: TNumberModule; begin // format // name,current value,origin value lst := TCoreClassListForObj.Create; FList.GetAsList(lst); - df := TDataFrameEngine.Create; + df := TDFE.Create; for i := 0 to lst.Count - 1 do begin - DM := TNumberModule(lst[i]); - df.WriteString(DM.Name); - df.WriteString(DM.SymbolName); - df.WriteString(DM.Description); - df.WriteString(DM.DetailDescription); - df.WriteVariant(DM.OriginValue); - df.WriteVariant(DM.CurrentValue); + NM := TNumberModule(lst[i]); + df.WriteString(NM.Name); + df.WriteString(NM.SymbolName); + df.WriteString(NM.Description); + df.WriteString(NM.DetailDescription); + df.WriteVariant(NM.OriginValue); + df.WriteVariant(NM.CurrentValue); end; - df.EncodeTo(stream); + df.FastEncodeTo(stream); DisposeObject(df); DisposeObject(lst); end; -procedure TNumberModuleList.LoadFromVariantList(v: THashVariantList); +procedure TNumberModulePool.LoadFromVariantList(L: THashVariantList); var - NL: TCoreClassStringList; + NL: TPascalStringList; i: Integer; lst: TCoreClassListForObj; - DM: TNumberModule; + NM: TNumberModule; begin lst := TCoreClassListForObj.Create; - - NL := TCoreClassStringList.Create; - v.GetNameList(NL); + NL := TPascalStringList.Create; + L.GetNameList(NL); for i := 0 to NL.Count - 1 do begin - DM := GetItems(NL[i]); - DM.DirectOriginValue := v[DM.Name]; - DM.DirectCurrentValue := DM.DirectOriginValue; - lst.Add(DM); + NM := GetItems(NL[i]); + NM.DirectOriginValue := L[NM.Name]; + NM.DirectCurrentValue := NM.DirectOriginValue; + lst.Add(NM); end; DisposeObject(NL); for i := 0 to lst.Count - 1 do begin - DM := TNumberModule(lst[i]); - DM.UpdateValue; + NM := TNumberModule(lst[i]); + NM.DoChange; end; DisposeObject(lst); end; -procedure TNumberModuleList.SaveToVariantList(v: THashVariantList); +procedure TNumberModulePool.SaveToVariantList(L: THashVariantList); var lst: TCoreClassStringList; i: Integer; - DM: TNumberModule; + NM: TNumberModule; begin lst := TCoreClassStringList.Create; FList.GetListData(lst); for i := 0 to lst.Count - 1 do begin - DM := TNumberModule(lst.Objects[i]); - v[DM.Name] := DM.OriginValue; + NM := TNumberModule(lst.Objects[i]); + L[NM.Name] := NM.OriginValue; end; DisposeObject(lst); end; -procedure TNMAutomated.DMCurrentValueHook(Sender: TNumberModuleHookInterface; OldValue: Variant; var NewValue: Variant); - - function IsMaxPriorityOverlap(ignore: PDMProcessingData): Boolean; - var - i: Integer; - p: PDMProcessingData; - begin - Result := True; - - for i := 0 to FCurrentValueCalcList.Count - 1 do - begin - p := FCurrentValueCalcList[i]; - if (p <> ignore) and (p^.Processed) then - if (p^.TypeID = ignore^.TypeID) and (p^.Priority >= ignore^.Priority) then - begin - Result := False; - Exit; - end; - end; - end; - - procedure ImpStyleValue(p: PDMProcessingData); - begin - case p^.Style of - npsInc: NewValue := NewValue + p^.opValue; - npsDec: NewValue := NewValue - p^.opValue; - npsIncMul: NewValue := NewValue + FDMSource.OriginValue * p^.opValue; - npsDecMul: NewValue := NewValue - FDMSource.OriginValue * p^.opValue; - else - Assert(False); - end; - p^.Processed := True; - end; - -var - i: Integer; - p: PDMProcessingData; - b: Boolean; -begin - for i := 0 to FCurrentValueCalcList.Count - 1 do - PDMProcessingData(FCurrentValueCalcList[i])^.Processed := False; - - for i := 0 to FCurrentValueCalcList.Count - 1 do - begin - p := FCurrentValueCalcList[i]; - b := p^.Overlap; - if not b then - b := IsMaxPriorityOverlap(p); - if b then - ImpStyleValue(p); - end; -end; - -function TNMAutomated.GetCurrentValueCalcData(token: TCoreClassObject): PDMProcessingData; -var - i: Integer; +function TNumberModulePool.GetItems(Name_: SystemString): TNumberModule; begin - for i := 0 to FCurrentValueCalcList.Count - 1 do - if PDMProcessingData(FCurrentValueCalcList[i])^.token = token then - begin - Result := FCurrentValueCalcList[i]; - Exit; - end; - Result := nil; -end; - -constructor TNMAutomated.Create(AOwner: TNMAutomatedManager; ADMSource: TNumberModule); -begin - inherited Create; - FOwner := AOwner; - FDMSource := ADMSource; - - FCurrentValueHookIntf := FDMSource.RegisterCurrentValueHook; - - FCurrentValueHookIntf.OnCurrentDMHook := {$IFDEF FPC}@{$ENDIF FPC}DMCurrentValueHook; - FCurrentValueCalcList := TCoreClassList.Create; -end; - -destructor TNMAutomated.Destroy; -begin - Clear; - DisposeObject(FCurrentValueCalcList); - DisposeObject(FCurrentValueHookIntf); - inherited Destroy; -end; - -procedure TNMAutomated.Progress(deltaTime: Double); -var - i: Integer; - p: PDMProcessingData; -begin - i := 0; - while i < FCurrentValueCalcList.Count do - begin - p := FCurrentValueCalcList[i]; - if p^.CancelDelayTime > 0 then - begin - if p^.CancelDelayTime - deltaTime <= 0 then - begin - Dispose(p); - FCurrentValueCalcList.Delete(i); - end - else - begin - p^.CancelDelayTime := p^.CancelDelayTime - deltaTime; - inc(i); - end; - end - else - inc(i); - end; -end; - -procedure TNMAutomated.ChangeProcessStyle(token: TCoreClassObject; opValue: Variant; Style: TNumberProcessStyle; CancelDelayTime: Double; Overlap: Boolean; TypeID: Integer; - Priority: Cardinal); -var - p: PDMProcessingData; -begin - p := GetCurrentValueCalcData(token); - if p = nil then - begin - new(p); - FCurrentValueCalcList.Add(p); - end; - p^.token := token; - p^.opValue := opValue; - p^.Style := Style; - p^.CancelDelayTime := CancelDelayTime; - p^.Overlap := Overlap; - p^.TypeID := TypeID; - p^.Priority := Priority; - p^.Processed := False; - FDMSource.UpdateValue; -end; - -procedure TNMAutomated.Cancel(token: TCoreClassObject); -var - i: Integer; - p: PDMProcessingData; - ANeedUpdate: Boolean; -begin - i := 0; - ANeedUpdate := False; - while i < FCurrentValueCalcList.Count do - begin - p := FCurrentValueCalcList[i]; - if p^.token = token then - begin - Dispose(p); - FCurrentValueCalcList.Delete(i); - ANeedUpdate := True; - end - else - inc(i); - end; - if ANeedUpdate then - FDMSource.UpdateValue; -end; - -procedure TNMAutomated.Clear; -var - i: Integer; -begin - for i := 0 to FCurrentValueCalcList.Count - 1 do - Dispose(PDMProcessingData(FCurrentValueCalcList[i])); - FCurrentValueCalcList.Clear; -end; - -function TNMAutomatedManager.GetOrCreate(ADMSource: TNumberModule): TNMAutomated; -var - i: Integer; -begin - for i := 0 to FList.Count - 1 do + Result := FList[Name_]; + if Result = nil then begin - Result := TNMAutomated(FList[i]); - if Result.FDMSource = ADMSource then - Exit; + Result := TNumberModule.Create(Self); + FList[Name_] := Result; + Result.FName := Name_; + Result.DoRegOpProc; end; - Result := TNMAutomated.Create(Self, ADMSource); - FList.Add(Result); -end; - -constructor TNMAutomatedManager.Create; -begin - inherited Create; - FList := TCoreClassListForObj.Create; -end; - -destructor TNMAutomatedManager.Destroy; -begin - Clear; - DisposeObject(FList); - inherited Destroy; end; -procedure TNMAutomatedManager.Progress(deltaTime: Double); +class procedure TNumberModulePool.test; var - i: Integer; + nmPool: TNumberModulePool; begin - for i := 0 to FList.Count - 1 do - TNMAutomated(FList[i]).Progress(deltaTime); -end; + nmPool := TNumberModulePool.Create; + nmPool['a'].OriginValue := 33.14; + nmPool['b'].OriginValue := 100; + nmPool['c'].OriginValue := 200; -procedure TNMAutomatedManager.Clear; -var - i: Integer; -begin - for i := 0 to FList.Count - 1 do - DisposeObject(TNMAutomated(FList[i])); - FList.Clear; -end; - -procedure TNMAutomatedManager.PostAutomatedProcess(Style: TNumberProcessStyle; - ADMSource: TNumberModule; token: TCoreClassPersistent; - opValue: Variant; Overlap: Boolean; TypeID: Integer; Priority: Cardinal); -begin - GetOrCreate(ADMSource).ChangeProcessStyle(token, opValue, Style, 0, Overlap, TypeID, Priority); -end; - -procedure TNMAutomatedManager.PostAutomatedDelayCancelProcess(Style: TNumberProcessStyle; - ADMSource: TNumberModule; token: TCoreClassPersistent; - opValue: Variant; Overlap: Boolean; TypeID: Integer; Priority: Cardinal; CancelDelayTime: Double); -begin - GetOrCreate(ADMSource).ChangeProcessStyle(token, opValue, Style, CancelDelayTime, Overlap, TypeID, Priority); -end; - -procedure TNMAutomatedManager.Delete(ADMSource: TNumberModule; token: TCoreClassObject); -begin - GetOrCreate(ADMSource).Cancel(token); -end; - -procedure TNMAutomatedManager.Delete(token: TCoreClassObject); -var - i: Integer; -begin - for i := 0 to FList.Count - 1 do - TNMAutomated(FList[i]).Cancel(token); + DoStatus('NM test: %s', [VarToStr(nmPool.RunScript('a(a*100)*b+c', tsPascal))]); + DoStatus('NM test: %s', [VarToStr(nmPool.RunScript('a(33.14)', tsPascal))]); + DoStatus('NM vector test: %s', [ExpressionValueVectorToStr(nmPool.RunVectorScript('a(a*100)*b+c, a*c+99', tsPascal)).Text]); + DisposeObject(nmPool); end; procedure test; var - NL: TNumberModuleList; + NL: TNumberModulePool; n: SystemString; begin - NL := TNumberModuleList.Create; + NL := TNumberModulePool.Create; NL['a'].OriginValue := '123'; NL['a'].Description := 'hahahaha'; NL.Macro('hello world', '<', '>', '.', n); @@ -1197,10 +1050,4 @@ procedure test; DoStatus(n); end; -initialization - -// test; - -finalization - end. diff --git a/Source/ObjectDataManager.pas b/Source/ObjectDataManager.pas index 521d5bcc..caf8f228 100644 --- a/Source/ObjectDataManager.pas +++ b/Source/ObjectDataManager.pas @@ -230,7 +230,7 @@ TObjectDataManager = class(TCoreClassObject) function ItemRename(const fieldPos: Int64; var ItemHnd: TItemHandle; const NewName, NewDescription: SystemString): Boolean; function ItemFastInsertNew(const fieldPos, InsertHeaderPos: Int64; const DBItemName, DBItemDescription: SystemString; var ItemHnd: TItemHandle): Boolean; function ItemFastCreate(const fPos: Int64; const DBItemName, DBItemDescription: SystemString; var ItemHnd: TItemHandle): Boolean; - function ItemFastOpen(const fPos: Int64; var ItemHnd: TItemHandle): Boolean; + function ItemFastOpen(const hPos: Int64; var ItemHnd: TItemHandle): Boolean; function ItemFastResetBody(const fPos: Int64): Boolean; function ItemFastExists(const fieldPos: Int64; const DBItemName: SystemString): Boolean; function ItemFastFindFirst(const fieldPos: Int64; const DBItemName: SystemString; var ItemSearchHandle: TItemSearch): Boolean; @@ -253,6 +253,7 @@ TObjectDataManager = class(TCoreClassObject) // item stream function ItemReadToStream(var ItemHnd: TItemHandle; stream: TCoreClassStream): Boolean; overload; + function ItemReadToStream(hPos: Int64; stream: TCoreClassStream): Boolean; overload; function ItemWriteFromStream(var ItemHnd: TItemHandle; stream: TCoreClassStream): Boolean; overload; function ItemReadToStream(const DBPath, DBItemName: SystemString; stream: TCoreClassStream): Boolean; overload; function ItemWriteFromStream(const DBPath, DBItemName: SystemString; stream: TCoreClassStream): Boolean; overload; @@ -1594,10 +1595,10 @@ function TObjectDataManager.ItemFastCreate(const fPos: Int64; const DBItemName, Result := db_ItemFastCreate(DBItemName, DBItemDescription, fPos, FDefaultItemID, ItemHnd, FDBHandle); end; -function TObjectDataManager.ItemFastOpen(const fPos: Int64; var ItemHnd: TItemHandle): Boolean; +function TObjectDataManager.ItemFastOpen(const hPos: Int64; var ItemHnd: TItemHandle): Boolean; begin Init_TTMDBItemHandle(ItemHnd); - Result := db_ItemFastOpen(fPos, FDefaultItemID, ItemHnd, FDBHandle); + Result := db_ItemFastOpen(hPos, FDefaultItemID, ItemHnd, FDBHandle); end; function TObjectDataManager.ItemFastResetBody(const fPos: Int64): Boolean; @@ -1715,6 +1716,16 @@ function TObjectDataManager.ItemReadToStream(var ItemHnd: TItemHandle; stream: T DisposeObject(sour); end; +function TObjectDataManager.ItemReadToStream(hPos: Int64; stream: TCoreClassStream): Boolean; +var + ItemHnd: TItemHandle; +begin + Result := ItemFastOpen(hPos, ItemHnd); + if not Result then + Exit; + Result := ItemReadToStream(ItemHnd, stream); +end; + function TObjectDataManager.ItemWriteFromStream(var ItemHnd: TItemHandle; stream: TCoreClassStream): Boolean; var sour: TItemStream; @@ -2925,6 +2936,7 @@ procedure TestObjectData(); initialization +Internal_ObjectDataMarshal := nil; ObjectDataMarshal(); finalization diff --git a/Source/OpCode.pas b/Source/OpCode.pas index 542270fa..e9d6d47e 100644 --- a/Source/OpCode.pas +++ b/Source/OpCode.pas @@ -22,7 +22,7 @@ interface -uses SysUtils, Variants, Math, CoreClasses, PascalStrings, DoStatusIO, ListEngine, UnicodeMixedLib, DataFrameEngine; +uses SysUtils, Variants, Math, CoreClasses, PascalStrings, DoStatusIO, ListEngine, UnicodeMixedLib; type TOpValueType = ( @@ -36,109 +36,102 @@ TOpCustomRunTime = class; TOpParam = array of Variant; - TOnOpCall = function(var Param: TOpParam): Variant; - TOnOpMethod = function(var Param: TOpParam): Variant of object; - TOnObjectOpCall = function(OpRunTime: TOpCustomRunTime; var Param: TOpParam): Variant; - TOnObjectOpMethod = function(OpRunTime: TOpCustomRunTime; var Param: TOpParam): Variant of object; - + TOnOpCall = function(var OP_Param: TOpParam): Variant; + TOnOpMethod = function(var OP_Param: TOpParam): Variant of object; + TOnObjectOpCall = function(Sender: TOpCustomRunTime; var OP_Param: TOpParam): Variant; + TOnObjectOpMethod = function(Sender: TOpCustomRunTime; var OP_Param: TOpParam): Variant of object; {$IFDEF FPC} - TOnOpProc = function(var Param: TOpParam): Variant is nested; - TOnObjectOpProc = function(OpRunTime: TOpCustomRunTime; var Param: TOpParam): Variant is nested; + TOnOpProc = function(var OP_Param: TOpParam): Variant is nested; + TOnObjectOpProc = function(Sender: TOpCustomRunTime; var OP_Param: TOpParam): Variant is nested; {$ELSE FPC} - TOnOpProc = reference to function(var Param: TOpParam): Variant; - TOnObjectOpProc = reference to function(OpRunTime: TOpCustomRunTime; var Param: TOpParam): Variant; + TOnOpProc = reference to function(var OP_Param: TOpParam): Variant; + TOnObjectOpProc = reference to function(Sender: TOpCustomRunTime; var OP_Param: TOpParam): Variant; {$ENDIF FPC} - POpRTData = ^TOpRTData; TOpRTData = record Param: TOpParam; Name, Description, Category: SystemString; OnOpCall: TOnOpCall; OnOpMethod: TOnOpMethod; + OnOpProc: TOnOpProc; OnObjectOpCall: TOnObjectOpCall; OnObjectOpMethod: TOnObjectOpMethod; - OnOpProc: TOnOpProc; OnObjectOpProc: TOnObjectOpProc; procedure Init; end; + POpRTData = ^TOpRTData; + TOpCustomRunTime = class(TCoreClassObject) protected procedure FreeNotifyProc(p: Pointer); - function DoInt(var Param: TOpParam): Variant; - function DoFrac(var Param: TOpParam): Variant; - function DoExp(var Param: TOpParam): Variant; - function DoCos(var Param: TOpParam): Variant; - function DoSin(var Param: TOpParam): Variant; - function DoLn(var Param: TOpParam): Variant; - function DoArcTan(var Param: TOpParam): Variant; - function DoSqrt(var Param: TOpParam): Variant; - function DoSqr(var Param: TOpParam): Variant; - function DoTan(var Param: TOpParam): Variant; - function DoRound(var Param: TOpParam): Variant; - function DoTrunc(var Param: TOpParam): Variant; - function DoDeg(var Param: TOpParam): Variant; - function DoPower(var Param: TOpParam): Variant; - - function DoSingle(var Param: TOpParam): Variant; - function DoDouble(var Param: TOpParam): Variant; - function DoExtended(var Param: TOpParam): Variant; - function DoByte(var Param: TOpParam): Variant; - function DoWord(var Param: TOpParam): Variant; - function DoCardinal(var Param: TOpParam): Variant; - function DoUInt64(var Param: TOpParam): Variant; - function DoShortInt(var Param: TOpParam): Variant; - function DoSmallInt(var Param: TOpParam): Variant; - function DoInteger(var Param: TOpParam): Variant; - function DoInt64(var Param: TOpParam): Variant; - - function DoROL8(var Param: TOpParam): Variant; - function DoROL16(var Param: TOpParam): Variant; - function DoROL32(var Param: TOpParam): Variant; - function DoROL64(var Param: TOpParam): Variant; - function DoROR8(var Param: TOpParam): Variant; - function DoROR16(var Param: TOpParam): Variant; - function DoROR32(var Param: TOpParam): Variant; - function DoROR64(var Param: TOpParam): Variant; - function DoEndian16(var Param: TOpParam): Variant; - function DoEndian32(var Param: TOpParam): Variant; - function DoEndian64(var Param: TOpParam): Variant; - function DoEndianU16(var Param: TOpParam): Variant; - function DoEndianU32(var Param: TOpParam): Variant; - function DoEndianU64(var Param: TOpParam): Variant; - function DoSAR16(var Param: TOpParam): Variant; - function DoSAR32(var Param: TOpParam): Variant; - function DoSAR64(var Param: TOpParam): Variant; - - function DoPI(var Param: TOpParam): Variant; - function DoBool(var Param: TOpParam): Variant; - function DoTrue(var Param: TOpParam): Variant; - function DoFalse(var Param: TOpParam): Variant; - function DoRColor(var Param: TOpParam): Variant; - function DoVec2(var Param: TOpParam): Variant; - function DoVec3(var Param: TOpParam): Variant; - function DoVec4(var Param: TOpParam): Variant; - - function DoRandom(var Param: TOpParam): Variant; - function DoRandomFloat(var Param: TOpParam): Variant; - - function DoMax(var Param: TOpParam): Variant; - function DoMin(var Param: TOpParam): Variant; - function DoClamp(var Param: TOpParam): Variant; - function DoIfThen(var Param: TOpParam): Variant; - - function DoStr(var Param: TOpParam): Variant; - - function DoGetFirst(var Param: TOpParam): Variant; - function DoDeleteFirst(var Param: TOpParam): Variant; - function DoGetLast(var Param: TOpParam): Variant; - function DoDeleteLast(var Param: TOpParam): Variant; - - function DoMultiple(var Param: TOpParam): Variant; - function DoPrint(var Param: TOpParam): Variant; - - procedure InternalReg; virtual; + function DoInt(var OP_Param: TOpParam): Variant; + function DoFrac(var OP_Param: TOpParam): Variant; + function DoExp(var OP_Param: TOpParam): Variant; + function DoCos(var OP_Param: TOpParam): Variant; + function DoSin(var OP_Param: TOpParam): Variant; + function DoLn(var OP_Param: TOpParam): Variant; + function DoArcTan(var OP_Param: TOpParam): Variant; + function DoSqrt(var OP_Param: TOpParam): Variant; + function DoSqr(var OP_Param: TOpParam): Variant; + function DoTan(var OP_Param: TOpParam): Variant; + function DoRound(var OP_Param: TOpParam): Variant; + function DoTrunc(var OP_Param: TOpParam): Variant; + function DoDeg(var OP_Param: TOpParam): Variant; + function DoPower(var OP_Param: TOpParam): Variant; + + function DoSingle(var OP_Param: TOpParam): Variant; + function DoDouble(var OP_Param: TOpParam): Variant; + function DoExtended(var OP_Param: TOpParam): Variant; + function DoByte(var OP_Param: TOpParam): Variant; + function DoWord(var OP_Param: TOpParam): Variant; + function DoCardinal(var OP_Param: TOpParam): Variant; + function DoUInt64(var OP_Param: TOpParam): Variant; + function DoShortInt(var OP_Param: TOpParam): Variant; + function DoSmallInt(var OP_Param: TOpParam): Variant; + function DoInteger(var OP_Param: TOpParam): Variant; + function DoInt64(var OP_Param: TOpParam): Variant; + + function DoROL8(var OP_Param: TOpParam): Variant; + function DoROL16(var OP_Param: TOpParam): Variant; + function DoROL32(var OP_Param: TOpParam): Variant; + function DoROL64(var OP_Param: TOpParam): Variant; + function DoROR8(var OP_Param: TOpParam): Variant; + function DoROR16(var OP_Param: TOpParam): Variant; + function DoROR32(var OP_Param: TOpParam): Variant; + function DoROR64(var OP_Param: TOpParam): Variant; + function DoEndian16(var OP_Param: TOpParam): Variant; + function DoEndian32(var OP_Param: TOpParam): Variant; + function DoEndian64(var OP_Param: TOpParam): Variant; + function DoEndianU16(var OP_Param: TOpParam): Variant; + function DoEndianU32(var OP_Param: TOpParam): Variant; + function DoEndianU64(var OP_Param: TOpParam): Variant; + function DoSAR16(var OP_Param: TOpParam): Variant; + function DoSAR32(var OP_Param: TOpParam): Variant; + function DoSAR64(var OP_Param: TOpParam): Variant; + + function DoPI(var OP_Param: TOpParam): Variant; + function DoBool(var OP_Param: TOpParam): Variant; + function DoTrue(var OP_Param: TOpParam): Variant; + function DoFalse(var OP_Param: TOpParam): Variant; + function DoRColor(var OP_Param: TOpParam): Variant; + function DoVec2(var OP_Param: TOpParam): Variant; + function DoVec3(var OP_Param: TOpParam): Variant; + function DoVec4(var OP_Param: TOpParam): Variant; + + function DoRandom(var OP_Param: TOpParam): Variant; + function DoRandomFloat(var OP_Param: TOpParam): Variant; + + function DoMax(var OP_Param: TOpParam): Variant; + function DoMin(var OP_Param: TOpParam): Variant; + function DoClamp(var OP_Param: TOpParam): Variant; + function DoIfThen(var OP_Param: TOpParam): Variant; + + function DoStr(var OP_Param: TOpParam): Variant; + + function DoMultiple(var OP_Param: TOpParam): Variant; + public ProcList: THashList; Trigger: POpRTData; @@ -147,8 +140,10 @@ TOpCustomRunTime = class(TCoreClassObject) UserData: Pointer; constructor Create; - constructor CustomCreate(maxHashLen: Integer); virtual; + constructor CustomCreate(maxHashSiz_: Integer); virtual; destructor Destroy; override; + procedure Clean; virtual; + procedure PrepareRegistation; virtual; function GetProcDescription(ProcName: SystemString): SystemString; overload; function GetAllProcDescription(): TPascalStringList; overload; @@ -365,7 +360,7 @@ function LoadOpFromStream(stream: TCoreClassStream; out LoadedOp: TOpCode): Bool implementation -uses Geometry2DUnit, Geometry3DUnit; +uses Geometry2DUnit, Geometry3DUnit, DataFrameEngine; type opRegData = record @@ -387,9 +382,9 @@ procedure TOpRTData.Init; Category := ''; OnOpCall := nil; OnOpMethod := nil; + OnOpProc := nil; OnObjectOpCall := nil; OnObjectOpMethod := nil; - OnOpProc := nil; OnObjectOpProc := nil; end; @@ -502,310 +497,310 @@ function LoadOpFromStream(stream: TCoreClassStream; out LoadedOp: TOpCode): Bool procedure TOpCustomRunTime.FreeNotifyProc(p: Pointer); begin - SetLength(POpRTData(p)^.Param, 0); + POpRTData(p)^.Init; Dispose(POpRTData(p)); end; -function TOpCustomRunTime.DoInt(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoInt(var OP_Param: TOpParam): Variant; var v: Variant; i: Integer; begin v := 0; - for i := low(Param) to high(Param) do - v := v + Param[i]; + for i := low(OP_Param) to high(OP_Param) do + v := v + OP_Param[i]; Result := Int(v); end; -function TOpCustomRunTime.DoFrac(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoFrac(var OP_Param: TOpParam): Variant; var v: Variant; i: Integer; begin v := 0; - for i := low(Param) to high(Param) do - v := v + Param[i]; + for i := low(OP_Param) to high(OP_Param) do + v := v + OP_Param[i]; Result := Frac(v); end; -function TOpCustomRunTime.DoExp(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoExp(var OP_Param: TOpParam): Variant; var v: Variant; i: Integer; begin v := 0; - for i := low(Param) to high(Param) do - v := v + Param[i]; + for i := low(OP_Param) to high(OP_Param) do + v := v + OP_Param[i]; Result := Exp(v); end; -function TOpCustomRunTime.DoCos(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoCos(var OP_Param: TOpParam): Variant; var v: Variant; i: Integer; begin v := 0; - for i := low(Param) to high(Param) do - v := v + Param[i]; + for i := low(OP_Param) to high(OP_Param) do + v := v + OP_Param[i]; Result := Cos(v); end; -function TOpCustomRunTime.DoSin(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoSin(var OP_Param: TOpParam): Variant; var v: Variant; i: Integer; begin v := 0; - for i := low(Param) to high(Param) do - v := v + Param[i]; + for i := low(OP_Param) to high(OP_Param) do + v := v + OP_Param[i]; Result := Sin(v); end; -function TOpCustomRunTime.DoLn(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoLn(var OP_Param: TOpParam): Variant; var v: Variant; i: Integer; begin v := 0; - for i := low(Param) to high(Param) do - v := v + Param[i]; + for i := low(OP_Param) to high(OP_Param) do + v := v + OP_Param[i]; Result := ln(v); end; -function TOpCustomRunTime.DoArcTan(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoArcTan(var OP_Param: TOpParam): Variant; var v: Variant; i: Integer; begin v := 0; - for i := low(Param) to high(Param) do - v := v + Param[i]; + for i := low(OP_Param) to high(OP_Param) do + v := v + OP_Param[i]; Result := ArcTan(v); end; -function TOpCustomRunTime.DoSqrt(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoSqrt(var OP_Param: TOpParam): Variant; var v: Variant; i: Integer; begin v := 0; - for i := low(Param) to high(Param) do - v := v + Param[i]; + for i := low(OP_Param) to high(OP_Param) do + v := v + OP_Param[i]; Result := Sqrt(v); end; -function TOpCustomRunTime.DoSqr(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoSqr(var OP_Param: TOpParam): Variant; var v: Variant; i: Integer; begin v := 0; - for i := low(Param) to high(Param) do - v := v + Param[i]; + for i := low(OP_Param) to high(OP_Param) do + v := v + OP_Param[i]; Result := Sqr(v); end; -function TOpCustomRunTime.DoTan(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoTan(var OP_Param: TOpParam): Variant; var v: Variant; i: Integer; begin v := 0; - for i := low(Param) to high(Param) do - v := v + Param[i]; + for i := low(OP_Param) to high(OP_Param) do + v := v + OP_Param[i]; Result := Tan(v); end; -function TOpCustomRunTime.DoRound(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoRound(var OP_Param: TOpParam): Variant; var v: Variant; i: Integer; begin v := 0; - for i := low(Param) to high(Param) do - v := v + Param[i]; + for i := low(OP_Param) to high(OP_Param) do + v := v + OP_Param[i]; Result := Round(Double(v)); end; -function TOpCustomRunTime.DoTrunc(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoTrunc(var OP_Param: TOpParam): Variant; var v: Variant; i: Integer; begin v := 0; - for i := low(Param) to high(Param) do - v := v + Param[i]; + for i := low(OP_Param) to high(OP_Param) do + v := v + OP_Param[i]; Result := Trunc(Double(v)); end; -function TOpCustomRunTime.DoDeg(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoDeg(var OP_Param: TOpParam): Variant; var v: Variant; i: Integer; begin v := 0; - for i := low(Param) to high(Param) do - v := v + Param[i]; + for i := low(OP_Param) to high(OP_Param) do + v := v + OP_Param[i]; Result := NormalizeDegAngle(TGeoFloat(v)); end; -function TOpCustomRunTime.DoPower(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoPower(var OP_Param: TOpParam): Variant; var v: Variant; i: Integer; begin - if length(Param) = 2 then - Result := Power(Param[0], Param[1]) + if length(OP_Param) = 2 then + Result := Power(OP_Param[0], OP_Param[1]) else Result := 0; end; -function TOpCustomRunTime.DoSingle(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoSingle(var OP_Param: TOpParam): Variant; begin - Result := Single(Param[0]); + Result := Single(OP_Param[0]); end; -function TOpCustomRunTime.DoDouble(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoDouble(var OP_Param: TOpParam): Variant; begin - Result := Double(Param[0]); + Result := Double(OP_Param[0]); end; -function TOpCustomRunTime.DoExtended(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoExtended(var OP_Param: TOpParam): Variant; begin - Result := Extended(Param[0]); + Result := Extended(OP_Param[0]); end; -function TOpCustomRunTime.DoByte(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoByte(var OP_Param: TOpParam): Variant; begin - Result := Byte(Param[0]); + Result := Byte(OP_Param[0]); end; -function TOpCustomRunTime.DoWord(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoWord(var OP_Param: TOpParam): Variant; begin - Result := Word(Param[0]); + Result := Word(OP_Param[0]); end; -function TOpCustomRunTime.DoCardinal(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoCardinal(var OP_Param: TOpParam): Variant; begin - Result := Cardinal(Param[0]); + Result := Cardinal(OP_Param[0]); end; -function TOpCustomRunTime.DoUInt64(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoUInt64(var OP_Param: TOpParam): Variant; begin - Result := UInt64(Param[0]); + Result := UInt64(OP_Param[0]); end; -function TOpCustomRunTime.DoShortInt(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoShortInt(var OP_Param: TOpParam): Variant; begin - Result := ShortInt(Param[0]); + Result := ShortInt(OP_Param[0]); end; -function TOpCustomRunTime.DoSmallInt(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoSmallInt(var OP_Param: TOpParam): Variant; begin - Result := SmallInt(Param[0]); + Result := SmallInt(OP_Param[0]); end; -function TOpCustomRunTime.DoInteger(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoInteger(var OP_Param: TOpParam): Variant; begin - Result := Integer(Param[0]); + Result := Integer(OP_Param[0]); end; -function TOpCustomRunTime.DoInt64(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoInt64(var OP_Param: TOpParam): Variant; begin - Result := Int64(Param[0]); + Result := Int64(OP_Param[0]); end; -function TOpCustomRunTime.DoROL8(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoROL8(var OP_Param: TOpParam): Variant; begin - Result := ROL8(Param[0], Param[1]); + Result := ROL8(OP_Param[0], OP_Param[1]); end; -function TOpCustomRunTime.DoROL16(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoROL16(var OP_Param: TOpParam): Variant; begin - Result := ROL16(Param[0], Param[1]); + Result := ROL16(OP_Param[0], OP_Param[1]); end; -function TOpCustomRunTime.DoROL32(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoROL32(var OP_Param: TOpParam): Variant; begin - Result := ROL32(Param[0], Param[1]); + Result := ROL32(OP_Param[0], OP_Param[1]); end; -function TOpCustomRunTime.DoROL64(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoROL64(var OP_Param: TOpParam): Variant; begin - Result := ROL64(Param[0], Param[1]); + Result := ROL64(OP_Param[0], OP_Param[1]); end; -function TOpCustomRunTime.DoROR8(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoROR8(var OP_Param: TOpParam): Variant; begin - Result := ROR8(Param[0], Param[1]); + Result := ROR8(OP_Param[0], OP_Param[1]); end; -function TOpCustomRunTime.DoROR16(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoROR16(var OP_Param: TOpParam): Variant; begin - Result := ROR16(Param[0], Param[1]); + Result := ROR16(OP_Param[0], OP_Param[1]); end; -function TOpCustomRunTime.DoROR32(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoROR32(var OP_Param: TOpParam): Variant; begin - Result := ROR32(Param[0], Param[1]); + Result := ROR32(OP_Param[0], OP_Param[1]); end; -function TOpCustomRunTime.DoROR64(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoROR64(var OP_Param: TOpParam): Variant; begin - Result := ROR64(Param[0], Param[1]); + Result := ROR64(OP_Param[0], OP_Param[1]); end; -function TOpCustomRunTime.DoEndian16(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoEndian16(var OP_Param: TOpParam): Variant; begin - Result := Endian(SmallInt(Param[0])); + Result := Endian(SmallInt(OP_Param[0])); end; -function TOpCustomRunTime.DoEndian32(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoEndian32(var OP_Param: TOpParam): Variant; begin - Result := Endian(Integer(Param[0])); + Result := Endian(Integer(OP_Param[0])); end; -function TOpCustomRunTime.DoEndian64(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoEndian64(var OP_Param: TOpParam): Variant; begin - Result := Endian(Int64(Param[0])); + Result := Endian(Int64(OP_Param[0])); end; -function TOpCustomRunTime.DoEndianU16(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoEndianU16(var OP_Param: TOpParam): Variant; begin - Result := Endian(Word(Param[0])); + Result := Endian(Word(OP_Param[0])); end; -function TOpCustomRunTime.DoEndianU32(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoEndianU32(var OP_Param: TOpParam): Variant; begin - Result := Endian(Cardinal(Param[0])); + Result := Endian(Cardinal(OP_Param[0])); end; -function TOpCustomRunTime.DoEndianU64(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoEndianU64(var OP_Param: TOpParam): Variant; begin - Result := Endian(UInt64(Param[0])); + Result := Endian(UInt64(OP_Param[0])); end; -function TOpCustomRunTime.DoSAR16(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoSAR16(var OP_Param: TOpParam): Variant; begin - Result := SAR16(Param[0], Param[1]); + Result := SAR16(OP_Param[0], OP_Param[1]); end; -function TOpCustomRunTime.DoSAR32(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoSAR32(var OP_Param: TOpParam): Variant; begin - Result := SAR32(Param[0], Param[1]); + Result := SAR32(OP_Param[0], OP_Param[1]); end; -function TOpCustomRunTime.DoSAR64(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoSAR64(var OP_Param: TOpParam): Variant; begin - Result := SAR64(Param[0], Param[1]); + Result := SAR64(OP_Param[0], OP_Param[1]); end; -function TOpCustomRunTime.DoPI(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoPI(var OP_Param: TOpParam): Variant; begin Result := PI; end; -function TOpCustomRunTime.DoBool(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoBool(var OP_Param: TOpParam): Variant; function v2b(const v: Variant): Boolean; var n: TPascalString; @@ -832,22 +827,22 @@ function TOpCustomRunTime.DoBool(var Param: TOpParam): Variant; i: Integer; begin n := True; - for i := low(Param) to high(Param) do - n := n and v2b(Param[i]); + for i := low(OP_Param) to high(OP_Param) do + n := n and v2b(OP_Param[i]); Result := n; end; -function TOpCustomRunTime.DoTrue(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoTrue(var OP_Param: TOpParam): Variant; begin Result := True; end; -function TOpCustomRunTime.DoFalse(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoFalse(var OP_Param: TOpParam): Variant; begin Result := False; end; -function TOpCustomRunTime.DoRColor(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoRColor(var OP_Param: TOpParam): Variant; var buff: array [0 .. 3] of SystemString; i: Integer; @@ -856,13 +851,13 @@ function TOpCustomRunTime.DoRColor(var Param: TOpParam): Variant; buff[i] := '0.0'; buff[3] := '1.0'; - for i := Low(Param) to high(Param) do - buff[i] := VarToStr(Param[i]); + for i := Low(OP_Param) to high(OP_Param) do + buff[i] := VarToStr(OP_Param[i]); Result := Format('RColor(%s,%s,%s,%s)', [buff[0], buff[1], buff[2], buff[3]]); end; -function TOpCustomRunTime.DoVec2(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoVec2(var OP_Param: TOpParam): Variant; var buff: array [0 .. 1] of SystemString; i: Integer; @@ -870,13 +865,13 @@ function TOpCustomRunTime.DoVec2(var Param: TOpParam): Variant; for i := Low(buff) to high(buff) do buff[i] := '0.0'; - for i := Low(Param) to high(Param) do - buff[i] := VarToStr(Param[i]); + for i := Low(OP_Param) to high(OP_Param) do + buff[i] := VarToStr(OP_Param[i]); Result := Format('Vec2(%s,%s)', [buff[0], buff[1]]); end; -function TOpCustomRunTime.DoVec3(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoVec3(var OP_Param: TOpParam): Variant; var buff: array [0 .. 2] of SystemString; i: Integer; @@ -884,13 +879,13 @@ function TOpCustomRunTime.DoVec3(var Param: TOpParam): Variant; for i := Low(buff) to high(buff) do buff[i] := '0.0'; - for i := Low(Param) to high(Param) do - buff[i] := VarToStr(Param[i]); + for i := Low(OP_Param) to high(OP_Param) do + buff[i] := VarToStr(OP_Param[i]); Result := Format('Vec3(%s,%s,%s)', [buff[0], buff[1], buff[2]]); end; -function TOpCustomRunTime.DoVec4(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoVec4(var OP_Param: TOpParam): Variant; var buff: array [0 .. 3] of SystemString; i: Integer; @@ -898,20 +893,20 @@ function TOpCustomRunTime.DoVec4(var Param: TOpParam): Variant; for i := Low(buff) to high(buff) do buff[i] := '0.0'; - for i := Low(Param) to high(Param) do - buff[i] := VarToStr(Param[i]); + for i := Low(OP_Param) to high(OP_Param) do + buff[i] := VarToStr(OP_Param[i]); Result := Format('Vec4(%s,%s,%s,%s)', [buff[0], buff[1], buff[2], buff[3]]); end; -function TOpCustomRunTime.DoRandom(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoRandom(var OP_Param: TOpParam): Variant; var v: Integer; i: Integer; begin v := 0; - for i := low(Param) to high(Param) do - v := v + Param[i]; + for i := low(OP_Param) to high(OP_Param) do + v := v + OP_Param[i]; if v <> 0 then Result := MT19937Rand32(v) @@ -919,162 +914,142 @@ function TOpCustomRunTime.DoRandom(var Param: TOpParam): Variant; Result := MT19937Rand32(MaxInt); end; -function TOpCustomRunTime.DoRandomFloat(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoRandomFloat(var OP_Param: TOpParam): Variant; begin Result := MT19937RandF; end; -function TOpCustomRunTime.DoMax(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoMax(var OP_Param: TOpParam): Variant; var i: Integer; begin - if length(Param) = 0 then + if length(OP_Param) = 0 then begin Result := NULL; Exit; end; - Result := Param[0]; - for i := 1 to length(Param) - 1 do - if Param[i] > Result then - Result := Param[i]; + Result := OP_Param[0]; + for i := 1 to length(OP_Param) - 1 do + if OP_Param[i] > Result then + Result := OP_Param[i]; end; -function TOpCustomRunTime.DoMin(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoMin(var OP_Param: TOpParam): Variant; var i: Integer; begin - if length(Param) = 0 then + if length(OP_Param) = 0 then begin Result := NULL; Exit; end; - Result := Param[0]; - for i := 1 to length(Param) - 1 do - if Param[i] < Result then - Result := Param[i]; + Result := OP_Param[0]; + for i := 1 to length(OP_Param) - 1 do + if OP_Param[i] < Result then + Result := OP_Param[i]; end; -function TOpCustomRunTime.DoClamp(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoClamp(var OP_Param: TOpParam): Variant; var minv_, maxv_: Variant; begin - if length(Param) <> 3 then + if length(OP_Param) <> 3 then begin - if length(Param) > 0 then - Result := Param[0] + if length(OP_Param) > 0 then + Result := OP_Param[0] else Result := NULL; Exit; end; - if Param[1] > Param[2] then + if OP_Param[1] > OP_Param[2] then begin - minv_ := Param[2]; - maxv_ := Param[1]; + minv_ := OP_Param[2]; + maxv_ := OP_Param[1]; end else begin - minv_ := Param[1]; - maxv_ := Param[2]; + minv_ := OP_Param[1]; + maxv_ := OP_Param[2]; end; - if Param[0] < minv_ then + if OP_Param[0] < minv_ then Result := minv_ - else if Param[0] > maxv_ then + else if OP_Param[0] > maxv_ then Result := maxv_ else - Result := Param[0]; + Result := OP_Param[0]; end; -function TOpCustomRunTime.DoIfThen(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoIfThen(var OP_Param: TOpParam): Variant; begin - if length(Param) <> 3 then + if length(OP_Param) <> 3 then begin Result := NULL; Exit; end; - if Boolean(Param[0]) = True then - Result := Param[1] + if Boolean(OP_Param[0]) = True then + Result := OP_Param[1] else - Result := Param[2]; + Result := OP_Param[2]; end; -function TOpCustomRunTime.DoStr(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoStr(var OP_Param: TOpParam): Variant; var n: TPascalString; i: Integer; begin n := ''; - for i := low(Param) to high(Param) do - n.Append(VarToStr(Param[i])); + for i := low(OP_Param) to high(OP_Param) do + n.Append(VarToStr(OP_Param[i])); Result := n; end; -function TOpCustomRunTime.DoGetFirst(var Param: TOpParam): Variant; -begin - if length(Param) = 2 then - Result := umlGetFirstStr(VarToStr(Param[0]), VarToStr(Param[1])).Text - else - Result := ''; -end; - -function TOpCustomRunTime.DoDeleteFirst(var Param: TOpParam): Variant; +function TOpCustomRunTime.DoMultiple(var OP_Param: TOpParam): Variant; +var + i: Integer; begin - if length(Param) = 2 then - Result := umlDeleteFirstStr(VarToStr(Param[0]), VarToStr(Param[1])).Text + if length(OP_Param) >= 2 then + begin + Result := True; + for i := 1 to length(OP_Param) - 1 do + Result := Result and umlMultipleMatch(VarToStr(OP_Param[0]), VarToStr(OP_Param[i])); + end else - Result := ''; + Result := True; end; -function TOpCustomRunTime.DoGetLast(var Param: TOpParam): Variant; +constructor TOpCustomRunTime.Create; begin - if length(Param) = 2 then - Result := umlGetLastStr(VarToStr(Param[0]), VarToStr(Param[1])).Text - else - Result := ''; + CustomCreate(1024); end; -function TOpCustomRunTime.DoDeleteLast(var Param: TOpParam): Variant; +constructor TOpCustomRunTime.CustomCreate(maxHashSiz_: Integer); begin - if length(Param) = 2 then - Result := umlDeleteLastStr(VarToStr(Param[0]), VarToStr(Param[1])).Text - else - Result := ''; + inherited Create; + ProcList := THashList.CustomCreate(maxHashSiz_); + ProcList.AutoFreeData := True; + ProcList.AccessOptimization := True; + ProcList.OnFreePtr := {$IFDEF FPC}@{$ENDIF FPC}FreeNotifyProc; + Trigger := nil; + UserObject := nil; + UserData := nil; + PrepareRegistation; end; -function TOpCustomRunTime.DoMultiple(var Param: TOpParam): Variant; -var - i: Integer; +destructor TOpCustomRunTime.Destroy; begin - if length(Param) >= 2 then - begin - Result := True; - for i := 1 to length(Param) - 1 do - Result := Result and umlMultipleMatch(VarToStr(Param[0]), VarToStr(Param[i])); - end - else - Result := True; + DisposeObject(ProcList); + inherited Destroy; end; -function TOpCustomRunTime.DoPrint(var Param: TOpParam): Variant; -var - i: Integer; +procedure TOpCustomRunTime.Clean; begin - for i := low(Param) to high(Param) do - begin - DoStatusNoLn(Param[i]); - if i < high(Param) then - DoStatusNoLn(#32); - end; - - DoStatusNoLn; - Result := True; + ProcList.Clear; end; -procedure TOpCustomRunTime.InternalReg; +procedure TOpCustomRunTime.PrepareRegistation; begin - ProcList.OnFreePtr := {$IFDEF FPC}@{$ENDIF FPC}FreeNotifyProc; - RegOpM('Int', 'Int(0..n): math function', {$IFDEF FPC}@{$ENDIF FPC}DoInt)^.Category := 'Base Math'; RegOpM('Frac', 'Frac(0..n): math function', {$IFDEF FPC}@{$ENDIF FPC}DoFrac)^.Category := 'Base Math'; RegOpM('Exp', 'Exp(0..n): math function', {$IFDEF FPC}@{$ENDIF FPC}DoExp)^.Category := 'Base Math'; @@ -1092,6 +1067,7 @@ procedure TOpCustomRunTime.InternalReg; RegOpM('Single', 'Single(value): math function', {$IFDEF FPC}@{$ENDIF FPC}DoSingle)^.Category := 'Base Math'; RegOpM('Double', 'Double(value): math function', {$IFDEF FPC}@{$ENDIF FPC}DoDouble)^.Category := 'Base Math'; + RegOpM('Float', 'Float(value): math function', {$IFDEF FPC}@{$ENDIF FPC}DoDouble)^.Category := 'Base Math'; RegOpM('Extended', 'Extended(value): math function', {$IFDEF FPC}@{$ENDIF FPC}DoExtended)^.Category := 'Base Math'; RegOpM('Byte', 'Byte(value): math function', {$IFDEF FPC}@{$ENDIF FPC}DoByte)^.Category := 'Base Math'; RegOpM('Word', 'Word(value): math function', {$IFDEF FPC}@{$ENDIF FPC}DoWord)^.Category := 'Base Math'; @@ -1140,47 +1116,11 @@ procedure TOpCustomRunTime.InternalReg; RegOpM('IfThen', 'IfThen(bool, if true then of value, if false then of value): return if value', {$IFDEF FPC}@{$ENDIF FPC}DoIfThen)^.Category := 'Base Math'; RegOpM('Str', 'Str(n..n): convert any variant as string', {$IFDEF FPC}@{$ENDIF FPC}DoStr)^.Category := 'Base String'; - RegOpM('Base String', 'String(n..n): convert any variant as string', {$IFDEF FPC}@{$ENDIF FPC}DoStr)^.Category := 'Base String'; + RegOpM('String', 'String(n..n): convert any variant as string', {$IFDEF FPC}@{$ENDIF FPC}DoStr)^.Category := 'Base String'; RegOpM('Text', 'Text(n..n): convert any variant as string', {$IFDEF FPC}@{$ENDIF FPC}DoStr)^.Category := 'Base String'; - RegOpM('GetFirst', 'GetFirst(string, split Char): return first split segment', {$IFDEF FPC}@{$ENDIF FPC}DoGetFirst)^.Category := 'Base String'; - RegOpM('First', 'First(string, split Char): return first split segment', {$IFDEF FPC}@{$ENDIF FPC}DoGetFirst)^.Category := 'Base String'; - RegOpM('DeleteFirst', 'DeleteFirst(string, split Char): return removed at after first split segment of value', {$IFDEF FPC}@{$ENDIF FPC}DoDeleteFirst)^.Category := 'Base String'; - RegOpM('GetLast', 'GetLast(string, split Char): return last split segment', {$IFDEF FPC}@{$ENDIF FPC}DoGetLast)^.Category := 'Base String'; - RegOpM('Last', 'Last(string, split Char): return last split segment', {$IFDEF FPC}@{$ENDIF FPC}DoGetLast)^.Category := 'Base String'; - RegOpM('DeleteLast', 'DeleteLast(string, split Char): return removed at after last split segment of value', {$IFDEF FPC}@{$ENDIF FPC}DoDeleteLast)^.Category := 'Base String'; - RegOpM('MultipleMatch', 'MultipleMatch(multile exp, n..n): return bool', {$IFDEF FPC}@{$ENDIF FPC}DoMultiple)^.Category := 'Base String'; RegOpM('Multiple', 'MultipleMatch(multile exp, n..n): return bool', {$IFDEF FPC}@{$ENDIF FPC}DoMultiple)^.Category := 'Base String'; - - RegOpM('Print', 'Print(n..n): output to console', {$IFDEF FPC}@{$ENDIF FPC}DoPrint)^.Category := 'Base String'; - RegOpM('DoStatus', 'DoStatus(n..n): output to console', {$IFDEF FPC}@{$ENDIF FPC}DoPrint)^.Category := 'Base String'; -end; - -constructor TOpCustomRunTime.Create; -begin - CustomCreate(1024); -end; - -constructor TOpCustomRunTime.CustomCreate(maxHashLen: Integer); -begin - inherited Create; - ProcList := THashList.CustomCreate(maxHashLen); - ProcList.AutoFreeData := True; - ProcList.AccessOptimization := True; - - Trigger := nil; - - UserObject := nil; - UserData := nil; - - InternalReg; -end; - -destructor TOpCustomRunTime.Destroy; -begin - DisposeObject(ProcList); - inherited Destroy; end; function TOpCustomRunTime.GetProcDescription(ProcName: SystemString): SystemString; @@ -1667,12 +1607,12 @@ function op_Proc.DoExecute(opRT: TOpCustomRunTime): Variant; Result := p^.OnOpCall(p^.Param); if Assigned(p^.OnOpMethod) then Result := p^.OnOpMethod(p^.Param); + if Assigned(p^.OnOpProc) then + Result := p^.OnOpProc(p^.Param); if Assigned(p^.OnObjectOpCall) then Result := p^.OnObjectOpCall(opRT, p^.Param); if Assigned(p^.OnObjectOpMethod) then Result := p^.OnObjectOpMethod(opRT, p^.Param); - if Assigned(p^.OnOpProc) then - Result := p^.OnOpProc(p^.Param); if Assigned(p^.OnObjectOpProc) then Result := p^.OnObjectOpProc(opRT, p^.Param); end; diff --git a/Source/UnicodeMixedLib.pas b/Source/UnicodeMixedLib.pas index 37405e7c..034e2f30 100644 --- a/Source/UnicodeMixedLib.pas +++ b/Source/UnicodeMixedLib.pas @@ -38,6 +38,7 @@ interface uses {$IFDEF FPC} Dynlibs, + FPCGenericStructlist, {$IFDEF MSWINDOWS} Windows, {$ENDIF MSWINDOWS} {$ELSE FPC} {$IFDEF MSWINDOWS} Windows, {$ENDIF MSWINDOWS} @@ -85,6 +86,7 @@ interface P_String = PPascalString; U_Char = SystemChar; U_StringArray = array of U_SystemString; + U_ArrayString = U_StringArray; U_Bytes = TBytes; @@ -498,6 +500,7 @@ function umlTestBase64(const text: TPascalString): Boolean; type PMD5 = ^TMD5; TMD5 = array [0 .. 15] of Byte; + TMD5List = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; const NullMD5: TMD5 = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0); diff --git a/Source/XNATClient.pas b/Source/XNATClient.pas index 5b9d6407..29dd79b8 100644 --- a/Source/XNATClient.pas +++ b/Source/XNATClient.pas @@ -59,7 +59,7 @@ TXClientMapping = class(TCoreClassObject) procedure SendTunnel_ConnectResult(const cState: Boolean); procedure RecvTunnel_ConnectResult(const cState: Boolean); - procedure RequestListen_Result(Sender: TPeerIO; ResultData: TDataFrameEngine); + procedure RequestListen_Result(Sender: TPeerIO; Result_: TDataFrameEngine); procedure delay_RequestListen(Sender: TNPostExecute); procedure Open; @@ -96,7 +96,7 @@ TPhysicsEngine_Special = class(TPeerIOUserSpecial) procedure PhysicsConnect_Result_BuildP2PToken(const cState: Boolean); procedure PhysicsVMBuildAuthToken_Result; procedure PhysicsOpenVM_Result(const cState: Boolean); - procedure IPV6Listen_Result(Sender: TPeerIO; ResultData: TDataFrameEngine); + procedure IPV6Listen_Result(Sender: TPeerIO; Result_: TDataFrameEngine); public constructor Create(Owner_: TPeerIO); override; destructor Destroy; override; @@ -194,9 +194,9 @@ procedure TXClientMapping.RecvTunnel_ConnectResult(const cState: Boolean); DoStatus('error: [%s] Receive Tunnel connect failed!', [Mapping.Text]); end; -procedure TXClientMapping.RequestListen_Result(Sender: TPeerIO; ResultData: TDataFrameEngine); +procedure TXClientMapping.RequestListen_Result(Sender: TPeerIO; Result_: TDataFrameEngine); begin - if ResultData.Reader.ReadBool then + if Result_.Reader.ReadBool then begin DoStatus('success: remote host:%s port:%s mapping to host:%s port:%s', [XClientTunnel.Host.Text, Remote_ListenPort.Text, Addr.Text, Port.Text]); UpdateWorkload(True); @@ -543,14 +543,13 @@ procedure TPhysicsEngine_Special.PhysicsOpenVM_Result(const cState: Boolean); if cState then begin Owner.p2pVMTunnel.MaxVMFragmentSize := umlStrToInt(XNAT.MaxVMFragment, Owner.p2pVMTunnel.MaxVMFragmentSize); - Owner.p2pVMTunnel.MaxRealBuffer := umlStrToInt(XNAT.MaxRealBuffer, Owner.p2pVMTunnel.MaxRealBuffer); Owner.SendStreamCmdM(C_IPV6Listen, nil, {$IFDEF FPC}@{$ENDIF FPC}IPV6Listen_Result); end else XNAT.WaitAsyncConnecting := False; end; -procedure TPhysicsEngine_Special.IPV6Listen_Result(Sender: TPeerIO; ResultData: TDataFrameEngine); +procedure TPhysicsEngine_Special.IPV6Listen_Result(Sender: TPeerIO; Result_: TDataFrameEngine); var Mapping: TPascalString; Remote_ListenAddr, Remote_ListenPort: TPascalString; @@ -560,15 +559,15 @@ procedure TPhysicsEngine_Special.IPV6Listen_Result(Sender: TPeerIO; ResultData: SendTunnel_Port: Word; tunMp: TXClientMapping; begin - while ResultData.Reader.NotEnd do + while Result_.Reader.NotEnd do begin - Mapping := ResultData.Reader.ReadString; - Remote_ListenAddr := ResultData.Reader.ReadString; - Remote_ListenPort := ResultData.Reader.ReadString; - SendTunnel_IPV6 := ResultData.Reader.ReadString; - SendTunnel_Port := ResultData.Reader.ReadWord; - RecvTunnel_IPV6 := ResultData.Reader.ReadString; - RecvTunnel_Port := ResultData.Reader.ReadWord; + Mapping := Result_.Reader.ReadString; + Remote_ListenAddr := Result_.Reader.ReadString; + Remote_ListenPort := Result_.Reader.ReadString; + SendTunnel_IPV6 := Result_.Reader.ReadString; + SendTunnel_Port := Result_.Reader.ReadWord; + RecvTunnel_IPV6 := Result_.Reader.ReadString; + RecvTunnel_Port := Result_.Reader.ReadWord; tunMp := TXClientMapping(XNAT.HashMapping[Mapping]); if tunMp <> nil then begin diff --git a/Source/XNATMappingOnVirutalService.pas b/Source/XNATMappingOnVirutalService.pas index 317ff76d..954193b3 100644 --- a/Source/XNATMappingOnVirutalService.pas +++ b/Source/XNATMappingOnVirutalService.pas @@ -76,7 +76,7 @@ TXNAT_MappingOnVirutalServer = class(TCommunicationFrameworkServer) procedure SendTunnel_ConnectResult(const cState: Boolean); procedure RecvTunnel_ConnectResult(const cState: Boolean); - procedure RequestListen_Result(Sender: TPeerIO; ResultData: TDataFrameEngine); + procedure RequestListen_Result(Sender: TPeerIO; Result_: TDataFrameEngine); procedure delay_RequestListen(Sender: TNPostExecute); procedure Open; @@ -95,7 +95,7 @@ TXNAT_MappingOnVirutalServer = class(TCommunicationFrameworkServer) procedure Progress; override; procedure TriggerQueueData(v: PQueueData); override; function WaitSendConsoleCmd(p_io: TPeerIO; const Cmd, ConsoleData: SystemString; Timeout: TTimeTick): SystemString; override; - procedure WaitSendStreamCmd(p_io: TPeerIO; const Cmd: SystemString; StreamData, ResultData: TDataFrameEngine; Timeout: TTimeTick); override; + procedure WaitSendStreamCmd(p_io: TPeerIO; const Cmd: SystemString; StreamData, Result_: TDataFrameEngine; Timeout: TTimeTick); override; end; TPhysicsEngine_Special = class(TPeerIOUserSpecial) @@ -104,7 +104,7 @@ TPhysicsEngine_Special = class(TPeerIOUserSpecial) procedure PhysicsConnect_Result_BuildP2PToken(const cState: Boolean); procedure PhysicsVMBuildAuthToken_Result; procedure PhysicsOpenVM_Result(const cState: Boolean); - procedure IPV6Listen_Result(Sender: TPeerIO; ResultData: TDataFrameEngine); + procedure IPV6Listen_Result(Sender: TPeerIO; Result_: TDataFrameEngine); public constructor Create(Owner_: TPeerIO); override; destructor Destroy; override; @@ -291,9 +291,9 @@ procedure TXNAT_MappingOnVirutalServer.RecvTunnel_ConnectResult(const cState: Bo DoStatus('error: [%s] Receive Tunnel connect failed!', [Mapping.Text]); end; -procedure TXNAT_MappingOnVirutalServer.RequestListen_Result(Sender: TPeerIO; ResultData: TDataFrameEngine); +procedure TXNAT_MappingOnVirutalServer.RequestListen_Result(Sender: TPeerIO; Result_: TDataFrameEngine); begin - if ResultData.Reader.ReadBool then + if Result_.Reader.ReadBool then begin DoStatus('success: remote host:%s port:%s mapping to local server', [XNAT.Host.Text, Remote_ListenPort.Text]); UpdateWorkload(True); @@ -514,7 +514,7 @@ function TXNAT_MappingOnVirutalServer.WaitSendConsoleCmd(p_io: TPeerIO; const Cm RaiseInfo('WaitSend no Suppport'); end; -procedure TXNAT_MappingOnVirutalServer.WaitSendStreamCmd(p_io: TPeerIO; const Cmd: SystemString; StreamData, ResultData: TDataFrameEngine; Timeout: TTimeTick); +procedure TXNAT_MappingOnVirutalServer.WaitSendStreamCmd(p_io: TPeerIO; const Cmd: SystemString; StreamData, Result_: TDataFrameEngine; Timeout: TTimeTick); begin RaiseInfo('WaitSend no Suppport'); end; @@ -556,14 +556,13 @@ procedure TPhysicsEngine_Special.PhysicsOpenVM_Result(const cState: Boolean); if cState then begin Owner.p2pVMTunnel.MaxVMFragmentSize := umlStrToInt(XNAT.MaxVMFragment, Owner.p2pVMTunnel.MaxVMFragmentSize); - Owner.p2pVMTunnel.MaxRealBuffer := umlStrToInt(XNAT.MaxRealBuffer, Owner.p2pVMTunnel.MaxRealBuffer); Owner.SendStreamCmdM(C_IPV6Listen, nil, {$IFDEF FPC}@{$ENDIF FPC}IPV6Listen_Result); end else XNAT.WaitAsyncConnecting := False; end; -procedure TPhysicsEngine_Special.IPV6Listen_Result(Sender: TPeerIO; ResultData: TDataFrameEngine); +procedure TPhysicsEngine_Special.IPV6Listen_Result(Sender: TPeerIO; Result_: TDataFrameEngine); var Mapping: TPascalString; Remote_ListenAddr, Remote_ListenPort: TPascalString; @@ -573,15 +572,15 @@ procedure TPhysicsEngine_Special.IPV6Listen_Result(Sender: TPeerIO; ResultData: SendTunnel_Port: Word; tunMp: TXNAT_MappingOnVirutalServer; begin - while ResultData.Reader.NotEnd do + while Result_.Reader.NotEnd do begin - Mapping := ResultData.Reader.ReadString; - Remote_ListenAddr := ResultData.Reader.ReadString; - Remote_ListenPort := ResultData.Reader.ReadString; - SendTunnel_IPV6 := ResultData.Reader.ReadString; - SendTunnel_Port := ResultData.Reader.ReadWord; - RecvTunnel_IPV6 := ResultData.Reader.ReadString; - RecvTunnel_Port := ResultData.Reader.ReadWord; + Mapping := Result_.Reader.ReadString; + Remote_ListenAddr := Result_.Reader.ReadString; + Remote_ListenPort := Result_.Reader.ReadString; + SendTunnel_IPV6 := Result_.Reader.ReadString; + SendTunnel_Port := Result_.Reader.ReadWord; + RecvTunnel_IPV6 := Result_.Reader.ReadString; + RecvTunnel_Port := Result_.Reader.ReadWord; tunMp := TXNAT_MappingOnVirutalServer(XNAT.HashMapping[Mapping]); if tunMp <> nil then begin diff --git a/Source/XNATService.pas b/Source/XNATService.pas index 4e6cbbe4..19575c28 100644 --- a/Source/XNATService.pas +++ b/Source/XNATService.pas @@ -738,7 +738,6 @@ procedure TPhysicsEngine_Special.PhysicsOpenVM_Result(const cState: Boolean); if cState then begin Owner.p2pVMTunnel.MaxVMFragmentSize := umlStrToInt(XNAT.MaxVMFragment, Owner.p2pVMTunnel.MaxVMFragmentSize); - Owner.p2pVMTunnel.MaxRealBuffer := umlStrToInt(XNAT.MaxRealBuffer, Owner.p2pVMTunnel.MaxRealBuffer); XNAT.Activted := True; { open share listen } @@ -850,7 +849,6 @@ procedure TXNATService.p2pVMTunnelOpenBefore(Sender: TPeerIO; p2pVMTunnel: TComm begin shLt := ShareListenList[i] as TXServiceListen; Sender.p2pVM.MaxVMFragmentSize := umlStrToInt(MaxVMFragment, Sender.p2pVM.MaxVMFragmentSize); - Sender.p2pVM.MaxRealBuffer := umlStrToInt(MaxRealBuffer, Sender.p2pVM.MaxRealBuffer); Sender.p2pVM.InstallLogicFramework(shLt.RecvTunnel); Sender.p2pVM.InstallLogicFramework(shLt.SendTunnel); end; diff --git a/Source/ZDB2.pas b/Source/ZDB2.pas index db787bfa..1d9bcfc2 100644 --- a/Source/ZDB2.pas +++ b/Source/ZDB2.pas @@ -165,7 +165,6 @@ TZDB2 = class procedure NewStream(Stream: TCoreClassStream; Space_: Int64; BlockSize_: Word; Mode: TZDB2_SpaceMode); overload; procedure OpenStream(Cipher_: IZDB2_Cipher; Stream: TCoreClassStream; OnlyRead: Boolean; Mode: TZDB2_SpaceMode); overload; procedure OpenStream(Stream: TCoreClassStream; OnlyRead: Boolean; Mode: TZDB2_SpaceMode); overload; - procedure NewFile(Cipher_: IZDB2_Cipher; Filename: U_String; Space_: Int64; BlockSize_: Word; Mode: TZDB2_SpaceMode); overload; procedure NewFile(Filename: U_String; Space_: Int64; BlockSize_: Word; Mode: TZDB2_SpaceMode); overload; procedure OpenFile(Cipher_: IZDB2_Cipher; Filename: U_String; OnlyRead: Boolean; Mode: TZDB2_SpaceMode); overload; diff --git a/Source/ZJson.pas b/Source/ZJson.pas index 9675271d..9b8b0e66 100644 --- a/Source/ZJson.pas +++ b/Source/ZJson.pas @@ -27,6 +27,7 @@ interface {$IFDEF DELPHI} ZS_JsonDataObjects, {$ELSE DELPHI} + FPCGenericStructlist, fpjson, jsonparser, jsonscanner, {$ENDIF DELPHI} CoreClasses, PascalStrings, DoStatusIO, @@ -123,13 +124,17 @@ TZ_JsonArray = class(TZ_JsonBase) TZ_JsonObject = class(TZ_JsonBase) private FInstance: TZ_Instance_JsonObject; + FTag: Integer; public + property Tag: Integer read FTag write FTag; property Instance: TZ_Instance_JsonObject read FInstance; constructor Create(Parent_: TZ_JsonBase); overload; override; constructor Create(); overload; destructor Destroy; override; + procedure Assign(source_: TZ_JsonObject); + procedure Clear; function IndexOf(const Name: string): Integer; @@ -185,6 +190,26 @@ TZ_JsonObject = class(TZ_JsonBase) class procedure Test; end; + TZ_JsonObject_List_Decl = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList; + + TZ_JsonObject_List = class(TZ_JsonObject_List_Decl) + public + AutoFreeObj: Boolean; + constructor Create(AutoFreeObj_: Boolean); + destructor Destroy; override; + function AddFromText(Text_: TPascalString): TZ_JsonObject; + function AddFromStream(stream: TCoreClassStream): TZ_JsonObject; + procedure Remove(obj: TZ_JsonObject); + procedure Delete(Index: Integer); + procedure Clear; + procedure Clean; + end; + + TZJArry = TZ_JsonArray; + TZJ = TZ_JsonObject; + TZJList = TZ_JsonObject_List; + TZJL = TZ_JsonObject_List; + implementation {$IFDEF DELPHI} @@ -224,6 +249,7 @@ destructor TZ_JsonArray.Destroy; constructor TZ_JsonObject.Create(Parent_: TZ_JsonBase); begin inherited Create(Parent_); + FTag := 0; if Parent = nil then FInstance := TZ_Instance_JsonObject.Create; end; @@ -240,6 +266,17 @@ destructor TZ_JsonObject.Destroy; inherited Destroy; end; +procedure TZ_JsonObject.Assign(source_: TZ_JsonObject); +var + m64: TMS64; +begin + m64 := TMS64.Create; + source_.SaveToStream(m64); + m64.Position := 0; + LoadFromStream(m64); + disposeObject(m64); +end; + procedure TZ_JsonObject.SaveToStream(stream: TCoreClassStream); begin SaveToStream(stream, True); @@ -284,7 +321,7 @@ procedure TZ_JsonObject.SaveToFile(FileName: SystemString); SaveToStream(m64); m64.SaveToFile(FileName); finally - DisposeObject(m64); + disposeObject(m64); end; end; @@ -296,14 +333,14 @@ procedure TZ_JsonObject.LoadFromFile(FileName: SystemString); try m64.LoadFromFile(FileName); except - DisposeObject(m64); + disposeObject(m64); Exit; end; try LoadFromStream(m64); finally - DisposeObject(m64); + disposeObject(m64); end; end; @@ -373,6 +410,68 @@ class procedure TZ_JsonObject.Test; js.Free; end; +constructor TZ_JsonObject_List.Create(AutoFreeObj_: Boolean); +begin + inherited Create; + AutoFreeObj := AutoFreeObj_; +end; + +destructor TZ_JsonObject_List.Destroy; +begin + Clear; + inherited Destroy; +end; + +function TZ_JsonObject_List.AddFromText(Text_: TPascalString): TZ_JsonObject; +begin + Result := TZ_JsonObject.Create(nil); + Result.ParseText(Text_); + Add(Result); +end; + +function TZ_JsonObject_List.AddFromStream(stream: TCoreClassStream): TZ_JsonObject; +begin + Result := TZ_JsonObject.Create(nil); + Result.LoadFromStream(stream); + Add(Result); +end; + +procedure TZ_JsonObject_List.Remove(obj: TZ_JsonObject); +begin + if AutoFreeObj then + disposeObject(obj); + inherited Remove(obj); +end; + +procedure TZ_JsonObject_List.Delete(Index: Integer); +begin + if (index >= 0) and (index < Count) then + begin + if AutoFreeObj then + disposeObject(Items[index]); + inherited Delete(index); + end; +end; + +procedure TZ_JsonObject_List.Clear; +var + I: Integer; +begin + if AutoFreeObj then + for I := 0 to Count - 1 do + disposeObject(Items[I]); + inherited Clear; +end; + +procedure TZ_JsonObject_List.Clean; +var + I: Integer; +begin + for I := 0 to Count - 1 do + disposeObject(Items[I]); + inherited Clear; +end; + initialization end. diff --git a/Source/zDefine.inc b/Source/zDefine.inc index 7c959ce4..96eba5da 100644 --- a/Source/zDefine.inc +++ b/Source/zDefine.inc @@ -239,6 +239,9 @@ // Sequence packets default are closed in P2PVM-IO {$UNDEF UsedSequencePacketOnP2PVM} +// CommunicationFramework used QuietMode +{$UNDEF Communication_QuietMode} + {$IFDEF DEBUG} // initialization status prompt {$DEFINE initializationStatus} diff --git a/Source/zExpression.pas b/Source/zExpression.pas index 6b5dcba2..4cf0fcf1 100644 --- a/Source/zExpression.pas +++ b/Source/zExpression.pas @@ -236,6 +236,7 @@ function EvaluateExpressionValue_P(UsedCache: Boolean; SpecialAsciiToken: TListP TextEngClass: TTextParsingClass; TextStyle: TTextStyle; ExpressionText: SystemString; const OnGetValue: TOnDeclValueProc): Variant; {$ENDREGION 'internal define'} +function OpCache: THashObjectList; procedure CleanOpCache(); { prototype: EvaluateExpressionValue } @@ -306,7 +307,7 @@ procedure EvaluateExpressionVectorAndMatrix_test_; implementation var - OpCache: THashObjectList; + OpCache___: THashObjectList = nil; {$REGION 'internal imp'} @@ -1571,6 +1572,8 @@ function __ParseTextExpressionAsSymbol(ParsingEng: TTextParsing; const uName: Sy if ParsingEng.ParsingData.Len < 1 then Exit; + if ParsingEng.TokenCountT([ttTextDecl, ttNumber, ttAscii]) = 0 then + Exit; cPos := 1; BlockIndent := 0; @@ -2723,6 +2726,7 @@ function EvaluateExpressionValue_M(UsedCache: Boolean; SpecialAsciiToken: TListP Op: TOpCode; i: Integer; begin + Op := nil; if UsedCache then begin LockObject(OpCache); @@ -2774,6 +2778,7 @@ function EvaluateExpressionValue_C(UsedCache: Boolean; SpecialAsciiToken: TListP Op: TOpCode; i: Integer; begin + Op := nil; if UsedCache then begin LockObject(OpCache); @@ -2825,6 +2830,7 @@ function EvaluateExpressionValue_P(UsedCache: Boolean; SpecialAsciiToken: TListP Op: TOpCode; i: Integer; begin + Op := nil; if UsedCache then begin LockObject(OpCache); @@ -2872,6 +2878,13 @@ function EvaluateExpressionValue_P(UsedCache: Boolean; SpecialAsciiToken: TListP {$ENDREGION 'internal imp'} +function OpCache: THashObjectList; +begin + if OpCache___ = nil then + OpCache___ := THashObjectList.CustomCreate(True, 1024 * 1024); + Result := OpCache___; +end; + procedure CleanOpCache(); begin LockObject(OpCache); @@ -2931,6 +2944,7 @@ function EvaluateExpressionValue(UsedCache: Boolean; Exit; end; + Op := nil; if (UsedCache) and (const_vl = nil) then begin LockObject(OpCache); @@ -3288,10 +3302,10 @@ procedure EvaluateExpressionVectorAndMatrix_test_; initialization -OpCache := THashObjectList.CustomCreate(True, $FFFF); +OpCache___ := nil; finalization -DisposeObject(OpCache); +DisposeObject(OpCache___); end. diff --git a/Tools/DPRSourceSort/DPRCodeSort.dproj b/Tools/DPRSourceSort/DPRCodeSort.dproj index 1b1a2d72..3cb4c19e 100644 --- a/Tools/DPRSourceSort/DPRCodeSort.dproj +++ b/Tools/DPRSourceSort/DPRCodeSort.dproj @@ -351,7 +351,7 @@ - + true @@ -512,6 +512,11 @@ true + + + true + + DPRCodeSort.exe @@ -595,11 +600,6 @@ true - - - true - - 1