From 98aa017318e4a82baf34f5091aeb43b833aae934 Mon Sep 17 00:00:00 2001 From: Marc Durdin Date: Fri, 17 Sep 2021 06:37:23 +1000 Subject: [PATCH 1/4] fix(windows): handle edge cases using default language Fixes #5091. If the user has a default language that is not a minimal BCP47 tag, such as `zh-Hans-CN` vs `zh-CN`, or if the default language does not have a mapping in our `TLanguageCodeUtils.TranslateWindowsLanguagesToBCP47` function, then kmshell would crash on install of a keyboard that had no language metadata specified (i.e. neither legacy metadata in .kmx nor modern metadata in .kmp). This crash arose because the elevated instance of kmshell would install a local-machine reference to `zh-CN` (as it back-translated from a LangID), but the current user install would look for `zh-Hans-CN`, read from the Windows registry `HKCU\Control Panel\International\User Profile`. To further complicate matters, it is possible for the current user to have a different default language than the elevated user on the machine. Keyman was assuming that the default language was the same in both cases. This fix passes in the current user's default BCP47 and LangID to the elevated portion of the keyboard install, so we can guarantee that keyboard install which needs to use the default language, actually installs for the current user's actual language code, and not a canonicalized version (or a totally different code in the case of elevation to an alternate admin user account). --- ...an.Configuration.System.TIPMaintenance.pas | 62 +++++++++++++++++-- .../Keyman.Configuration.UI.InstallFile.pas | 4 +- .../kmshell/install/UfrmInstallKeyboard.pas | 3 +- windows/src/desktop/kmshell/main/initprog.pas | 31 +++++++--- .../kmcomapi/com/keyman_implementation.pas | 10 ++- windows/src/engine/kmcomapi/keymanapi_TLB.pas | 25 +++++++- windows/src/engine/kmcomapi/keymancontext.pas | 5 ++ windows/src/engine/kmcomapi/kmcomapi.dproj | 2 +- windows/src/engine/kmcomapi/kmcomapi.ridl | 14 ++++- .../processes/keyboard/kpinstallkeyboard.pas | 26 +++++--- 10 files changed, 156 insertions(+), 26 deletions(-) diff --git a/windows/src/desktop/kmshell/install/Keyman.Configuration.System.TIPMaintenance.pas b/windows/src/desktop/kmshell/install/Keyman.Configuration.System.TIPMaintenance.pas index 5ec46eff14..1fc4168d39 100644 --- a/windows/src/desktop/kmshell/install/Keyman.Configuration.System.TIPMaintenance.pas +++ b/windows/src/desktop/kmshell/install/Keyman.Configuration.System.TIPMaintenance.pas @@ -33,7 +33,11 @@ type class function GetFirstLanguage(Keyboard: IKeymanKeyboardFile): string; overload; /// Get the BCP47 tag for the user's default language - class function GetUserDefaultLanguage: string; static; + class function GetUserDefaultLanguage: string; overload; static; + class procedure GetUserDefaultLanguage(var BCP47: string; var LangID: Integer); overload; static; + + /// Get the -default-lang parameter string for kmshell + class function GetUserDefaultLangParameterString: string; static; private class function GetKeyboardLanguage(const KeyboardID, BCP47Tag: string): IKeymanKeyboardLanguageInstalled; static; @@ -180,7 +184,7 @@ begin if RegistrationRequired then begin // This calls back into TTIPMaintenance.RegisterTip - if WaitForElevatedConfiguration(0, '-register-tip '+IntToHex(LangID,4)+' "'+KeyboardID+'" "'+lang.BCP47Code+'"') <> 0 then + if WaitForElevatedConfiguration(0, '-register-tip '+IntToHex(LangID,4)+' "'+KeyboardID+'" "'+lang.BCP47Code+'" '+GetUserDefaultLangParameterString) <> 0 then Exit(False); end; @@ -232,16 +236,61 @@ begin Result := False; end; +class function TTIPMaintenance.GetUserDefaultLangParameterString: string; +var + LangID: Integer; + BCP47: string; +begin + GetUserDefaultLanguage(BCP47, LangID); + Result := '-default-lang '+BCP47+' '+IntToHex(LangID,4); +end; + class function TTIPMaintenance.GetUserDefaultLanguage: string; +var + LangID: Integer; +begin + GetUserDefaultLanguage(Result, LangID); +end; + +class procedure TTIPMaintenance.GetUserDefaultLanguage(var BCP47: string; var LangID: Integer); var r: TRegistry; tags: TStringList; v: string; keys: TStringList; key: string; + + function GetLangIDFromValueName: Integer; + var + values: TStringList; + v: string; + begin + // In HKCU\Control Panel\International\User Profile\, already opened + // by the caller, look for a value name such as '0453:00000453' or + // '0804:{81D4E9C9-1D3B-41BC-9E6C-4B40BF79E35E}{FA550B04-5AD7-411F-A5AC-CA038EC515D7}' + // and grab the LangID from there. + values := TStringList.Create; + try + r.GetValueNames(values); + for v in values do + begin + if Copy(v, 5, 1) = ':' then + begin + Result := StrToIntDef('$' + Copy(v, 1, 4), 0); + if Result > 0 then + Exit; + end; + end; + finally + values.Free; + end; + Result := 0; + end; + begin // Fallback result - Result := TLanguageCodeUtils.TranslateWindowsLanguagesToBCP47(HKLToLanguageID(GetDefaultHKL)); + LangID := HKLToLanguageID(GetDefaultHKL); + BCP47 := TLanguageCodeUtils.TranslateWindowsLanguagesToBCP47(LangID); // For Win10, look in CPL/International/UserProfile r := TRegistry.Create; @@ -260,7 +309,8 @@ begin if r.OpenKeyReadOnly('\' + SRegKey_ControlPanelInternationalUserProfile + '\' + key) and r.ValueExists(v) then begin - Result := key; + BCP47 := key; + LangID := GetLangIDFromValueName; Break; end; end; @@ -276,7 +326,9 @@ begin r.ReadMultiString(SRegValue_CPIUP_Languages, tags); if tags.Count > 0 then begin - Result := tags[0].Trim; + BCP47 := tags[0].Trim; + if r.OpenKeyReadOnly('\' + SRegKey_ControlPanelInternationalUserProfile + '\' + tags[0].Trim) then + LangID := GetLangIDFromValueName; end; finally tags.Free; diff --git a/windows/src/desktop/kmshell/install/Keyman.Configuration.UI.InstallFile.pas b/windows/src/desktop/kmshell/install/Keyman.Configuration.UI.InstallFile.pas index 5b0a52dc5f..5c7a8ee1fb 100644 --- a/windows/src/desktop/kmshell/install/Keyman.Configuration.UI.InstallFile.pas +++ b/windows/src/desktop/kmshell/install/Keyman.Configuration.UI.InstallFile.pas @@ -169,12 +169,12 @@ begin if Length(FilenameBCP47) > 1 then RegisterKeyboardPackageLanguage(FPackage, FilenameBCP47[1]) else RegisterKeyboardPackageLanguage(FPackage, ''); - // The keyboard will be installed for current user as a separate step + // The keyboard will be installed for current user as a separate step end else begin FKeyboard := (kmcom.Keyboards as IKeymanKeyboardsInstalled2).Install2(FileName, True); - if Length(FilenameBCP47) > 1 + if (Length(FilenameBCP47) > 1) and (Trim(FilenameBCP47[1]) <> '') then BCP47Tag := FilenameBCP47[1] else BCP47Tag := TTIPMaintenance.GetFirstLanguage(FKeyboard); TTIPMaintenance.DoRegister(FKeyboard.ID, BCP47Tag); diff --git a/windows/src/desktop/kmshell/install/UfrmInstallKeyboard.pas b/windows/src/desktop/kmshell/install/UfrmInstallKeyboard.pas index 6250db1030..8e780442e6 100644 --- a/windows/src/desktop/kmshell/install/UfrmInstallKeyboard.pas +++ b/windows/src/desktop/kmshell/install/UfrmInstallKeyboard.pas @@ -303,7 +303,8 @@ begin Manager.UpdateProgress('Installing Keyboard', 0, 0); t := TTempFileManager.Get('.log'); try - if WaitForElevatedConfiguration(GetForegroundWindow, '-log "'+t.Name+'" -s -i "'+FInstallFile+'='+BCP47Tag+'" -nowelcome') = 0 then + if WaitForElevatedConfiguration(GetForegroundWindow, '-log "'+t.Name+'" -s -i "'+FInstallFile+'='+BCP47Tag+'"'+ + ' -nowelcome '+TTIPMaintenance.GetUserDefaultLangParameterString) = 0 then begin // install the keyboard tip if not InstallTipForKeyboard(BCP47Tag) then diff --git a/windows/src/desktop/kmshell/main/initprog.pas b/windows/src/desktop/kmshell/main/initprog.pas index c3f8f1c990..19397c09ce 100644 --- a/windows/src/desktop/kmshell/main/initprog.pas +++ b/windows/src/desktop/kmshell/main/initprog.pas @@ -195,7 +195,8 @@ begin end; function Init(var FMode: TKMShellMode; KeyboardFileNames: TStrings; var FSilent, FForce, FNoWelcome: Boolean; - var FLogFile, FQuery: string; var FDisablePackages, FDefaultUILanguage: string; var FStartWithConfiguration: Boolean; var FParentWindow: THandle): Boolean; + var FLogFile, FQuery: string; var FDisablePackages, FDefaultUILanguage: string; var FStartWithConfiguration: Boolean; + var FParentWindow: THandle; var FDefaultBCP47: string; var FDefaultLangID: Integer): Boolean; var s: string; i: Integer; @@ -269,7 +270,13 @@ begin FQuery := Trim(FQuery); end else if Copy(s, 1, 3) = '-ur' then UnRegCRC := StrToIntDef('$'+Copy(s, 4, 8), 0) - + else if s = '-default-lang' then + begin + Inc(i); + FDefaultBCP47 := ParamStr(i); + Inc(i); + FDefaultLangID := StrToIntDef('$'+ParamStr(i), 0); + end // Controls from Keyman Engine else if s = '-showhint' then FMode := fmShowHint else if s = '-parentwindow' then @@ -301,7 +308,8 @@ begin end; procedure RunKMCOM(FMode: TKMShellMode; KeyboardFileNames: TStrings; FSilent, FForce, FNoWelcome: Boolean; - FLogFile, FQuery: string; FDisablePackages, FDefaultUILanguage: string; FStartWithConfiguration: Boolean; FParentWindow: THandle); forward; + FLogFile, FQuery: string; FDisablePackages, FDefaultUILanguage: string; FStartWithConfiguration: Boolean; FParentWindow: THandle; + const FDefaultBCP47: string; FDefaultLangID: Integer); forward; procedure Run; var @@ -312,7 +320,8 @@ var FForce: Boolean; FParentWindow: THandle; FLogFile: string; - FDisablePackages, FDefaultUILanguage: string; + FDefaultLangID: Integer; + FDefaultBCP47, FDisablePackages, FDefaultUILanguage: string; FStartWithConfiguration: Boolean; begin RegisterControlClasses; @@ -320,7 +329,7 @@ begin KeyboardFileNames := TStringList.Create; try FParentWindow := 0; - if not Init(FMode, KeyboardFileNames, FSilent, FForce, FNoWelcome, FLogFile, FQuery, FDisablePackages, FDefaultUILanguage, FStartWithConfiguration, FParentWindow) then + if not Init(FMode, KeyboardFileNames, FSilent, FForce, FNoWelcome, FLogFile, FQuery, FDisablePackages, FDefaultUILanguage, FStartWithConfiguration, FParentWindow, FDefaultBCP47, FDefaultLangID) then begin //TODO: TUtilExecute.Shell(PChar('hh.exe mk:@MSITStore:'+ExtractFilePath(KMShellExe)+'keyman.chm::/context/keyman_usage.html'), SW_SHOWNORMAL); Exit; @@ -328,7 +337,7 @@ begin if not LoadKMCOM then Exit; try - RunKMCOM(FMode, KeyboardFileNames, FSilent, FForce, FNoWelcome, FLogFile, FQuery, FDisablePackages, FDefaultUILanguage, FStartWithConfiguration, FParentWindow); + RunKMCOM(FMode, KeyboardFileNames, FSilent, FForce, FNoWelcome, FLogFile, FQuery, FDisablePackages, FDefaultUILanguage, FStartWithConfiguration, FParentWindow, FDefaultBCP47, FDefaultLangID); finally kmcom := nil; end; @@ -366,8 +375,10 @@ begin end; procedure RunKMCOM(FMode: TKMShellMode; KeyboardFileNames: TStrings; FSilent, FForce, FNoWelcome: Boolean; - FLogFile, FQuery: string; FDisablePackages, FDefaultUILanguage: string; FStartWithConfiguration: Boolean; FParentWindow: THandle); + FLogFile, FQuery: string; FDisablePackages, FDefaultUILanguage: string; FStartWithConfiguration: Boolean; + FParentWindow: THandle; const FDefaultBCP47: string; FDefaultLangID: Integer); var + kdl: IKeymanDefaultLanguage; FIcon: string; FMutex: TKeymanMutex; // I2720 function FirstKeyboardFileName: WideString; @@ -440,6 +451,12 @@ begin if FileExists(FIcon) then Application.Icon.LoadFromFile(FIcon); + if (FDefaultBCP47 <> '') or (FDefaultLangID <> 0) then + begin + if Supports(kmcom, IKeymanDefaultLanguage, kdl) then + kdl.SetDefaultLanguage(FDefaultBCP47, FDefaultLangID); + end; + case FMode of fmKeyboardWelcome: // I2569 ShowKeyboardWelcome(FirstKeyboardFileName); diff --git a/windows/src/engine/kmcomapi/com/keyman_implementation.pas b/windows/src/engine/kmcomapi/com/keyman_implementation.pas index 74766bad76..fe0c117fa5 100644 --- a/windows/src/engine/kmcomapi/com/keyman_implementation.pas +++ b/windows/src/engine/kmcomapi/com/keyman_implementation.pas @@ -48,7 +48,7 @@ uses keymansysteminfo; type - TKeyman = class(TAutoObject, IKeyman, IIntKeyman, IKeymanBCP47Canonicalization) + TKeyman = class(TAutoObject, IKeyman, IIntKeyman, IKeymanBCP47Canonicalization, IKeymanDefaultLanguage) private FInitialized: Boolean; FContext: TKeymanContext; @@ -84,6 +84,8 @@ type // Reimplement as a special case for this interface function SerializeXML(Flags: TOleEnum; const ImagePath: WideString; out References: OleVariant): WideString; safecall; + { IKeymanDefaultLanguage } + procedure SetDefaultLanguage(const BCP47: WideString; LangID: Integer); safecall; public procedure Initialize; override; destructor Destroy; override; @@ -290,6 +292,12 @@ begin end; end; +procedure TKeyman.SetDefaultLanguage(const BCP47: WideString; LangID: Integer); +begin + FContext.DefaultBCP47 := BCP47; + FContext.DefaultLangID := LangID; +end; + procedure TKeyman.Set_AutoApply(Value: WordBool); begin if not FInitialized then raise Exception.Create(SErrorUninitialised); diff --git a/windows/src/engine/kmcomapi/keymanapi_TLB.pas b/windows/src/engine/kmcomapi/keymanapi_TLB.pas index 56ec2f90e7..3ceb5b15cd 100644 --- a/windows/src/engine/kmcomapi/keymanapi_TLB.pas +++ b/windows/src/engine/kmcomapi/keymanapi_TLB.pas @@ -12,7 +12,7 @@ unit keymanapi_TLB; // ************************************************************************ // // $Rev: 52393 $ -// File generated on 1/02/2021 8:52:41 AM from Type Library described below. +// File generated on 16/09/2021 6:54:44 PM from Type Library described below. // ************************************************************************ // // Type Lib: C:\Projects\keyman\app\windows\src\engine\kmcomapi\kmcomapi (1) @@ -93,6 +93,7 @@ const IID_IKeymanKeyboardLanguageInstalled2: TGUID = '{414C26E6-BFAC-4A70-9EA1-E525BA9BBA7E}'; IID_IKeymanKeyboardLanguagesInstalled2: TGUID = '{628FF2E6-B490-462E-8FC7-7AE53B9D392C}'; CLASS_Keyman: TGUID = '{CF46549D-4D2D-4679-A2E1-23A815F172F8}'; + IID_IKeymanDefaultLanguage: TGUID = '{77BAB934-B7DF-4304-AFA6-B8F6BEC16516}'; // *********************************************************************// // Declaration of Enumerations defined in Type Library @@ -257,6 +258,8 @@ type IKeymanKeyboardLanguageInstalled2Disp = dispinterface; IKeymanKeyboardLanguagesInstalled2 = interface; IKeymanKeyboardLanguagesInstalled2Disp = dispinterface; + IKeymanDefaultLanguage = interface; + IKeymanDefaultLanguageDisp = dispinterface; // *********************************************************************// // Declaration of CoClasses defined in Type Library @@ -1765,6 +1768,26 @@ type out References: OleVariant): WideString; dispid 401; end; +// *********************************************************************// +// Interface: IKeymanDefaultLanguage +// Flags: (4416) Dual OleAutomation Dispatchable +// GUID: {77BAB934-B7DF-4304-AFA6-B8F6BEC16516} +// *********************************************************************// + IKeymanDefaultLanguage = interface(IDispatch) + ['{77BAB934-B7DF-4304-AFA6-B8F6BEC16516}'] + procedure SetDefaultLanguage(const DefaultBCP47: WideString; DefaultLangID: Integer); safecall; + end; + +// *********************************************************************// +// DispIntf: IKeymanDefaultLanguageDisp +// Flags: (4416) Dual OleAutomation Dispatchable +// GUID: {77BAB934-B7DF-4304-AFA6-B8F6BEC16516} +// *********************************************************************// + IKeymanDefaultLanguageDisp = dispinterface + ['{77BAB934-B7DF-4304-AFA6-B8F6BEC16516}'] + procedure SetDefaultLanguage(const DefaultBCP47: WideString; DefaultLangID: Integer); dispid 201; + end; + // *********************************************************************// // The Class CoKeyman provides a Create and CreateRemote method to // create instances of the default interface IKeyman exposed by diff --git a/windows/src/engine/kmcomapi/keymancontext.pas b/windows/src/engine/kmcomapi/keymancontext.pas index 085810eb2d..fdd3e76567 100644 --- a/windows/src/engine/kmcomapi/keymancontext.pas +++ b/windows/src/engine/kmcomapi/keymancontext.pas @@ -32,6 +32,8 @@ type private FKeyman: TObject; FController: TKeymanController; + FDefaultBCP47: string; + FDefaultLangID: Integer; function GetErrors: IIntKeymanErrors; function GetKeyboards: IIntKeymanKeyboardsInstalled; function GetPackages: IIntKeymanPackagesInstalled; @@ -50,6 +52,9 @@ type property SystemInfo: IIntKeymanSystemInfo read GetSystemInfo; property Control: IIntKeymanControl read GetControl; property Controller: TKeymanController read FController; + + property DefaultBCP47: string read FDefaultBCP47 write FDefaultBCP47; + property DefaultLangID: Integer read FDefaultLangID write FDefaultLangID; end; implementation diff --git a/windows/src/engine/kmcomapi/kmcomapi.dproj b/windows/src/engine/kmcomapi/kmcomapi.dproj index b11ff10ddc..f35aff8706 100644 --- a/windows/src/engine/kmcomapi/kmcomapi.dproj +++ b/windows/src/engine/kmcomapi/kmcomapi.dproj @@ -124,7 +124,7 @@ false false - ..\..\desktop\kmshell\kmshell.exe + ..\..\desktop\kmshell\bin\win32\debug\kmshell.exe CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) -c false diff --git a/windows/src/engine/kmcomapi/kmcomapi.ridl b/windows/src/engine/kmcomapi/kmcomapi.ridl index bdee680f06..ac20310a87 100644 --- a/windows/src/engine/kmcomapi/kmcomapi.ridl +++ b/windows/src/engine/kmcomapi/kmcomapi.ridl @@ -6,7 +6,7 @@ // However, when applying changes via the Editor this file will be regenerated // and comments or formatting changes will be lost. // ************************************************************************ // -// File generated on 1/02/2021 8:52:42 AM (- $Rev: 12980 $, 9519671). +// File generated on 16/09/2021 6:54:45 PM (- $Rev: 12980 $, 32940875). [ uuid(F16E2A9A-DA46-4EA3-BFF3-BA46B480C961), @@ -66,6 +66,7 @@ library keymanapi interface IKeymanKeyboardLanguageInstalled2; interface IKeymanKeyboardLanguagesInstalled2; interface IKeymanBCP47Canonicalization; + interface IKeymanDefaultLanguage; [ @@ -1019,6 +1020,17 @@ library keymanapi HRESULT _stdcall GetFullTagList([in] BSTR Tag, [out, retval] VARIANT* Result); }; + [ + uuid(77BAB934-B7DF-4304-AFA6-B8F6BEC16516), + dual, + oleautomation + ] + interface IKeymanDefaultLanguage: IDispatch + { + [id(0x000000C9)] + HRESULT _stdcall SetDefaultLanguage([in] BSTR DefaultBCP47, [in] long DefaultLangID); + }; + [ uuid(CF46549D-4D2D-4679-A2E1-23A815F172F8), version(10.0) diff --git a/windows/src/engine/kmcomapi/processes/keyboard/kpinstallkeyboard.pas b/windows/src/engine/kmcomapi/processes/keyboard/kpinstallkeyboard.pas index e91cab0eeb..147bb9aef6 100644 --- a/windows/src/engine/kmcomapi/processes/keyboard/kpinstallkeyboard.pas +++ b/windows/src/engine/kmcomapi/processes/keyboard/kpinstallkeyboard.pas @@ -326,6 +326,7 @@ var kpil: TKPInstallKeyboardLanguage; ml: TMitigateWin10_1803.TMitigatedLanguage; KeyboardName: string; + FDefaultBCP47: string; type TWSLCallback = reference to procedure(r: TRegistryErrorControlled); @@ -366,7 +367,11 @@ begin ErrorFmt(KMN_E_Install_InvalidFile, VarArrayOf([ExtractFileName(FileName), E.Message])); end; - FDefaultHKL := GetDefaultHKL; + FDefaultHKL := Context.DefaultLangID; + if FDefaultHKL = 0 then + FDefaultHKL := GetDefaultHKL; + + FDefaultBCP47 := Context.DefaultBCP47; KeyboardID := GetShortKeyboardName(FileName); @@ -456,12 +461,6 @@ begin begin FLanguages := GetLanguageCodesFromKeyboard(ki); - // - // Final fallback is to install against default language for system // I4607 - // - if Length(FLanguages) = 0 then - AddLanguage(HKLToLanguageID(FDefaultHKL)); - for i := 0 to High(Flanguages) do if TMitigateWin10_1803.IsMitigationRequired(FLanguages[i], ml) then begin @@ -483,6 +482,19 @@ begin i: Integer; BCP47Tag: string; begin + if Length(FLanguages) = 0 then + begin + // + // Final fallback is to install against default language for system + // + kpil := TKPInstallKeyboardLanguage.Create(Context); + try + kpil.RegisterTip(KeyboardID, FDefaultBCP47, KeyboardName, FDefaultHKL, FIconFileName, ''); //TODO: language name + finally + kpil.Free; + end; + r.WriteString(FDefaultBCP47, ''); // TODO: language name + end; for i := 0 to High(FLanguages) do begin BCP47Tag := TLanguageCodeUtils.TranslateWindowsLanguagesToBCP47(FLanguages[i]); From 1aac15fec805a57a18e65d0711984a52ab5a7df0 Mon Sep 17 00:00:00 2001 From: Marc Durdin Date: Fri, 17 Sep 2021 10:30:41 +1000 Subject: [PATCH 2/4] chore(windows): Apply suggestion Co-authored-by: Darcy Wong --- .../install/Keyman.Configuration.System.TIPMaintenance.pas | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/windows/src/desktop/kmshell/install/Keyman.Configuration.System.TIPMaintenance.pas b/windows/src/desktop/kmshell/install/Keyman.Configuration.System.TIPMaintenance.pas index 1fc4168d39..c1289679e8 100644 --- a/windows/src/desktop/kmshell/install/Keyman.Configuration.System.TIPMaintenance.pas +++ b/windows/src/desktop/kmshell/install/Keyman.Configuration.System.TIPMaintenance.pas @@ -327,7 +327,7 @@ begin if tags.Count > 0 then begin BCP47 := tags[0].Trim; - if r.OpenKeyReadOnly('\' + SRegKey_ControlPanelInternationalUserProfile + '\' + tags[0].Trim) then + if r.OpenKeyReadOnly('\' + SRegKey_ControlPanelInternationalUserProfile + '\' + BCP47) then LangID := GetLangIDFromValueName; end; finally From 66ddceadda03072e5ea3add3cc6684a797dd3404 Mon Sep 17 00:00:00 2001 From: Marc Durdin Date: Wed, 29 Sep 2021 11:34:16 +1000 Subject: [PATCH 3/4] fix(windows): change canonicalization strategy for Windows 7 On Windows 7, we will no longer attempt to canonicalize BCP 47 tags in the same was as on later OS versions, because there appear to be some significant differences in how they work, for example, zh-CN is not converted to zh-Hans-CN on Windows 7, whereas it is on Windows 10. This commit also refreshes the `KLog` unit which is useful for debugging these types of scenarios. --- ...an.Configuration.System.TIPMaintenance.pas | 300 +++++++++++------- .../kmshell/install/UfrmInstallKeyboard.pas | 46 +-- ...yman.System.CanonicalLanguageCodeUtils.pas | 7 + windows/src/global/delphi/general/klog.pas | 102 +++--- 4 files changed, 278 insertions(+), 177 deletions(-) diff --git a/windows/src/desktop/kmshell/install/Keyman.Configuration.System.TIPMaintenance.pas b/windows/src/desktop/kmshell/install/Keyman.Configuration.System.TIPMaintenance.pas index c1289679e8..b91bc535e5 100644 --- a/windows/src/desktop/kmshell/install/Keyman.Configuration.System.TIPMaintenance.pas +++ b/windows/src/desktop/kmshell/install/Keyman.Configuration.System.TIPMaintenance.pas @@ -53,6 +53,7 @@ uses Keyman.System.KeymanSentryClient, Keyman.System.LanguageCodeUtils, + KLog, BCP47Tag, glossary, kmint, @@ -68,9 +69,14 @@ var i: Integer; begin Result := True; - for i := 0 to Packages.Count - 1 do - // We'll attempt every package but return failure if any of them have issues - Result := InstallTipForPackage(Packages.Names[i], Packages.ValueFromIndex[i]) and Result; + KL.MethodEnter(nil, 'TTIPMaintenance.InstallTipsForPackages', [Packages.Text]); + try + for i := 0 to Packages.Count - 1 do + // We'll attempt every package but return failure if any of them have issues + Result := InstallTipForPackage(Packages.Names[i], Packages.ValueFromIndex[i]) and Result; + finally + KL.MethodExit(nil, 'TTIPMaintenance.InstallTipsForPackages', [Result]); + end; end; class function TTIPMaintenance.InstallTipForPackage(const PackageFilename, BCP47Tag: string): Boolean; @@ -79,23 +85,29 @@ var n: Integer; pack: IKeymanPackageInstalled; begin - // This function has a known limitation: if a package contains more than one keyboard, - // then the BCP47 association will be made only for the first keyboard. This is - // considered an acceptable limitation at this time + Result := False; + KL.MethodEnter(nil, 'TTIPMaintenance.InstallTipForPackage', [PackageFilename, BCP47Tag]); + try + // This function has a known limitation: if a package contains more than one keyboard, + // then the BCP47 association will be made only for the first keyboard. This is + // considered an acceptable limitation at this time - PackageID := ChangeFileExt(ExtractFileName(PackageFilename), ''); - n := kmcom.Packages.IndexOf(PackageID); - if n < 0 then - Exit(False); + PackageID := ChangeFileExt(ExtractFileName(PackageFilename), ''); + n := kmcom.Packages.IndexOf(PackageID); + if n < 0 then + Exit(False); - pack := kmcom.Packages[n]; + pack := kmcom.Packages[n]; - if pack.Keyboards.Count = 0 then - Exit(False); + if pack.Keyboards.Count = 0 then + Exit(False); - if BCP47Tag = '' - then Result := DoInstall(pack.Keyboards[0].ID, GetFirstLanguage(pack.Keyboards[0] as IKeymanKeyboardInstalled)) - else Result := DoInstall(pack.Keyboards[0].ID, BCP47Tag); + if BCP47Tag = '' + then Result := DoInstall(pack.Keyboards[0].ID, GetFirstLanguage(pack.Keyboards[0] as IKeymanKeyboardInstalled)) + else Result := DoInstall(pack.Keyboards[0].ID, BCP47Tag); + finally + KL.MethodExit(nil, 'TTIPMaintenance.InstallTipForPackage', [Result]); + end; end; procedure AddDiagnosticBreadcrumb(const KeyboardID: string); @@ -125,18 +137,19 @@ class function TTIPMaintenance.InstallTip(LangID: Integer; const KeyboardID, BCP var lang: IKeymanKeyboardLanguageInstalled; begin - lang := GetKeyboardLanguage(KeyboardID, BCP47Tag); - if lang = nil then - Exit(False); - - // TODO: can this fail? + Result := False; + KL.MethodEnter(nil, 'TTIPMaintenance.InstallTip', [LangID, KeyboardID, BCP47Tag, KeyboardToRemove]); try + lang := GetKeyboardLanguage(KeyboardID, BCP47Tag); + if lang = nil then + Exit(False); + + // TODO: can this fail? (lang as IKeymanKeyboardLanguageInstalled2).InstallTip(LangID, KeyboardToRemove); - except - AddDiagnosticBreadcrumb(KeyboardID); - raise; + Result := True; + finally + KL.MethodExit(nil, 'TTIPMaintenance.InstallTip', [Result]); end; - Result := True; end; class function TTIPMaintenance.RegisterTip(LangID: Integer; const KeyboardID, @@ -144,13 +157,19 @@ class function TTIPMaintenance.RegisterTip(LangID: Integer; const KeyboardID, var lang: IKeymanKeyboardLanguageInstalled; begin - lang := GetKeyboardLanguage(KeyboardID, BCP47Tag); - if lang = nil then - Exit(False); + Result := False; + KL.MethodEnter(nil, 'TTIPMaintenance.RegisterTip', [KeyboardID, BCP47Tag]); + try + lang := GetKeyboardLanguage(KeyboardID, BCP47Tag); + if lang = nil then + Exit(False); - // TODO: can this fail? + // TODO: can this fail? (lang as IKeymanKeyboardLanguageInstalled2).RegisterTip(LangID); - Result := True; + Result := True; + finally + KL.MethodExit(nil, 'TTIPMaintenance.RegisterTip', [Result]); + end; end; class function TTIPMaintenance.DoInstall(const KeyboardID, @@ -161,44 +180,59 @@ var TemporaryKeyboardID: WideString; LangID: Integer; childExitCode: Cardinal; + CanonicalTag, Command: string; begin - lang := GetKeyboardLanguage(KeyboardID, (kmcom as IKeymanBCP47Canonicalization).GetCanonicalTag(BCP47Tag)); - if lang = nil then - // The keyboard was not found - Exit(False); - - if lang.IsInstalled then - // After canonicalization, we may find the language is already installed - Exit(True); - - TemporaryKeyboardID := ''; - LangID := 0; - RegistrationRequired := False; - - if not (lang as IKeymanKeyboardLanguageInstalled2).FindInstallationLangID(LangID, TemporaryKeyboardID, RegistrationRequired, kifInstallTransientLanguage) then - begin - // We were not able to find a TIP, perhaps all transient TIPs have been used - Exit(False); - end; - - if RegistrationRequired then - begin - // This calls back into TTIPMaintenance.RegisterTip - if WaitForElevatedConfiguration(0, '-register-tip '+IntToHex(LangID,4)+' "'+KeyboardID+'" "'+lang.BCP47Code+'" '+GetUserDefaultLangParameterString) <> 0 then + Result := False; + KL.MethodEnter(nil, 'TTIPMaintenance.DoInstall', [KeyboardID, BCP47Tag]); + try + CanonicalTag := (kmcom as IKeymanBCP47Canonicalization).GetCanonicalTag(BCP47Tag); + lang := GetKeyboardLanguage(KeyboardID, CanonicalTag); + KL.Log('BCP47Tag = %s, CanonicalTag = %s, lang.BCP47Code = %s', [BCP47Tag, CanonicalTag, lang.BCP47Code]); + if lang = nil then + // The keyboard was not found Exit(False); - end; - // This calls back into TTIPMaintenance.InstallTip - if not TUtilExecute.WaitForProcess('"'+ParamStr(0)+'" -install-tip '+IntToHex(LangID,4)+' "'+KeyboardID+'" "'+lang.BCP47Code+'" "'+TemporaryKeyboardID+'"', - GetCurrentDir, childExitCode) or - (childExitCode <> 0) then - begin + if lang.IsInstalled then + // After canonicalization, we may find the language is already installed + Exit(True); + + TemporaryKeyboardID := ''; + LangID := 0; + RegistrationRequired := False; + + if not (lang as IKeymanKeyboardLanguageInstalled2).FindInstallationLangID(LangID, TemporaryKeyboardID, RegistrationRequired, kifInstallTransientLanguage) then + begin + KL.Log('Failed to find installation langid'); + // We were not able to find a TIP, perhaps all transient TIPs have been used + Exit(False); + end; + + KL.Log('LangID=%x, TemporaryKeyboardID=%s, RegistrationRequired=%s', [LangID, TemporaryKeyboardID, BoolToStr(RegistrationRequired, True)]); + + if RegistrationRequired then + begin + Command := '-register-tip '+IntToHex(LangID,4)+' "'+KeyboardID+'" "'+lang.BCP47Code+'" '+GetUserDefaultLangParameterString; + KL.Log('Calling elevated kmshell %s', [Command]); + // This calls back into TTIPMaintenance.RegisterTip + if WaitForElevatedConfiguration(0, Command) <> 0 then + Exit(False); + end; + + Command := '-install-tip '+IntToHex(LangID,4)+' "'+KeyboardID+'" "'+lang.BCP47Code+'" "'+TemporaryKeyboardID+'"'; + KL.Log('Calling user kmshell %s', [Command]); + // This calls back into TTIPMaintenance.InstallTip + if not TUtilExecute.WaitForProcess('"'+ParamStr(0)+'" '+Command, GetCurrentDir, childExitCode) or + (childExitCode <> 0) then + begin + kmcom.Refresh; + Exit(False); + end; + kmcom.Refresh; - Exit(False); + Result := True; + finally + KL.MethodExit(nil, 'TTIPMaintenance.DoInstall', [Result]); end; - - kmcom.Refresh; - Result := True; end; function GetDefaultHKL: HKL; @@ -215,25 +249,31 @@ var TemporaryKeyboardID: WideString; RegistrationRequired: WordBool; begin - lang := GetKeyboardLanguage(KeyboardID, (kmcom as IKeymanBCP47Canonicalization).GetCanonicalTag(BCP47Tag)); - if lang = nil then - // The keyboard was not found - Exit(False); + Result := False; + KL.MethodEnter(nil, 'TTIPMaintenance.DoRegister', [KeyboardID, BCP47Tag]); + try + lang := GetKeyboardLanguage(KeyboardID, (kmcom as IKeymanBCP47Canonicalization).GetCanonicalTag(BCP47Tag)); + if lang = nil then + // The keyboard was not found + Exit(False); - if lang.IsInstalled or (lang as IKeymanKeyboardLanguageInstalled2).IsRegistered then - // After canonicalization, we may find the language is already installed - Exit(True); + if lang.IsInstalled or (lang as IKeymanKeyboardLanguageInstalled2).IsRegistered then + // After canonicalization, we may find the language is already installed + Exit(True); - TemporaryKeyboardID := ''; - LangID := 0; - RegistrationRequired := False; + TemporaryKeyboardID := ''; + LangID := 0; + RegistrationRequired := False; - if (lang as IKeymanKeyboardLanguageInstalled2).FindInstallationLangID(LangID, TemporaryKeyboardID, RegistrationRequired, 0) then - begin - Result := not RegistrationRequired or RegisterTip(LangID, KeyboardID, lang.BCP47Code); - end - else - Result := False; + if (lang as IKeymanKeyboardLanguageInstalled2).FindInstallationLangID(LangID, TemporaryKeyboardID, RegistrationRequired, 0) then + begin + Result := not RegistrationRequired or RegisterTip(LangID, KeyboardID, lang.BCP47Code); + end + else + Result := False; + finally + KL.MethodExit(nil, 'TTIPMaintenance.DoRegister', [Result]); + end; end; class function TTIPMaintenance.GetUserDefaultLangParameterString: string; @@ -241,15 +281,25 @@ var LangID: Integer; BCP47: string; begin - GetUserDefaultLanguage(BCP47, LangID); - Result := '-default-lang '+BCP47+' '+IntToHex(LangID,4); + KL.MethodEnter(nil, 'TTIPMaintenance.GetUserDefaultLangParameterString', []); + try + GetUserDefaultLanguage(BCP47, LangID); + Result := '-default-lang '+BCP47+' '+IntToHex(LangID,4); + finally + KL.MethodExit(nil, 'TTIPMaintenance.GetUserDefaultLangParameterString', [Result]); + end; end; class function TTIPMaintenance.GetUserDefaultLanguage: string; var LangID: Integer; begin - GetUserDefaultLanguage(Result, LangID); + KL.MethodEnter(nil, 'TTIPMaintenance.GetUserDefaultLanguage', []); + try + GetUserDefaultLanguage(Result, LangID); + finally + KL.MethodExit(nil, 'TTIPMaintenance.GetUserDefaultLanguage', [Result]); + end; end; class procedure TTIPMaintenance.GetUserDefaultLanguage(var BCP47: string; var LangID: Integer); @@ -288,54 +338,60 @@ var end; begin - // Fallback result - LangID := HKLToLanguageID(GetDefaultHKL); - BCP47 := TLanguageCodeUtils.TranslateWindowsLanguagesToBCP47(LangID); - - // For Win10, look in CPL/International/UserProfile - r := TRegistry.Create; + KL.MethodEnter(nil, 'TTIPMaintenance.GetUserDefaultLanguage', []); try - if not r.OpenKeyReadOnly(SRegKey_ControlPanelInternationalUserProfile) then - Exit; - if r.ValueExists(SRegValue_CPIUP_InputMethodOverride) then - begin - // Lookup the override input method BCP 47 tag - v := r.ReadString(SRegValue_CPIUP_InputMethodOverride); - keys := TStringList.Create; - try - r.GetKeyNames(keys); - for key in keys do - begin - if r.OpenKeyReadOnly('\' + SRegKey_ControlPanelInternationalUserProfile + '\' + key) and - r.ValueExists(v) then + // Fallback result + LangID := HKLToLanguageID(GetDefaultHKL); + BCP47 := TLanguageCodeUtils.TranslateWindowsLanguagesToBCP47(LangID); + + // For Win10, look in CPL/International/UserProfile + r := TRegistry.Create; + try + if not r.OpenKeyReadOnly(SRegKey_ControlPanelInternationalUserProfile) then + Exit; + if r.ValueExists(SRegValue_CPIUP_InputMethodOverride) then + begin + // Lookup the override input method BCP 47 tag + v := r.ReadString(SRegValue_CPIUP_InputMethodOverride); + keys := TStringList.Create; + try + r.GetKeyNames(keys); + for key in keys do begin - BCP47 := key; - LangID := GetLangIDFromValueName; - Break; + if r.OpenKeyReadOnly('\' + SRegKey_ControlPanelInternationalUserProfile + '\' + key) and + r.ValueExists(v) then + begin + BCP47 := key; + LangID := GetLangIDFromValueName; + Break; + end; end; + finally + keys.Free; end; - finally - keys.Free; - end; - end - else if r.ValueExists(SRegValue_CPIUP_Languages) then - begin - // The first tag is the default language tag - tags := TStringList.Create; - try - r.ReadMultiString(SRegValue_CPIUP_Languages, tags); - if tags.Count > 0 then - begin - BCP47 := tags[0].Trim; - if r.OpenKeyReadOnly('\' + SRegKey_ControlPanelInternationalUserProfile + '\' + BCP47) then - LangID := GetLangIDFromValueName; + end + else if r.ValueExists(SRegValue_CPIUP_Languages) then + begin + // The first tag is the default language tag + tags := TStringList.Create; + try + r.ReadMultiString(SRegValue_CPIUP_Languages, tags); + if tags.Count > 0 then + begin + BCP47 := tags[0].Trim; + if r.OpenKeyReadOnly('\' + SRegKey_ControlPanelInternationalUserProfile + '\' + BCP47) then + LangID := GetLangIDFromValueName; + end; + finally + tags.Free; end; - finally - tags.Free; end; + finally + r.Free; end; finally - r.Free; + KL.Log('TTIPMaintenance.GetUserDefaultLanguage = BCP47:%s LangID:%d', [BCP47, LangID]); + KL.MethodExit(nil, 'TTIPMaintenance.GetUserDefaultLanguage'); end; end; diff --git a/windows/src/desktop/kmshell/install/UfrmInstallKeyboard.pas b/windows/src/desktop/kmshell/install/UfrmInstallKeyboard.pas index 8e780442e6..34421ca37e 100644 --- a/windows/src/desktop/kmshell/install/UfrmInstallKeyboard.pas +++ b/windows/src/desktop/kmshell/install/UfrmInstallKeyboard.pas @@ -118,6 +118,7 @@ uses System.Win.ComObj, Winapi.ShellApi, + KLog, custinterfaces, GetOSVersion, MessageIdentifierConsts, @@ -270,7 +271,6 @@ end; procedure TfrmInstallKeyboard.FireCommand(const command: WideString; params: TStringList); var - t: TTempFile; BCP47Tag: string; begin BCP47Tag := ''; @@ -297,28 +297,38 @@ begin BCP47Tag := params.ValueFromIndex[0]; TfrmProgress.Execute(Self, function(Manager: IProgressManager): Boolean + var + t: TTempFile; + ExecParams: string; begin - Manager.Title := 'Installing Keyboard'; - Manager.CanCancel := False; - Manager.UpdateProgress('Installing Keyboard', 0, 0); - t := TTempFileManager.Get('.log'); + KL.MethodEnter(Self, '"keyboard_install"', [params.Text]); try - if WaitForElevatedConfiguration(GetForegroundWindow, '-log "'+t.Name+'" -s -i "'+FInstallFile+'='+BCP47Tag+'"'+ - ' -nowelcome '+TTIPMaintenance.GetUserDefaultLangParameterString) = 0 then - begin - // install the keyboard tip - if not InstallTipForKeyboard(BCP47Tag) then - Exit(False); + Manager.Title := 'Installing Keyboard'; + Manager.CanCancel := False; + Manager.UpdateProgress('Installing Keyboard', 0, 0); + t := TTempFileManager.Get('.log'); + try + ExecParams := '-log "'+t.Name+'" -s -i "'+FInstallFile+'='+BCP47Tag+'"'+ + ' -nowelcome '+TTIPMaintenance.GetUserDefaultLangParameterString; + KL.Log('Calling elevated kmshell %s', [ExecParams]); + if WaitForElevatedConfiguration(GetForegroundWindow, ExecParams) = 0 then + begin + // install the keyboard tip + if not InstallTipForKeyboard(BCP47Tag) then + Exit(False); - CheckForMitigationWarningFor_Win10_1803(False, ''); - ModalResult := mrOk; - end - else - ModalResult := mrCancel; + CheckForMitigationWarningFor_Win10_1803(False, ''); + ModalResult := mrOk; + end + else + ModalResult := mrCancel; - CheckLogFileForWarnings(t.Name, False); + CheckLogFileForWarnings(t.Name, False); + finally + t.Free; + end; finally - t.Free; + KL.MethodExit(Self, '"keyboard_install"'); end; Result := True; end diff --git a/windows/src/global/delphi/general/Keyman.System.CanonicalLanguageCodeUtils.pas b/windows/src/global/delphi/general/Keyman.System.CanonicalLanguageCodeUtils.pas index 3d13b07a8a..4da9557054 100644 --- a/windows/src/global/delphi/general/Keyman.System.CanonicalLanguageCodeUtils.pas +++ b/windows/src/global/delphi/general/Keyman.System.CanonicalLanguageCodeUtils.pas @@ -14,6 +14,7 @@ implementation uses BCP47Tag, + GetOsVersion, Keyman.System.LanguageCodeUtils, Keyman.System.Standards.LangTagsRegistry, System.SysUtils; @@ -34,6 +35,12 @@ var t: TBCP47Tag; LangTag: TLangTag; begin + // We do not try and canonicalize language tags on Windows 7, because it does + // not follow the same patterns as for later versions of Windows. For example, + // zh-CN is not canonicalized to zh-Hans-CN + if GetOs = osWin7 then + Exit(Tag); + if Tag = '' then Exit(''); diff --git a/windows/src/global/delphi/general/klog.pas b/windows/src/global/delphi/general/klog.pas index 0915696743..2787f8b347 100644 --- a/windows/src/global/delphi/general/klog.pas +++ b/windows/src/global/delphi/general/klog.pas @@ -1,18 +1,18 @@ (* Name: klog Copyright: Copyright (C) SIL International. - Documentation: - Description: + Documentation: + Description: Create Date: 1 Aug 2006 Modified Date: 8 Jun 2012 Authors: mcdurdin - Related Files: - Dependencies: + Related Files: + Dependencies: - Bugs: - Todo: - Notes: + Bugs: + Todo: + Notes: History: 01 Aug 2006 - mcdurdin - Disable logging with KLOGGING define 14 Sep 2006 - mcdurdin - Add Current Tick Count to logs (for correlation with system.log) 04 May 2012 - mcdurdin - I3309 - V9.0 - Migrate to Delphi XE2, VS2010, svn 1.7 @@ -23,8 +23,6 @@ unit klog; // I3309 interface -{TNT-IGNORE-UNIT} - {DEFINE KLOGGING} {$IFDEF KLOGGING} @@ -41,6 +39,7 @@ type FLogFile: TextFile; FMethodStack: TStringList; FFileOpen: Boolean; + function VarRecToString(const vr: TVarRec): string; {$ENDIF} public constructor Create; @@ -50,7 +49,8 @@ type procedure LogError(const msg: string); overload; procedure LogError(const msg: string; const fmt: array of const); overload; procedure MethodEnter(instance: TObject; const name: string; const parameters: array of const); - procedure MethodExit(instance: TObject; const name: string); + procedure MethodExit(instance: TObject; const name: string); overload; + procedure MethodExit(instance: TObject; const name: string; const result: array of const); overload; end; function KL: TKLog; @@ -60,8 +60,7 @@ implementation {$IFDEF KLOGGING} uses - Variants, Windows, SysUtils, ErrorControlledRegistry, ErrLogPath, VersionInfo, Unicode; - + Variants, Windows, SysUtils, ErrorControlledRegistry, KeymanPaths, VersionInfo, Unicode; {$ENDIF} var @@ -75,6 +74,7 @@ end; { TKLog } +{$WARN SYMBOL_PLATFORM OFF} constructor TKLog.Create; {$IFDEF KLOGGING} @@ -88,21 +88,21 @@ constructor TKLog.Create; var buf: array[0..260] of char; - FRootPath: string; begin inherited Create; - FRootPath := GetErrLogPath; FMethodStack := TStringList.Create; - GetModuleFileName(hInstance, buf, 260); FAppName := buf; - FLogFileName := FRootPath+ChangeFileExt(ExtractFileName(FAppName), '') + IntToStr(GetCurrentProcessId) + '.log'; + GetModuleFileName(hInstance, buf, 260); FAppName := ChangeFileExt(ExtractFileName(buf),''); + FLogFileName := TKeymanPaths.ErrorLogPath(FAppName); Log(StringOfChar('=', 160)); - Log('Starting application '+FAppName+', version '+GetFileVersionString(FAppName)); + Log('Starting application %s, version %s', [FAppName, GetFileVersionString(FAppName)]); + Log('Command line: %s', [String(CmdLine)]); {$ELSE} begin inherited Create; {$ENDIF} end; +{$WARN SYMBOL_PLATFORM DEFAULT} destructor TKLog.Destroy; {$IFDEF KLOGGING} @@ -163,26 +163,7 @@ begin begin vr := TVarRec(parameters[i]); if i > Low(parameters) then s := s + ', '; - case vr.VType of - vtInteger: s := s + IntToStr(vr.VInteger); - vtBoolean: if vr.VBoolean then s := s + 'True' else s := s + 'False'; - vtChar: s := s + ''''+Char(vr.VChar)+''''; // I3310 - vtExtended: s := s + FloatToStr(vr.VExtended^); - vtString: s := s + ''''+String_AtoU(vr.VString^)+''''; // I3310 // I3310 - vtPointer: s := s + '$'+IntToHex(Integer(vr.VPointer), 8); - vtPChar: s := s + ''''+String_AtoU(vr.VPChar)+''''; // I3310 - vtObject: if vr.VObject = nil then s := s + 'object ' else s := s + 'object '+vr.VObject.ClassName+' [$'+IntToHex(Integer(Pointer(vr.VObject)), 8)+']'; - vtClass: if vr.VClass = nil then s := s + 'class ' else s := s + 'class '+vr.VClass.ClassName; - vtWideChar: s := s + ''''+vr.VWideChar+''''; - vtPWideChar: s := s + ''''+vr.VPWideChar+''''; - vtAnsiString: s := s + ''''+string(vr.VAnsiString)+''''; - vtCurrency: s := s + CurrToStr(vr.VCurrency^); - vtVariant: try s := s + VarToStr(vr.VVariant^); except s := s + ''; end; - vtInterface: s := s + 'interface $'+IntToHex(Integer(vr.VInterface), 8); - vtWideString: s := s + ''''+widestring(vr.VWideString)+''''; - vtInt64: s := s + IntToStr(vr.VInt64^); - vtUnicodeString: s := s + ''''+WideString(vr.VUnicodeString)+''''; // I3309 - end; + s := s + VarRecToString(vr); end; if Assigned(instance) then begin @@ -199,6 +180,26 @@ begin {$ENDIF} end; +procedure TKLog.MethodExit(instance: TObject; const name: string; const result: array of const); +{$IFDEF KLOGGING} +var + s: string; +begin + if Assigned(instance) + then s := instance.ClassName+'.'+name + else s := name; + while (FMethodStack.Count > 0) and (FMethodStack[FMethodStack.Count-1] <> s) do + begin + Log(FMethodStack[FMethodStack.Count-1] + ' not exiting properly!'); + FMethodStack.Delete(FMethodStack.Count-1); + end; + if FMethodStack.Count > 0 then FMethodStack.Delete(FMethodStack.Count-1); + Log(s+'() exit('+VarRecToString(TVarRec(result[0]))+')'); +{$ELSE} +begin +{$ENDIF} +end; + procedure TKLog.MethodExit(instance: TObject; const name: string); {$IFDEF KLOGGING} var @@ -226,6 +227,33 @@ begin {$ENDIF} end; +{$IFDEF KLOGGING} +function TKLog.VarRecToString(const vr: TVarRec): string; +begin + case vr.VType of + vtInteger: Result := IntToStr(vr.VInteger); + vtBoolean: if vr.VBoolean then Result := 'True' else Result := 'False'; + vtChar: Result := ''''+Char(vr.VChar)+''''; // I3310 + vtExtended: Result := FloatToStr(vr.VExtended^); + vtString: Result := ''''+String_AtoU(vr.VString^)+''''; // I3310 // I3310 + vtPointer: Result := '$'+IntToHex(Integer(vr.VPointer), 8); + vtPChar: Result := ''''+String_AtoU(vr.VPChar)+''''; // I3310 + vtObject: if vr.VObject = nil then Result := 'object ' else Result := 'object '+vr.VObject.ClassName+' [$'+IntToHex(Integer(Pointer(vr.VObject)), 8)+']'; + vtClass: if vr.VClass = nil then Result := 'class ' else Result := 'class '+vr.VClass.ClassName; + vtWideChar: Result := ''''+vr.VWideChar+''''; + vtPWideChar: Result := ''''+vr.VPWideChar+''''; + vtAnsiString: Result := ''''+string(vr.VAnsiString)+''''; + vtCurrency: Result := CurrToStr(vr.VCurrency^); + vtVariant: try Result := VarToStr(vr.VVariant^); except Result := ''; end; + vtInterface: Result := 'interface $'+IntToHex(Integer(vr.VInterface), 8); + vtWideString: Result := ''''+widestring(vr.VWideString)+''''; + vtInt64: Result := IntToStr(vr.VInt64^); + vtUnicodeString: Result := ''''+UnicodeString(vr.VUnicodeString)+''''; // I3309 + else Result := '???'; + end; +end; +{$ENDIF} + function KLEnabled: Boolean; begin {$IFDEF KLOGGING} From dac9e80c9735f48ec4b7c5d68b0f0d2aa3eeba15 Mon Sep 17 00:00:00 2001 From: Marc Durdin Date: Wed, 29 Sep 2021 12:12:48 +1000 Subject: [PATCH 4/4] fix(windows): unit test os version --- .../unit-tests/standards-data/GetOsVersion.pas | 18 ++++++++++++++++++ .../standards-data/standardsdata.dpr | 3 ++- .../standards-data/standardsdata.dproj | 3 ++- 3 files changed, 22 insertions(+), 2 deletions(-) create mode 100644 windows/src/unit-tests/standards-data/GetOsVersion.pas diff --git a/windows/src/unit-tests/standards-data/GetOsVersion.pas b/windows/src/unit-tests/standards-data/GetOsVersion.pas new file mode 100644 index 0000000000..a3068b51cd --- /dev/null +++ b/windows/src/unit-tests/standards-data/GetOsVersion.pas @@ -0,0 +1,18 @@ +unit GetOsVersion; + +interface + +// This is a stub version of GetOsVersion for unit tests +type + TOS = (osLegacy, osVista, osWin7, osWin8, osWin10, osOther); + +function GetOs: TOS; + +implementation + +function GetOs: TOS; +begin + Result := osWin10; +end; + +end. diff --git a/windows/src/unit-tests/standards-data/standardsdata.dpr b/windows/src/unit-tests/standards-data/standardsdata.dpr index 5b5d0da7b9..913eaff544 100644 --- a/windows/src/unit-tests/standards-data/standardsdata.dpr +++ b/windows/src/unit-tests/standards-data/standardsdata.dpr @@ -22,7 +22,8 @@ uses Keyman.System.Standards.LangTagsRegistry in '..\..\global\delphi\standards\Keyman.System.Standards.LangTagsRegistry.pas', Keyman.System.Standards.LCIDToBCP47Registry in '..\..\global\delphi\standards\Keyman.System.Standards.LCIDToBCP47Registry.pas', utilstr in '..\..\global\delphi\general\utilstr.pas', - Unicode in '..\..\global\delphi\general\Unicode.pas'; + Unicode in '..\..\global\delphi\general\Unicode.pas', + GetOsVersion in 'GetOsVersion.pas'; var runner : ITestRunner; diff --git a/windows/src/unit-tests/standards-data/standardsdata.dproj b/windows/src/unit-tests/standards-data/standardsdata.dproj index fd12709617..6787b3dab3 100644 --- a/windows/src/unit-tests/standards-data/standardsdata.dproj +++ b/windows/src/unit-tests/standards-data/standardsdata.dproj @@ -96,6 +96,7 @@ + Cfg_2 Base @@ -133,7 +134,7 @@ true - + standardsdata.exe true