spiegel-keyman/windows/src/desktop/kmshell/install/Keyman.Configuration.System.TIPMaintenance.pas

unit Keyman.Configuration.System.TIPMaintenance;

interface

uses
  Sentry.Client,
  System.Classes,
  utiltsf,
  KeymanAPI_TLB;

type
  TTIPMaintenance = class
  public
    /// <summary>Install a TIP for the current user (user context)</summary>
    class function DoInstall(const KeyboardID, BCP47Tag: string): Boolean;

    /// <summary>Install a TIP for the current user (user context)</summary>
    class function InstallTip(LangID: Integer; const KeyboardID, BCP47Tag, KeyboardToRemove: string): Boolean;

    /// <summary>Install TIPs for packages for the current user (user context)</summary>
    class function InstallTipsForPackages(Packages: TStrings): Boolean; static;

    /// <summary>Install TIP for a package for the current user (user context)</summary>
    class function InstallTipForPackage(const PackageFilename, BCP47Tag: string): Boolean; static;

    /// <summary>Register TIP for the local machine (elevated context)</summary>
    class function DoRegister(const KeyboardID, BCP47Tag: string): Boolean;

    /// <summary>Register TIP for the local machine (elevated context)</summary>
    class function RegisterTip(LangID: Integer; const KeyboardID, BCP47Tag: string): Boolean;

    /// <summary>Helper function to get default BCP47 tag for an installed keyboard</summary>
    class function GetFirstLanguage(Keyboard: IKeymanKeyboardInstalled): string; overload;
    class function GetFirstLanguage(Keyboard: IKeymanKeyboardFile): string; overload;

    /// <summary>Get the BCP47 tag for the user's default language</summary>
    class function GetUserDefaultLanguage: string; overload; static;
    class procedure GetUserDefaultLanguage(var BCP47: string; var LangID: Integer); overload; static;

    /// <summary>Get the -default-lang parameter string for kmshell</summary>
    class function GetUserDefaultLangParameterString: string; static;
  private
    class function GetKeyboardLanguage(const KeyboardID,
      BCP47Tag: string): IKeymanKeyboardLanguageInstalled; static;
  end;

implementation

uses
  System.SysUtils,
  System.Win.Registry,
  Winapi.Windows,

  Keyman.System.KeymanSentryClient,
  Keyman.System.LanguageCodeUtils,

  KLog,
  BCP47Tag,
  glossary,
  kmint,
  RegistryKeys,
  utilkmshell,
  utilexecute,
  utilsystem;

  { For temporary debugging couldn't include utilkeyman.pas so extracted needed function }

function GetShortKeyboardName(const FileName: string): string;
begin
  if (LowerCase(ExtractFileExt(FileName)) = '.kmx') or
      (LowerCase(ExtractFileExt(FileName)) = '.kxx') or
      (LowerCase(ExtractFileExt(FileName)) = '.kmp')
    then Result := ChangeFileExt(ExtractFileName(FileName), '')
    else Result := FileName;
end;

// https://stackoverflow.com/questions/9004870/enumerate-registry-subkeys-in-delphi
procedure GetSubKeyList(RootKey: HKEY; const Key: string; var KeyList: string);
var
  Registry: TRegistry;
  SubKeyNames: TStringList;
  Name: string;
begin
  Registry := TRegistry.Create(KEY_READ);
  KeyList := '';
  Try
    Registry.RootKey := RootKey;
    if not Registry.OpenKeyReadOnly(Key) then
    begin
      KeyList := '<Unable to open key>';
      Exit;
    end;
    SubKeyNames := TStringList.Create;
    Try
      Registry.GetKeyNames(SubKeyNames);
      for Name in SubKeyNames do
        KeyList := KeyList + ' ' + Name;
    Finally
      SubKeyNames.Free;
    End;
  Finally
    Registry.Free;
  End;
end;

  { TTIPMaintenance }

class function TTIPMaintenance.InstallTipsForPackages(Packages: TStrings): Boolean;
var
  i: Integer;
begin
  Result := True;
  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;
var
  PackageID: string;
  n: Integer;
  pack: IKeymanPackageInstalled;
begin
  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);

    pack := kmcom.Packages[n];

    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);
  finally
    KL.MethodExit(nil, 'TTIPMaintenance.InstallTipForPackage', [Result]);
  end;
end;

procedure AddDiagnosticBreadcrumb(const KeyboardID: string);
var
  keys: TStringList;
  RootPath: string;
  reg: TRegistry;
