From 66ddceadda03072e5ea3add3cc6684a797dd3404 Mon Sep 17 00:00:00 2001 From: Marc Durdin Date: Wed, 29 Sep 2021 11:34:16 +1000 Subject: [PATCH] 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}