From cd03f5326dea8077e8efacebed560c231e41866c Mon Sep 17 00:00:00 2001 From: joost Date: Fri, 15 Feb 2019 21:25:05 +0000 Subject: [PATCH] * Fixed bug #35060, proper unicode-handling of registry-keynames. With test (modified) from Bart Broersma git-svn-id: trunk@41325 - --- .gitattributes | 2 + packages/fcl-registry/src/winreg.inc | 27 ++-- tests/test/packages/fcl-registry/tw35060a.pp | 154 ++++++++++++++++++ tests/test/packages/fcl-registry/tw35060b.pp | 155 +++++++++++++++++++ 4 files changed, 325 insertions(+), 13 deletions(-) create mode 100644 tests/test/packages/fcl-registry/tw35060a.pp create mode 100644 tests/test/packages/fcl-registry/tw35060b.pp diff --git a/.gitattributes b/.gitattributes index 39f2b02696..c002e144a5 100644 --- a/.gitattributes +++ b/.gitattributes @@ -12722,6 +12722,8 @@ tests/test/packages/fcl-db/tdb5.pp svneol=native#text/plain tests/test/packages/fcl-db/tdb6.pp svneol=native#text/plain tests/test/packages/fcl-db/toolsunit.pas svneol=native#text/plain tests/test/packages/fcl-registry/tregistry1.pp svneol=native#text/plain +tests/test/packages/fcl-registry/tw35060a.pp svneol=native#text/plain +tests/test/packages/fcl-registry/tw35060b.pp svneol=native#text/plain tests/test/packages/fcl-xml/thtmlwriter.pp svneol=native#text/plain tests/test/packages/fcl-xml/tw22495.pp svneol=native#text/plain tests/test/packages/fcl-xml/uw22495.pp svneol=native#text/plain diff --git a/packages/fcl-registry/src/winreg.inc b/packages/fcl-registry/src/winreg.inc index e69338c0eb..63c51d6e8a 100644 --- a/packages/fcl-registry/src/winreg.inc +++ b/packages/fcl-registry/src/winreg.inc @@ -28,12 +28,13 @@ begin Dispose(PWinRegData(FSysData)); end; -Function PrepKey(Const S : String) : pChar; +Function PrepKey(Const S : String) : String; begin - Result:=PChar(S); - If Result^='\' then - Inc(Result); + If Copy(S, 1, 1)='\' then + Result := Copy(Result, 2) + else + Result := S; end; Function RelativeKey(Const S : String) : Boolean; @@ -52,7 +53,7 @@ Var begin SecurityAttributes := Nil; - u:=UTF8Decode(PrepKey(Key)); + u:=PrepKey(Key); FLastError:=RegCreateKeyExW(GetBaseKey(RelativeKey(Key)), PWideChar(u), 0, @@ -71,14 +72,14 @@ function TRegistry.DeleteKey(const Key: String): Boolean; Var u: UnicodeString; begin - u:=UTF8Decode(PRepKey(Key)); + u:=PRepKey(Key); FLastError:=RegDeleteKeyW(GetBaseKey(RelativeKey(Key)),PWideChar(u)); Result:=FLastError=ERROR_SUCCESS; end; function TRegistry.DeleteValue(const Name: String): Boolean; begin - FLastError:= RegDeleteValueW(fCurrentKey, PWideChar(UTF8Decode(Name))); + FLastError:= RegDeleteValueW(fCurrentKey, PWideChar(UnicodeString(Name))); Result:=FLastError=ERROR_SUCCESS; end; @@ -89,7 +90,7 @@ Var RD : DWord; begin - u := UTF8Decode(Name); + u := Name; FLastError:=RegQueryValueExW(fCurrentKey,PWideChar(u),Nil, @RD,Buffer,lpdword(@BufSize)); if (FLastError<>ERROR_SUCCESS) Then @@ -110,7 +111,7 @@ Var RD : DWord; begin - u:=UTF8Decode(ValueName); + u:=ValueName; With Value do begin FLastError:=RegQueryValueExW(fCurrentKey,PWideChar(u),Nil,lpdword(@RegData),Nil,lpdword(@DataSize)); @@ -147,7 +148,7 @@ begin {$ifdef WinCE} FLastError:=RegOpenKeyEx(GetBaseKey(Rel),PWideChar(WideString(S)),0,FAccess,Result); {$else WinCE} - u:=UTF8Decode(S); + u:=UnicodeString(S); FLastError:=RegOpenKeyExW(GetBaseKey(Rel),PWideChar(u),0,FAccess,Result); {$endif WinCE} end; @@ -212,7 +213,7 @@ Var S: string; begin SecurityAttributes := Nil; - u:=UTF8Decode(PrepKey(Key)); + u:=PrepKey(Key); If CanCreate then begin Handle:=0; @@ -260,7 +261,7 @@ begin {$ifdef WinCE} Result:=False; {$else} - FLastError:=RegConnectRegistryW(PWideChar(UTF8Decode(UNCName)),RootKey,newroot); + FLastError:=RegConnectRegistryW(PWideChar(UnicodeString(UNCName)),RootKey,newroot); Result:=FLastError=ERROR_SUCCESS; if Result then begin RootKey:=newroot; @@ -422,7 +423,7 @@ Var begin RegDataType:=RegDataWords[RegData]; - u:=UTF8Decode(Name); + u:=UnicodeString(Name); FLastError:=RegSetValueExW(fCurrentKey,PWideChar(u),0,RegDataType,Buffer,BufSize); Result:=FLastError=ERROR_SUCCESS; end; diff --git a/tests/test/packages/fcl-registry/tw35060a.pp b/tests/test/packages/fcl-registry/tw35060a.pp new file mode 100644 index 0000000000..ada019d881 --- /dev/null +++ b/tests/test/packages/fcl-registry/tw35060a.pp @@ -0,0 +1,154 @@ +{ %TARGET=win32,win64,wince } + +program tw35060a; + +{$apptype console} +{$assertions on} +{$ifdef fpc} +{$codepage cp1252} +{$mode objfpc} +{$h+} +{$endif fpc} + +uses + SysUtils, Classes, Windows, Registry; + +{$ifndef fpc} +type + UnicodeString = WideString; + +function GetLastOSError: Integer; +begin + Result := GetLastError; +end; +{$endif} + +const + ExpectedAnsiHex = 'E4 EB EF'; + ExpectedUnicodeHex = '00E4 00EB 00EF'; + BugID = 'FPCBug0035060'; + +function UnicodeToHex(const S: UnicodeString): String; +var + i: Integer; +begin + Result := ''; + for i := 1 to length(S) do + Result := Result + IntToHex(Word(S[i]),4) + #32; + Result := Trim(Result); +end; + +function AnsiToHex(const S: String): String; +var + i: Integer; +begin + Result := ''; + for i := 1 to length(S) do + Result := Result + IntToHex(Byte(S[i]),2) + #32; + Result := Trim(Result); +end; + + +//Creating and removing Keys using plain Windows W-API +function PrepKeyW(Const S : UnicodeString) : pWideChar; +begin + Result:=PWideChar(S); + If Result^='\' then + Inc(Result); +end; + +procedure CreateKeyInHKCU(const Key: UnicodeString); +Var + u: UnicodeString; + Disposition: Dword; + Handle: HKEY; + SecurityAttributes: Pointer; //LPSECURITY_ATTRIBUTES; + FLastError: LongInt; +begin + SecurityAttributes := Nil; + u:=PrepKeyW(Key); + Handle := 0; + FLastError:=RegCreateKeyExW(HKEY_CURRENT_USER, + PWideChar(u), + 0, + '', + REG_OPTION_NON_VOLATILE, + KEY_ALL_ACCESS, + SecurityAttributes, + Handle, + @Disposition); + RegCloseKey(Handle); + Assert(FLastError=ERROR_SUCCESS,format('Creating key "%s" using plain Windows API failed: "%s"', + [String(Key),Trim(SysErrorMessage(FLastError))])); +end; + + +procedure CreateTestKey; +const + TestKey: UnicodeString = 'Software\'+ UniCodeString(BugID)+ '\äëï'; +var + Len: Integer; +begin + Len := Length(TestKey); + //Being a bit paranoid here? + Assert((Len=26) and (Word(TestKey[Len])=$EF) and (Word(TestKey[Len-1])=$EB) and (Word(TestKey[Len-2])=$E4),'Wrong encoding of TestKey'); + CreateKeyInHKCU(TestKey); +end; + +procedure RemoveTestKey; +const + TestKeyFull: UnicodeString = 'Software\'+ UniCodeString(BugID)+ '\äëï'; + TestKeyBugID: UnicodeString = 'Software\'+ UniCodeString(BugID); +var + Key: UnicodeString; + FLastError: LongInt; +begin + Key:=PRepKeyW(TestKeyFull); + FLastError:=RegDeleteKeyW(HKEY_CURRENT_USER,PWideChar(Key)); + Assert(FLastError=ERROR_SUCCESS,format('Removing key "%s" using plain Windows API failed: "%s"', + [String(Key),Trim(SysErrorMessage(FLastError))])); + + Key:=PRepKeyW(TestKeyBugID); + FLastError:=RegDeleteKeyW(HKEY_CURRENT_USER,PWideChar(Key)); + Assert(FLastError=ERROR_SUCCESS,format('Removing key "%s" using plain Windows API failed: "%s"', + [String(Key),Trim(SysErrorMessage(FLastError))])); +end; + +//End Registry plain API functions + +var + R: TRegistry; + Name, S, Key: String; + U: UnicodeString; + B: Boolean; + Err: Integer; + CP: TSystemCodePage; +begin + CreateTestKey; + try + Name := 'äëï'; + U := UnicodeString(Name); + S := AnsiToHex(Name); + Assert(S=ExpectedAnsiHex,format('Name is wrongly encoded: expected: %s, found: %s',[ExpectedAnsiHex,S])); + S := UnicodeToHex(U); + Assert(S=ExpectedUnicodeHex,format('Name is wrongly encoded: expected: %s, found: %s',[ExpectedUnicodeHex,S])); + + R := TRegistry.Create(KEY_ALL_ACCESS); + try + R.RootKey := HKEY_CURRENT_USER; + Key := '\Software\'+BugId+'\'+Name; + CP := System.StringCodePage(Key); + Assert(CP <> 65001,format('The string that contains the key does not have CP_ACP as dynamic code page, but has codepage %d',[CP])); + B := R.OpenKeyReadOnly(Key); + Err := GetLastOSError; + Assert(B,format('OpenKey(''%s'') failed: "%s" [%d]',[Key,Trim(SysErrorMessage(Err)),Err])); + writeln(format('OpenKeyReadOnly(''%s''): OK',[Key])); + finally + R.Free; + end; + + finally + RemoveTestKey; + end; +end. + diff --git a/tests/test/packages/fcl-registry/tw35060b.pp b/tests/test/packages/fcl-registry/tw35060b.pp new file mode 100644 index 0000000000..7a13687a1e --- /dev/null +++ b/tests/test/packages/fcl-registry/tw35060b.pp @@ -0,0 +1,155 @@ +{ %TARGET=win32,win64,wince } + +program tw35060b; + +{$apptype console} +{$assertions on} +{$ifdef fpc} +{$codepage utf8} +{$mode objfpc} +{$h+} +{$endif fpc} + +uses + SysUtils, Classes, Windows, Registry; + +{$ifndef fpc} +type + UnicodeString = WideString; + +function GetLastOSError: Integer; +begin + Result := GetLastError; +end; +{$endif} + +const + ExpectedUtf8Hex = 'C3 A4 C3 AB C3 AF'; + ExpectedUnicodeHex = '00E4 00EB 00EF'; + BugID = 'FPCBug0035060'; + +function UnicodeToHex(const S: UnicodeString): String; +var + i: Integer; +begin + Result := ''; + for i := 1 to length(S) do + Result := Result + IntToHex(Word(S[i]),4) + #32; + Result := Trim(Result); +end; + +function Utf8ToHex(const S: String): String; +var + i: Integer; +begin + Result := ''; + for i := 1 to length(S) do + Result := Result + IntToHex(Byte(S[i]),2) + #32; + Result := Trim(Result); +end; + + +//Creating and removing Keys using plain Windows W-API +function PrepKeyW(Const S : UnicodeString) : pWideChar; +begin + Result:=PWideChar(S); + If Result^='\' then + Inc(Result); +end; + +procedure CreateKeyInHKCU(const Key: UnicodeString); +Var + u: UnicodeString; + Disposition: Dword; + Handle: HKEY; + SecurityAttributes: Pointer; //LPSECURITY_ATTRIBUTES; + FLastError: LongInt; +begin + SecurityAttributes := Nil; + u:=PrepKeyW(Key); + Handle := 0; + FLastError:=RegCreateKeyExW(HKEY_CURRENT_USER, + PWideChar(u), + 0, + '', + REG_OPTION_NON_VOLATILE, + KEY_ALL_ACCESS, + SecurityAttributes, + Handle, + @Disposition); + RegCloseKey(Handle); + Assert(FLastError=ERROR_SUCCESS,format('Creating key "%s" using plain Windows API failed: "%s"', + [String(Key),Trim(SysErrorMessage(FLastError))])); +end; + + +procedure CreateTestKey; +const + TestKey: UnicodeString = 'Software\'+ UniCodeString(BugID)+ '\äëï'; +var + Len: Integer; +begin + Len := Length(TestKey); + //Being a bit paranoid here? + Assert((Len=26) and (Word(TestKey[Len])=$EF) and (Word(TestKey[Len-1])=$EB) and (Word(TestKey[Len-2])=$E4),'Wrong encoding of TestKey'); + CreateKeyInHKCU(TestKey); +end; + +procedure RemoveTestKey; +const + TestKeyFull: UnicodeString = 'Software\'+ UniCodeString(BugID)+ '\äëï'; + TestKeyBugID: UnicodeString = 'Software\'+ UniCodeString(BugID); +var + Key: UnicodeString; + FLastError: LongInt; +begin + Key:=PRepKeyW(TestKeyFull); + FLastError:=RegDeleteKeyW(HKEY_CURRENT_USER,PWideChar(Key)); + Assert(FLastError=ERROR_SUCCESS,format('Removing key "%s" using plain Windows API failed: "%s"', + [String(Key),Trim(SysErrorMessage(FLastError))])); + + Key:=PRepKeyW(TestKeyBugID); + FLastError:=RegDeleteKeyW(HKEY_CURRENT_USER,PWideChar(Key)); + Assert(FLastError=ERROR_SUCCESS,format('Removing key "%s" using plain Windows API failed: "%s"', + [String(Key),Trim(SysErrorMessage(FLastError))])); +end; + +//End Registry plain API functions + +var + R: TRegistry; + Name, S: String; + Key: Utf8String; + U: UnicodeString; + B: Boolean; + Err: Integer; + CP: TSystemCodePage; +begin + CreateTestKey; + try + Name := 'äëï'; + U := UnicodeString(Name); + S := Utf8ToHex(Name); + Assert(S=ExpectedUtf8Hex,format('Name is wrongly encoded: expected: %s, found: %s',[ExpectedUtf8Hex,S])); + S := UnicodeToHex(U); + Assert(S=ExpectedUnicodeHex,format('Name is wrongly encoded: expected: %s, found: %s',[ExpectedUnicodeHex,S])); + + R := TRegistry.Create(KEY_ALL_ACCESS); + try + R.RootKey := HKEY_CURRENT_USER; + Key := 'Software\'+BugId+'\'+Name; + CP := System.StringCodePage(Key); + Assert(CP = 65001,format('The string that contains the key does not have UTF-8 as dynamic code page, but has codepage %d',[CP])); + B := R.OpenKeyReadOnly(Key); + Err := GetLastOSError; + Assert(B,format('OpenKey(''%s'') failed: "%s" [%d]',[Key,Trim(SysErrorMessage(Err)),Err])); + writeln(format('OpenKeyReadOnly(''%s''): OK',[Key])); + finally + R.Free; + end; + + finally + RemoveTestKey; + end; +end. +