begin
  keys := TStringList.Create;
  reg := TRegistry.Create(KEY_READ);
  try
    reg.RootKey := HKEY_LOCAL_MACHINE;
    RootPath := SRegKey_InstalledKeyboards_LM+'\'+KeyboardID+'\'+SRegSubKey_LanguageProfiles;
    if reg.OpenKeyReadOnly(RootPath) then
    begin
      reg.GetKeyNames(keys);
      TKeymanSentryClient.Breadcrumb('Registry', RootPath + #13#10 + keys.Text);
    end;
  finally
    reg.Free;
    keys.Free;
  end;
end;

class function TTIPMaintenance.InstallTip(LangID: Integer; const KeyboardID, BCP47Tag,
  KeyboardToRemove: string): Boolean;
var
  lang: IKeymanKeyboardLanguageInstalled;
begin
  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);
    Result := True;
  finally
    KL.MethodExit(nil, 'TTIPMaintenance.InstallTip', [Result]);
  end;
end;

class function TTIPMaintenance.RegisterTip(LangID: Integer; const KeyboardID,
  BCP47Tag: string): Boolean;
var
  lang: IKeymanKeyboardLanguageInstalled;
begin
  Result := False;
  KL.MethodEnter(nil, 'TTIPMaintenance.RegisterTip', [KeyboardID, BCP47Tag]);
  try
    lang := GetKeyboardLanguage(KeyboardID, BCP47Tag);
    if lang = nil then
      Exit(False);

    // TODO: can this fail?
    (lang as IKeymanKeyboardLanguageInstalled2).RegisterTip(LangID);
    Result := True;
  finally
    KL.MethodExit(nil, 'TTIPMaintenance.RegisterTip', [Result]);
  end;
end;

class function TTIPMaintenance.DoInstall(const KeyboardID,
  BCP47Tag: string): Boolean;
var
  lang: IKeymanKeyboardLanguageInstalled;
  RegistrationRequired: WordBool;
  TemporaryKeyboardID: WideString;
  LangID: Integer;
  childExitCode, elevatedExitCode: Cardinal;
  CanonicalTag, Command, RootPath, KeyList: string;
begin
  Result := False;
  KL.MethodEnter(nil, 'TTIPMaintenance.DoInstall', [KeyboardID, BCP47Tag]);
  try
    CanonicalTag := (kmcom as IKeymanBCP47Canonicalization).GetCanonicalTag(BCP47Tag);
    lang := GetKeyboardLanguage(KeyboardID, CanonicalTag);
    if lang = nil then
    begin
      // The keyboard was not found
      KL.Log('lang not found: BCP47Tag = %s, CanonicalTag = %s', [BCP47Tag, CanonicalTag]);
      // Additonal Sentry logging added to track TIP crash git hub issue #6619
      if TKeymanSentryClient.Client <> nil then
        TKeymanSentryClient.Client.MessageEvent(Sentry.Client.SENTRY_LEVEL_INFO,
          Format('TTIPMaintenance.DoInstall: lang not found: BCP47Tag = %s, CanonicalTag = %s', [BCP47Tag, CanonicalTag]),
          TRUE);
      Exit(False);
    end;

    KL.Log('BCP47Tag = %s, CanonicalTag = %s, lang.BCP47Code = %s', [BCP47Tag, CanonicalTag, lang.BCP47Code]);

    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

      // Additonal Sentry logging added to track TIP crash git hub issue #6619
      if TKeymanSentryClient.Client <> nil then
        TKeymanSentryClient.Client.MessageEvent(Sentry.Client.SENTRY_LEVEL_INFO,
          Format('TTIPMaintenance.DoInstall: FindInstallationLangID failed kbID[%s] BCP47Tag[%s] CanonicalTag[%s] lang.BCP47Tag[%s] Result LangID[%x] TempKeyboardID[%s] RegistrationRequired[%s]',
            [KeyboardID,  BCP47Tag, CanonicalTag, lang.BCP47Code, LangId, TemporaryKeyboardID, BoolToStr(RegistrationRequired, True)]),
          TRUE);
      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
      elevatedExitCode := WaitForElevatedConfiguration(0, Command);
      if elevatedExitCode <> 0 then
        // Additonal Sentry logging added to track TIP crash git hub issue #6619
        if TKeymanSentryClient.Client <> nil then
          // Log command line, state of variables and registry subkeys in the language profile
          if IsTransientLanguageID(LangID) then
          begin
            RootPath := SRegKey_InstalledKeyboards_LM+'\'+GetShortKeyboardName(KeyboardID) + SRegSubKey_TransientLanguageProfiles;
          end
          else
          begin
            RootPath := SRegKey_InstalledKeyboards_LM+'\'+GetShortKeyboardName(KeyboardID) + SRegSubKey_LanguageProfiles;
          end;
          GetSubKeyList(HKEY_LOCAL_MACHINE,RootPath,KeyList);
          TKeymanSentryClient.Client.MessageEvent(Sentry.Client.SENTRY_LEVEL_INFO,
            Format('TTIPMaintenance.DoInstall: ElevatedRegistration child process failed CommadLine[%s] kbID[%s] BCP47Tag[%s] CanonicalTag[%s] TempKeyboardID[%s] ' +
                    'RegistrationRequired[%s] Exit Code[%d] '#13#10' Registry Values for Languages[%s]',
                    [Command, KeyboardID,  BCP47Tag, CanonicalTag, TemporaryKeyboardID, BoolToStr(RegistrationRequired, True), elevatedExitCode, KeyList]), TRUE);
        Exit(False); // sentry log
    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;
      // Additional Sentry logging added to track TIP crash git hub issue #6619
      if TKeymanSentryClient.Client <> nil then
        //  Log command line, state of variables and registry subkeys in the language profile.
        if IsTransientLanguageID(LangID) then
        begin
          RootPath := SRegKey_InstalledKeyboards_LM+'\'+GetShortKeyboardName(KeyboardID) + SRegSubKey_TransientLanguageProfiles;
        end
        else
        begin
          RootPath := SRegKey_InstalledKeyboards_LM+'\'+GetShortKeyboardName(KeyboardID) + SRegSubKey_LanguageProfiles;
        end;
        GetSubKeyList(HKEY_LOCAL_MACHINE,RootPath,KeyList);
        TKeymanSentryClient.Client.MessageEvent(Sentry.Client.SENTRY_LEVEL_INFO,
          Format('TTIPMaintenance.DoInstall: InstallTip child process failed CommadLine[%s] kbID[%s] BCP47Tag[%s] CanonicalTag[%s] ' +
                  'RegistrationRequired[%s] Exit Code[%d] '#13#10' Registry Values for Languages[%s]',
                  [Command, KeyboardID,  BCP47Tag, CanonicalTag, BoolToStr(RegistrationRequired, True), childExitCode, KeyList] ), TRUE);
      Exit(False);
    end;

    kmcom.Refresh;
    Result := True;
  finally
    KL.MethodExit(nil, 'TTIPMaintenance.DoInstall', [Result]);
  end;
