paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-14 06:06:21 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Fixed bug #35060, proper unicode-handling of registry-keynames. With test

Browse Source 
(modified) from Bart Broersma

git-svn-id: trunk@41325 -
This commit is contained in:
joost 2019-02-15 21:25:05 +00:00
parent e3546cf5af
commit cd03f5326d
4 changed files with 325 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -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

27
packages/fcl-registry/src/winreg.inc
View File

@ -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;

154
tests/test/packages/fcl-registry/tw35060a.pp Normal file
View File

@ -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.

155
tests/test/packages/fcl-registry/tw35060b.pp Normal file
View File

@ -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.