Browse Source

Merge branch 'exilon.master' into jkour.master

jkour 1 year ago
parent
commit
fbb37ea260
9 changed files with 108 additions and 48 deletions
  1. 2 2
      Delphinus.Info.json
  2. 35 3
      Quick.AppService.pas
  3. 0 1
      Quick.AutoMapper.pas
  4. 5 5
      Quick.Console.pas
  5. 5 5
      Quick.HttpClient.pas
  6. 0 1
      Quick.MemoryCache.pas
  7. 38 29
      Quick.YAML.Serializer.pas
  8. 21 1
      QuickLib.inc
  9. 2 1
      README.md

+ 2 - 2
Delphinus.Info.json

@@ -6,9 +6,9 @@
     "license_file": "LICENSE.txt",
     "license_file": "LICENSE.txt",
     "platforms": "Win32;Win64;OSX32;Android;IOSDevice32;IOSDevice64;Linux64",
     "platforms": "Win32;Win64;OSX32;Android;IOSDevice32;IOSDevice64;Linux64",
     "package_compiler_min": 22,
     "package_compiler_min": 22,
-    "package_compiler_max": 35,
+    "package_compiler_max": 36,
     "compiler_min": 22,
     "compiler_min": 22,
-    "compiler_max": 35,
+    "compiler_max": 36,
     "first_version": "1.0",
     "first_version": "1.0",
     "report_url": "",
     "report_url": "",
     "dependencies":
     "dependencies":

+ 35 - 3
Quick.AppService.pas

@@ -96,15 +96,18 @@ type
     fOnStop : TSvcAnonMethod;
     fOnStop : TSvcAnonMethod;
     fOnExecute : TSvcAnonMethod;
     fOnExecute : TSvcAnonMethod;
     fAfterRemove : TSvcRemoveEvent;
     fAfterRemove : TSvcRemoveEvent;
+    fServiceDescription : string;
     procedure ReportSvcStatus(dwCurrentState, dwWin32ExitCode, dwWaitHint: DWORD);
     procedure ReportSvcStatus(dwCurrentState, dwWin32ExitCode, dwWaitHint: DWORD);
     procedure Execute;
     procedure Execute;
     procedure Help;
     procedure Help;
     procedure DoStop;
     procedure DoStop;
+    procedure SetServiceDescription;
   public
   public
     constructor Create;
     constructor Create;
     destructor Destroy; override;
     destructor Destroy; override;
     property ServiceName : string read fServiceName write fServiceName;
     property ServiceName : string read fServiceName write fServiceName;
     property DisplayName : string read fDisplayName write fDisplayName;
     property DisplayName : string read fDisplayName write fDisplayName;
+    property ServiceDescription : string read fServiceDescription write fServiceDescription;
     property LoadOrderGroup : string read fLoadOrderGroup write fLoadOrderGroup;
     property LoadOrderGroup : string read fLoadOrderGroup write fLoadOrderGroup;
     property Dependencies : string read fDependencies write fDependencies;
     property Dependencies : string read fDependencies write fDependencies;
     property DesktopInteraction : Boolean read fDesktopInteraction write fDesktopInteraction;
     property DesktopInteraction : Boolean read fDesktopInteraction write fDesktopInteraction;
@@ -138,6 +141,11 @@ var
 
 
 implementation
 implementation
 
 
+{$IFDEF MSWINDOWS}
+uses
+  Registry;
+{$ENDIF}
+
 procedure ServiceCtrlHandler(Control: DWORD); stdcall;
 procedure ServiceCtrlHandler(Control: DWORD); stdcall;
 begin
 begin
   case Control of
   case Control of
@@ -242,6 +250,27 @@ begin
   SetServiceStatus(StatusHandle,ServiceStatus);
   SetServiceStatus(StatusHandle,ServiceStatus);
 end;
 end;
 
 