end;

function GetDefaultHKL: HKL;
begin
  if not SystemParametersInfo(SPI_GETDEFAULTINPUTLANG, 0, @Result, 0) then
    Result := 0;
end;

class function TTIPMaintenance.DoRegister(const KeyboardID,
  BCP47Tag: string): Boolean;
var
  lang: IKeymanKeyboardLanguageInstalled;
  LangID: Integer;
  TemporaryKeyboardID: WideString;
  RegistrationRequired: WordBool;
begin
  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);

    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;
  finally
    KL.MethodExit(nil, 'TTIPMaintenance.DoRegister', [Result]);
  end;
end;

class function TTIPMaintenance.GetUserDefaultLangParameterString: string;
var
  LangID: Integer;
  BCP47: string;
begin
  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
  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);
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\<bcp47>, 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
  KL.MethodEnter(nil, 'TTIPMaintenance.GetUserDefaultLanguage', []);
  try
    // 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
            if r.OpenKeyReadOnly('\' + SRegKey_ControlPanelInternationalUserProfile + '\' + key) and
              r.ValueExists(v) then
            begin
              BCP47 := key;
              LangID := GetLangIDFromValueName;
              Break;
            end;
          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;
        finally
          tags.Free;
        end;
      end;
    finally
      r.Free;
    end;
  finally
    KL.Log('TTIPMaintenance.GetUserDefaultLanguage = BCP47:%s LangID:%d', [BCP47, LangID]);
    KL.MethodExit(nil, 'TTIPMaintenance.GetUserDefaultLanguage');
  end;
end;

class function TTIPMaintenance.GetFirstLanguage(Keyboard: IKeymanKeyboardFile): string;
begin
  if Keyboard.Languages.Count > 0
    then Result := Keyboard.Languages[0].BCP47Code
    else Result := GetUserDefaultLanguage;
end;

class function TTIPMaintenance.GetFirstLanguage(Keyboard: IKeymanKeyboardInstalled): string;
begin
  if Keyboard.Languages.Count > 0
    then Result := Keyboard.Languages[0].BCP47Code
    else Result := GetUserDefaultLanguage;
end;

class function TTIPMaintenance.GetKeyboardLanguage(const KeyboardID,
  BCP47Tag: string): IKeymanKeyboardLanguageInstalled;
var
  keyboard: IKeymanKeyboardInstalled;
  i: Integer;
begin
  keyboard := kmcom.Keyboards[KeyboardID];
  if keyboard = nil then
    Exit(nil);

  for i := 0 to keyboard.Languages.Count - 1 do
    if SameText(keyboard.Languages[i].BCP47Code, BCP47Tag) then
      Exit(keyboard.Languages[i]);

  Result := (keyboard.Languages as IKeymanKeyboardLanguagesInstalled2).Add(BCP47Tag);
end;

end.