+procedure TAppService.SetServiceDescription;
+{$IFDEF MSWINDOWS}
+var
+  reg: TRegistry;
+{$ENDIF}
+begin
+{$IFDEF MSWINDOWS}
+  reg := TRegistry.Create(KEY_READ or KEY_WRITE);
+  try
+    reg.RootKey := HKEY_LOCAL_MACHINE;
+    if reg.OpenKey('\SYSTEM\CurrentControlSet\Services\' + fServiceName, False) then
+    begin
+      reg.WriteString('Description', fServiceDescription);
+      reg.CloseKey;
+    end;
+  finally
+    reg.Free;
+  end;
+{$ENDIF}
+end;
+
 procedure TAppService.Execute;
 procedure TAppService.Execute;
 begin
 begin
   //we have to do something or service will stop
   //we have to do something or service will stop
@@ -320,7 +349,7 @@ begin
   end;
   end;
   //service interacts with desktop
   //service interacts with desktop
   if fDesktopInteraction then servicetype := SERVICE_WIN32_OWN_PROCESS and SERVICE_INTERACTIVE_PROCESS
   if fDesktopInteraction then servicetype := SERVICE_WIN32_OWN_PROCESS and SERVICE_INTERACTIVE_PROCESS
-    else servicetype := SERVICE_WIN32_OWN_PROCESS; 
+    else servicetype := SERVICE_WIN32_OWN_PROCESS;
   //service load order
   //service load order
   if fLoadOrderGroup.IsEmpty then svcloadgroup := nil
   if fLoadOrderGroup.IsEmpty then svcloadgroup := nil
     else svcloadgroup := PChar(fLoadOrderGroup);
     else svcloadgroup := PChar(fLoadOrderGroup);
@@ -333,7 +362,7 @@ begin
   //service user password
   //service user password
   if fUserPass.IsEmpty then svcuserpass := nil
   if fUserPass.IsEmpty then svcuserpass := nil
     else svcuserpass := PChar(fUserPass);
     else svcuserpass := PChar(fUserPass);
-    
+
   fSvHandle := CreateService(fSCMHandle,
   fSvHandle := CreateService(fSCMHandle,
                               PChar(fServiceName),
                               PChar(fServiceName),
                               PChar(fDisplayName),
                               PChar(fDisplayName),
@@ -348,6 +377,9 @@ begin
                               svcusername, //user
                               svcusername, //user
                               svcuserpass); //password
                               svcuserpass); //password
 
 
+  if Length(fServiceDescription) > 0 then
+    SetServiceDescription;
+
   if fSvHandle <> 0 then
   if fSvHandle <> 0 then
   begin
   begin
     if fSilent then Writeln(Format(cInstallMsg,[fServiceName]))
     if fSilent then Writeln(Format(cInstallMsg,[fServiceName]))
@@ -364,7 +396,7 @@ begin
     WriteLn(' [/instance:<service name>]'+#9+'Install service with a custom name');
     WriteLn(' [/instance:<service name>]'+#9+'Install service with a custom name');
   end
   end
   else Writeln(Format('%s [/console] [/install] [/remove] [/h] [/help]',[ExtractFileName(ParamStr(0))]));
   else Writeln(Format('%s [/console] [/install] [/remove] [/h] [/help]',[ExtractFileName(ParamStr(0))]));
-  WriteLn(' [/console]'+#9#9#9+'Force run as a console application (when runned from another service)');
+  WriteLn(' [/console]'+#9#9#9+'Force run as a console application (when run from another service)');
   WriteLn(' [/install]'+#9#9#9+'Install as a service');
   WriteLn(' [/install]'+#9#9#9+'Install as a service');
   WriteLn(' [/remove]'+#9#9#9+'Remove service');
   WriteLn(' [/remove]'+#9#9#9+'Remove service');
   WriteLn(' [/h /help]'+#9#9#9+'This help');
   WriteLn(' [/h /help]'+#9#9#9+'This help');

+ 0 - 1
Quick.AutoMapper.pas

@@ -373,7 +373,6 @@ end;
 
 
 function TAutoMapper<TClass1, TClass2>.Map(aSrcObj: TClass1): TClass2;
 function TAutoMapper<TClass1, TClass2>.Map(aSrcObj: TClass1): TClass2;
 var
 var
-  objvalue : TValue;
   obj : TObject;
   obj : TObject;
 begin
 begin
   obj := aSrcObj as TObject;
   obj := aSrcObj as TObject;

+ 5 - 5
Quick.Console.pas

@@ -1,13 +1,13 @@
 { ***************************************************************************
 { ***************************************************************************
 
 
-  Copyright (c) 2016-2021 Kike Pérez
+  Copyright (c) 2016-2024 Kike Pérez
 
 
   Unit        : Quick.Console
   Unit        : Quick.Console
   Description : Console output with colors and optional file log
   Description : Console output with colors and optional file log
   Author      : Kike Pérez
   Author      : Kike Pérez
   Version     : 1.9
   Version     : 1.9
   Created     : 10/05/2017
   Created     : 10/05/2017
-  Modified    : 05/08/2021
+  Modified    : 20/01/2024
 
 
   This file is part of QuickLib: https://github.com/exilon/QuickLib
   This file is part of QuickLib: https://github.com/exilon/QuickLib
 
 
@@ -172,7 +172,7 @@ type
   procedure coutSL(const cMsg : string; cColor : TConsoleColor);
   procedure coutSL(const cMsg : string; cColor : TConsoleColor);
   procedure cout(const cMsg : string; params : array of const; cEventType : TLogEventType); overload;
   procedure cout(const cMsg : string; params : array of const; cEventType : TLogEventType); overload;
   procedure coutXY(x,y : Integer; const cMsg : string; cEventType : TLogEventType); overload;
   procedure coutXY(x,y : Integer; const cMsg : string; cEventType : TLogEventType); overload;
-  procedure coutXY(x,y : Integer; const cMsg : string; cColor : TConsoleColor); overload;
+  procedure coutXY(x,y : Integer; const cMsg : string; cColor : TConsoleColor; cClearLineBefore : Boolean = False); overload;
   procedure coutXY(x,y : Integer; const cMsg : string; params : array of const; cEventType : TLogEventType); overload;
   procedure coutXY(x,y : Integer; const cMsg : string; params : array of const; cEventType : TLogEventType); overload;
   procedure coutXY(x,y : Integer; const cMsg : string; params : array of const; cColor : TConsoleColor); overload;
   procedure coutXY(x,y : Integer; const cMsg : string; params : array of const; cColor : TConsoleColor); overload;
   procedure coutTL(const cMsg : string; cEventType : TLogEventType); overload;
   procedure coutTL(const cMsg : string; cEventType : TLogEventType); overload;
@@ -480,7 +480,7 @@ begin
   end;
   end;
 end;
 end;
 
 
-procedure coutXY(x,y : Integer; const cMsg : string; cColor : TConsoleColor); overload;
+procedure coutXY(x,y : Integer; const cMsg : string; cColor : TConsoleColor; cClearLineBefore : Boolean = False); overload;
 var
 var
  NewCoord : TCoord;
  NewCoord : TCoord;
  LastCoord : TCoord;
  LastCoord : TCoord;
@@ -496,7 +496,7 @@ begin
   {$ENDIF}
   {$ENDIF}
   NewCoord.X := x;
   NewCoord.X := x;
   NewCoord.Y := y;
   NewCoord.Y := y;
-  ClearLine(Y);
+  if cClearLineBefore then ClearLine(Y);
   SetCursorPos(NewCoord);
   SetCursorPos(NewCoord);
   try
   try
     cout(cMsg,cColor);
     cout(cMsg,cColor);

+ 5 - 5
Quick.HttpClient.pas

@@ -147,9 +147,9 @@ var
   bodycontent : TStringStream;
   bodycontent : TStringStream;
   responsecontent : TStringStream;
   responsecontent : TStringStream;
 begin
 begin
-  bodycontent := TStringStream.Create;
+  bodycontent := TStringStream.Create('',TEncoding.UTF8);
   try
   try
-    responsecontent := TStringStream.Create;
+    responsecontent := TStringStream.Create('',TEncoding.UTF8);
     try
     try
       {$IFDEF DELPHIXE8_UP}
       {$IFDEF DELPHIXE8_UP}
       resp := fHTTPClient.Get(aURL,responsecontent,nil);
       resp := fHTTPClient.Get(aURL,responsecontent,nil);
@@ -185,7 +185,7 @@ begin
   postcontent := TStringStream.Create(Utf8Encode(aInContent));
   postcontent := TStringStream.Create(Utf8Encode(aInContent));
   try
   try
     //postcontent.WriteString(aInContent);
     //postcontent.WriteString(aInContent);
-    responsecontent := TStringStream.Create;
+    responsecontent := TStringStream.Create('',TEncoding.UTF8);
     try
     try
       {$IFDEF DELPHIXE8_UP}
       {$IFDEF DELPHIXE8_UP}
       if aHeaders <> nil then
       if aHeaders <> nil then
@@ -238,7 +238,7 @@ var
   responsecontent : TStringStream;
   responsecontent : TStringStream;
 begin
 begin
   //postcontent.WriteString(aInContent);
   //postcontent.WriteString(aInContent);
-  responsecontent := TStringStream.Create;
+  responsecontent := TStringStream.Create('',TEncoding.UTF8);
   try
   try
     {$IFDEF DELPHIXE8_UP}
     {$IFDEF DELPHIXE8_UP}
     resp := fHTTPClient.Post(aURL,aInContent,responsecontent);
     resp := fHTTPClient.Post(aURL,aInContent,responsecontent);
@@ -290,7 +290,7 @@ begin
   postcontent := TStringStream.Create(Utf8Encode(aInContent));
   postcontent := TStringStream.Create(Utf8Encode(aInContent));
   try
   try
     //postcontent.WriteString(aInContent);
     //postcontent.WriteString(aInContent);
-    responsecontent := TStringStream.Create;
+    responsecontent := TStringStream.Create('',TEncoding.UTF8);
     try
     try
       {$IFDEF DELPHIXE8_UP}
       {$IFDEF DELPHIXE8_UP}
       resp := fHTTPClient.Put(aURL,postcontent,responsecontent);
       resp := fHTTPClient.Put(aURL,postcontent,responsecontent);

+ 0 - 1
Quick.MemoryCache.pas

@@ -500,7 +500,6 @@ end;
 
 
 procedure TMemoryCache<T>.SetValue(const aKey: string; aValue: T; aExpirationMilliseconds : Integer; aExpirationDate : TDateTime);
 procedure TMemoryCache<T>.SetValue(const aKey: string; aValue: T; aExpirationMilliseconds : Integer; aExpirationDate : TDateTime);
 var
 var
-  serialized : string;
   cacheitem : TCacheEntry;
   cacheitem : TCacheEntry;
 begin
 begin
   fLock.BeginWrite;
   fLock.BeginWrite;

+ 38 - 29
Quick.YAML.Serializer.pas

@@ -192,43 +192,52 @@ begin
     TValue.Make(@pArr,aTypeInfo, Result);
     TValue.Make(@pArr,aTypeInfo, Result);
     rDynArray := ctx.GetType(Result.TypeInfo) as TRTTIDynamicArrayType;
     rDynArray := ctx.GetType(Result.TypeInfo) as TRTTIDynamicArrayType;
 
 
-    for i := 0 to aYamlArray.Count - 1 do
-    begin
-      rItemValue := nil;
-      case rType.Kind of
-        tkClass :
-          begin
-            if TYamlPair(aYamlArray.Items[i]).Value is TYamlObject then
+    try
+      for i := 0 to aYamlArray.Count - 1 do
+      begin
+        rItemValue := nil;
+        case rType.Kind of
+          tkClass :
             begin
             begin
-              Yaml := TYamlObject(TYamlPair(aYamlArray.Items[i]).value);
-              propObj := GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i, rDynArray.ElementType).AsObject;
-              if propObj = nil then
-              begin
-                objClass := rType.TypeData.ClassType;
-                rItemValue := DeserializeClass(objClass,yaml);
-              end
-              else
+              if aYamlArray.Items[i] = nil then raise Exception.Create('Value empty!');
+
+              if TYamlPair(aYamlArray.Items[i]).Value is TYamlObject then
               begin
               begin
-                DeserializeObject(propObj,yaml);
+                Yaml := TYamlObject(TYamlPair(aYamlArray.Items[i]).value);
+                propObj := GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i, rDynArray.ElementType).AsObject;
+                if propObj = nil then
+                begin
+                  objClass := rType.TypeData.ClassType;
+                  rItemValue := DeserializeClass(objClass,yaml);
+                end
+                else
+                begin
+                  DeserializeObject(propObj,yaml);
+                end;
               end;
               end;
             end;
             end;
-          end;
-        tkRecord :
+          tkRecord :
+            begin
+              Yaml := TYamlObject(TYamlPair(aYamlArray.Items[i]).value);
+              rItemValue := DeserializeRecord(GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i,
+                                              rDynArray.ElementType),aObject,Yaml);
+            end;
+          tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
+            begin
+              //skip these properties
+            end
+        else
           begin
           begin
-            Yaml := TYamlObject(TYamlPair(aYamlArray.Items[i]).value);
-            rItemValue := DeserializeRecord(GetValue(PPByte(Result.GetReferenceToRawData)^ +rDynArray.ElementType.TypeSize * i,
-                                            rDynArray.ElementType),aObject,Yaml);
+            rItemValue := DeserializeType(aObject,rType.Kind,rType,aYamlArray.Items[i].Value);
           end;
           end;
-        tkMethod, tkPointer, tkClassRef ,tkInterface, tkProcedure :
-          begin
-            //skip these properties
-          end
-      else
-        begin
-          rItemValue := DeserializeType(aObject,rType.Kind,rType,aYamlArray.Items[i].Value);
         end;
         end;
+        if not rItemValue.IsEmpty then Result.SetArrayElement(i,rItemValue);
+      end;
+    except
+      on E : Exception do
+      begin
+        raise Exception.CreateFmt('Array %s item %d error (%s)',[rtype.Name, i, e.Message]);
       end;
       end;
-      if not rItemValue.IsEmpty then Result.SetArrayElement(i,rItemValue);
     end;
     end;
     //aProperty.SetValue(aObject,rValue);
     //aProperty.SetValue(aObject,rValue);
   finally
   finally

+ 21 - 1
QuickLib.inc

@@ -1,7 +1,7 @@
 {
 {
     This file is part of QuickLib: https://github.com/exilon/QuickLib
     This file is part of QuickLib: https://github.com/exilon/QuickLib
 
 
-    QuickLibs. Copyright (C) 2022 Kike Pérez
+    QuickLibs. Copyright (C) 2024 Kike Pérez
       Exilon - https://www.exilon.es
       Exilon - https://www.exilon.es
 
 
      ***************************************************************************
      ***************************************************************************
@@ -169,6 +169,26 @@
         {$define NEXTGEN} //compatibility with older delphis
         {$define NEXTGEN} //compatibility with older delphis
       {$endif}
       {$endif}
     {$endif}
     {$endif}
+    {$if CompilerVersion >= 36.0} //Delphi RX12 Athens
+      {$define DELPHIRX12_UP}
+	    {$define DELPHIATHENS_UP}
+      {$UNDEF DELPHILINUX}
+      {$if defined(POSIX)}
+        {$DEFINE LINUX}
+        {$if defined(CPUARM)}
+          {$if defined(MACOS)}
+          {$ELSE}
+            {$DEFINE ANDROID}
+          {$ENDIF}
+        {$ELSE}
+          {$DEFINE LINUX}
+          {$DEFINE DELPHILINUX}
+        {$ENDIF}
+      {$ENDIF}
+      {$if defined(ANDROID) OR defined(IOS)}
+        {$define NEXTGEN} //compatibility with older delphis
+      {$endif}
+    {$endif}
   {$else}
   {$else}
     //Delphi 5 or older
     //Delphi 5 or older
     {$define DELPHI6OROLDER}
     {$define DELPHI6OROLDER}

+ 2 - 1
README.md

@@ -1,6 +1,6 @@
 ![alt text](docs/QuickLib.png "QuickLib") 
 ![alt text](docs/QuickLib.png "QuickLib") 
 
 
-QuickLib is a delphi/Firemonkey(Windows, Linux, Android, OSX & IOS) and fpc(Windows & Linux) library containing interesting and quick to implement functions, created to simplify application development and crossplatform support and improve productivity. Delphi XE8 - Delphi 11 Alexandria supported.
+QuickLib is a delphi/Firemonkey(Windows, Linux, Android, OSX & IOS) and fpc(Windows & Linux) library containing interesting and quick to implement functions, created to simplify application development and crossplatform support and improve productivity. Delphi XE8 - Delphi 12 Athens supported.
 
 
 ## Give it a star
 ## Give it a star
 Please "star" this project in GitHub! It costs nothing but helps to reference the code.
 Please "star" this project in GitHub! It costs nothing but helps to reference the code.
@@ -74,6 +74,7 @@ If you find this project useful, please consider making a donation.
 
 
 **Updates:**
 **Updates:**
 
 
+* NEW: RAD Studio 12 supported
 * NEW: RAD Studio 11 supported
 * NEW: RAD Studio 11 supported
 * NEW: Condition checks
 * NEW: Condition checks
 * NEW: Commonly used RegEx validations
 * NEW: Commonly used RegEx validations