paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-09 20:28:49 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Corrected patch from Rolf Wetjen to use unicode API on windows (bug ID 32185)

Browse Source 
git-svn-id: trunk@36765 -
This commit is contained in:
michael 2017-07-22 17:09:45 +00:00
parent 3b48c6e316
commit 3b5d532ab5
6 changed files with 462 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -2701,6 +2701,7 @@ packages/fcl-registry/Makefile svneol=native#text/plain
packages/fcl-registry/Makefile.fpc svneol=native#text/plain
packages/fcl-registry/Makefile.fpc.fpcmake svneol=native#text/plain
packages/fcl-registry/examples/remotereg.pp svneol=native#text/pascal
packages/fcl-registry/examples/testunicode.pp svneol=native#text/plain
packages/fcl-registry/fpmake.pp svneol=native#text/plain
packages/fcl-registry/src/regdef.inc svneol=native#text/plain
packages/fcl-registry/src/regini.inc svneol=native#text/plain

257
packages/fcl-registry/examples/testunicode.pp Normal file
View File

@ -0,0 +1,257 @@
program testunicode;
{$mode objfpc}{$H+}
{$codepage utf8}
{$IFNDEF UNIX}
{$APPTYPE CONSOLE}
{$ENDIF}
uses
sysutils, classes, registry;
Var
EditKey : UTF8String = 'ASCII;这是一个测试';
labeledEditName : UTF8String = 'ASCII;പേര് ഇതാണ്ASCII;这是一个测试';
labeledEditValue : UTF8String = 'これは値です;ASCII';
labelkeycaption : string = 'HKCU\Software\zzz_test\';
reg: TRegistry;
Results : TStrings;
function TestKey (const AKey: utf8string): boolean;
begin
Result:=false;
try
reg.CloseKey;
if reg.KeyExists(AKey) then
reg.DeleteKey(AKey);
if reg.KeyExists(AKey) then
begin
Results.Add('TestKey-01 failed: DeleteKey(%s);',[AKey]);
exit;
end;
if not reg.OpenKey(AKey,true) then
begin
Results.Add('TestKey-02 failed: OpenKey(%s,true)',[AKey]);
exit;
end;
reg.CloseKey;
if not reg.KeyExists(AKey) then
begin
Results.Add('TestKey-03 failed: OpenKey(%s,true)',[AKey]);
exit;
end;
reg.DeleteKey(AKey);
if not reg.CreateKey(AKey) then
begin
Results.Add('TestKey-04 failed: CreateKey(%s)',[AKey]);
exit;
end;
if not reg.KeyExists(AKey) then
begin
Results.Add('TestKey-05 failed: CreateKey(%s,true)',[AKey]);
exit;
end;
if not reg.OpenKeyReadOnly(AKey) then
begin
Results.Add('TestKey-06 failed: OpenKeyReadOnly(%s)',[AKey]);
exit;
end;
reg.CloseKey;
if not reg.OpenKey(AKey,false) then
begin
Results.Add('TestKey-07 failed: OpenKey(%s,false)',[AKey]);
exit;
end;
Results.Add('TestKey passed: %s',[AKey]);
except
on e:Exception do
Results.Add('TestKey-08 failed: %s; %s;',[AKey,e.Message]);
end;
Result:=true;
end;
procedure TestValue (const AName, AValue: utf8string);
var
wrong,s: string;
begin
try
wrong:=AName+'_wrong';
if reg.ValueExists(wrong) then
reg.DeleteValue(wrong);
if reg.ValueExists(wrong) then
begin
Results.Add('TestValue-01 failed: DeleteValue(%s)',[wrong]);
exit;
end;
reg.WriteString(wrong,AValue);
s:=reg.ReadString(wrong);
if s<>AValue then
begin
Results.Add('TestValue-02 failed: WriteString(%s,%s)',[wrong,AValue]);
exit;
end;
if reg.ValueExists(AName) then
reg.DeleteValue(AName);
if reg.ValueExists(AName) then
begin
Results.Add('TestValue-03 failed: DeleteValue(%s)',[AName]);
exit;
end;
reg.RenameValue(wrong,AName);
s:=reg.ReadString(AName);
if s<>AValue then
begin
Results.Add('TestValue-04 failed: RenameValue(%s,%s)',[wrong,AName]);
exit;
end;
Results.Add('TestValue passed: %s; %s;',[AName,AValue]);
except
on e:Exception do
Results.Add('TestValue-08 failed: %s; %s; %s;',[AName,AValue,e.Message]);
end;
end;
procedure TestGetKeyNames (const AKey, AExpected: utf8string);
var
sl: TStringList;
begin
sl:=TStringList.Create;
sl.Delimiter:=';';
reg.CloseKey;
try
if not reg.OpenKeyReadOnly(AKey) then
begin
Results.Add('TestGetKeyNames-01 failed: Key "%s";',[AKey]);
exit;
end;
reg.GetKeyNames(sl);
if sl.DelimitedText=AExpected then
Results.Add('TestGetKeyNames passed: Key: "%s"; Expected: "%s";',[AKey,AExpected])
else
Results.Add('TestGetKeyNames-02 failed: Key: "%s"; got: "%s"; expected: "%s";',
[AKey,sl.DelimitedText,AExpected]);
except
on e:Exception do
Results.Add('TestGetKeyNames-03 failed exception: Key: "%s"; Got: "%s"; Expected: "%s"; Exception: "%s";',
[AKey,sl.DelimitedText,AExpected,e.Message]);
end;
sl.Free;
end;
procedure TestGetValueNames (const AKey, AExpected: UTF8string);
var
sl: TStringList;
begin
sl:=TStringList.Create;
sl.Delimiter:=';';
try
reg.GetValueNames(sl);
if sl.DelimitedText=AExpected then
Results.Add('TestGetValueNames passed: Key: "%s"; Expected "%s";',[AKey,AExpected])
else
Results.Add('TestGetValueNames-01 failed: Key "%s"; Got: "%s"; Expected: "%s";',
[AKey,sl.DelimitedText,AExpected]);
except
on e:Exception do
Results.Add('TestGetValueNames-02 failed exception: Key: "%s"; Got: "%s"; expected: "%s"; exception: "%s";',
[AKey,sl.DelimitedText,AExpected,e.Message]);
end;
sl.Free;
end;
procedure Test;
var
sKey: string;
slKeys,
slNames,
slValues: TStringList;
sValueNames,
s: string;
k,n,v: integer;
l: longint;
begin
sKey:=LabelKeyCaption;
l:=pos('\',LabelKeyCaption);
if l>0 then
delete(sKey,1,l);
if sKey[Length(sKey)]='\' then
SetLength(sKey,Length(sKey)-1);
slKeys:=TStringList.Create;
slKeys.Delimiter:=';';
slKeys.DelimitedText:=EditKey;
slNames:=TStringList.Create;
slNames.Delimiter:=';';
slNames.DelimitedText:=LabeledEditName;
slValues:=TStringList.Create;
slValues.Delimiter:=';';
slValues.DelimitedText:=LabeledEditValue;
for k:=0 to slKeys.Count-1 do
if TestKey(sKey+'\'+slKeys[k]) then
begin
sValueNames:='';
for n:=0 to slNames.Count-1 do
for v:=0 to slValues.Count-1 do
begin
s:=Format('%d%d%d_%s',[k,n,v,slNames[n]]);
if sValueNames='' then
sValueNames:=s
else
sValueNames:=sValueNames+slNames.Delimiter+s;
TestValue(s,slValues[v]);
end;
TestGetValueNames(reg.CurrentPath,sValueNames);
end;
TestGetKeyNames(sKey,slKeys.DelimitedText);
reg.CloseKey;
slKeys.Free;
slNames.Free;
slValues.Free;
end;
Procedure WN;
Var
F : Text;
begin
Assign(F,'names.txt');
Rewrite(F);
Writeln(F,EditKey);
Writeln(F,labeledEditName);
Writeln(F,LabeledEditValue);
Writeln(F,LabelKeyCaption);
Close(F);
end;
begin
defaultsystemcodepage:=CP_UTF8;
if (ParamStr(1)='-s') then
WN;
reg:=TRegistry.Create;
reg.lazywrite:=false;
Results:=TStringList.Create;
Test;
Reg.Free;
if (ParamStr(1)='-s') then
Results.SaveToFile('result.txt');
Writeln(Results.Text);
Results.Free;
{$IFDEF WINDOWS}Readln;{$ENDIF}
end.

49
packages/fcl-registry/src/registry.pp
View File

@ -383,30 +383,31 @@ function TRegistry.ReadString(const Name: string): string;
Var
Info : TRegDataInfo;
ReadDataSize: Integer;
u: UnicodeString;
begin
Result:='';
GetDataInfo(Name,Info);
if info.datasize>0 then
begin
if Not (Info.RegData in [rdString,rdExpandString]) then
Raise ERegistryException.CreateFmt(SInvalidRegType, [Name]);
if Odd(Info.DataSize) then
SetLength(u,round((Info.DataSize+1)/SizeOf(UnicodeChar)))
else
SetLength(u,round(Info.DataSize/SizeOf(UnicodeChar)));
ReadDataSize := GetData(Name,@u[1],Info.DataSize,Info.RegData);
if ReadDataSize > 0 then
begin
If Not (Info.RegData in [rdString,rdExpandString]) then
Raise ERegistryException.CreateFmt(SInvalidRegType, [Name]);
SetLength(Result,Info.DataSize);
ReadDataSize := GetData(Name,PChar(Result),Info.DataSize,Info.RegData);
if ReadDataSize > 0 then
begin
// If the data has the REG_SZ, REG_MULTI_SZ or REG_EXPAND_SZ type,
// the size includes any terminating null character or characters
// unless the data was stored without them! (RegQueryValueEx @ MSDN)
if StringSizeIncludesNull then
if Result[ReadDataSize] = #0 then
Dec(ReadDataSize);
SetLength(Result, ReadDataSize);
end
else
Result := '';
end
else
result:='';
// If the data has the REG_SZ, REG_MULTI_SZ or REG_EXPAND_SZ type,
// the size includes any terminating null character or characters
// unless the data was stored without them! (RegQueryValueEx @ MSDN)
if StringSizeIncludesNull and
(u[Length(u)] = WideChar(0)) then
SetLength(u,Length(u)-1);
Result:=UTF8Encode(u);
end;
end;
end;
function TRegistry.ReadTime(const Name: string): TDateTime;
@ -449,9 +450,12 @@ begin
end;
procedure TRegistry.WriteExpandString(const Name, Value: string);
var
u: UnicodeString;
begin
PutData(Name, PChar(Value), Length(Value),rdExpandString);
u:=UTF8Decode(Value);
PutData(Name, PWideChar(u), ByteLength(u), rdExpandString);
end;
procedure TRegistry.WriteFloat(const Name: string; Value: Double);
@ -465,9 +469,12 @@ begin
end;
procedure TRegistry.WriteString(const Name, Value: string);
var
u: UnicodeString;
begin
PutData(Name, PChar(Value), Length(Value), rdString);
u:=UTF8Decode(Value);
PutData(Name, PWideChar(u), ByteLength(u), rdString);
end;
procedure TRegistry.MoveKey(const OldName, NewName: string; Delete: Boolean);

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

@ -40,23 +40,23 @@ end;
function TRegistry.sysCreateKey(const Key: String): Boolean;
Var
P: PChar;
u: UnicodeString;
Disposition: Dword;
Handle: HKEY;
SecurityAttributes: Pointer; //LPSECURITY_ATTRIBUTES;
begin
SecurityAttributes := Nil;
P:=PrepKey(Key);
FLastError:=RegCreateKeyExA(GetBaseKey(RelativeKey(Key)),
P,
0,
'',
REG_OPTION_NON_VOLATILE,
KEY_ALL_ACCESS,
SecurityAttributes,
Handle,
@Disposition);
u:=UTF8Decode(PrepKey(Key));
FLastError:=RegCreateKeyExW(GetBaseKey(RelativeKey(Key)),
PWideChar(u),
0,
'',
REG_OPTION_NON_VOLATILE,
KEY_ALL_ACCESS,
SecurityAttributes,
Handle,
@Disposition);
Result:=FLastError=ERROR_SUCCESS;
RegCloseKey(Handle);
end;
@ -64,28 +64,28 @@ end;
function TRegistry.DeleteKey(const Key: String): Boolean;
Var
P: PChar;
u: UnicodeString;
begin
P:=PRepKey(Key);
FLastError:=RegDeleteKeyA(GetBaseKey(RelativeKey(Key)),P);
u:=UTF8Decode(PRepKey(Key));
FLastError:=RegDeleteKeyW(GetBaseKey(RelativeKey(Key)),PWideChar(u));
Result:=FLastError=ERROR_SUCCESS;
end;
function TRegistry.DeleteValue(const Name: String): Boolean;
begin
FLastError:= RegDeleteValueA(fCurrentKey, @Name[1]);
FLastError:= RegDeleteValueW(fCurrentKey, PWideChar(UTF8Decode(Name)));
Result:=FLastError=ERROR_SUCCESS;
end;
function TRegistry.SysGetData(const Name: String; Buffer: Pointer;
BufSize: Integer; Out RegData: TRegDataType): Integer;
Var
P: PChar;
u: UnicodeString;
RD : DWord;
begin
P := PChar(Name);
FLastError:=RegQueryValueExA(fCurrentKey,P,Nil,
u := UTF8Decode(Name);
FLastError:=RegQueryValueExW(fCurrentKey,PWideChar(u),Nil,
@RD,Buffer,lpdword(@BufSize));
if (FLastError<>ERROR_SUCCESS) Then
Result:=-1
@ -108,13 +108,13 @@ end;
function TRegistry.GetDataInfo(const ValueName: String; out Value: TRegDataInfo): Boolean;
Var
P: PChar;
u: UnicodeString;
begin
P:=PChar(ValueName);
u:=UTF8Decode(ValueName);
With Value do
begin
FLastError:=RegQueryValueExA(fCurrentKey,P,Nil,lpdword(@RegData),Nil,lpdword(@DataSize));
FLastError:=RegQueryValueExW(fCurrentKey,PWideChar(u),Nil,lpdword(@RegData),Nil,lpdword(@DataSize));
Result:=FLastError=ERROR_SUCCESS;
end;
If Not Result Then
@ -128,6 +128,9 @@ end;
function TRegistry.GetKey(const Key: String): HKEY;
var
S : string;
{$ifndef WinCE}
u : UnicodeString;
{$endif}
Rel : Boolean;
begin
Result:=0;
@ -138,7 +141,8 @@ begin
{$ifdef WinCE}
FLastError:=RegOpenKeyEx(GetBaseKey(Rel),PWideChar(WideString(S)),0,FAccess,Result);
{$else WinCE}
FLastError:=RegOpenKeyEx(GetBaseKey(Rel),PChar(S),0,FAccess,Result);
u:=UTF8Decode(S);
FLastError:=RegOpenKeyExW(GetBaseKey(Rel),PWideChar(u),0,FAccess,Result);
{$endif WinCE}
end;
@ -195,19 +199,18 @@ end;
function TRegistry.OpenKey(const Key: string; CanCreate: Boolean): Boolean;
Var
P: PChar;
u: UnicodeString;
Handle: HKEY;
Disposition: Integer;
SecurityAttributes: Pointer; //LPSECURITY_ATTRIBUTES;
S: string;
begin
SecurityAttributes := Nil;
P:=PrepKey(Key);
u:=UTF8Decode(PrepKey(Key));
If CanCreate then
begin
Handle:=0;
FLastError:=RegCreateKeyExA(GetBaseKey(RelativeKey(Key)),P,0,'',
FLastError:=RegCreateKeyExW(GetBaseKey(RelativeKey(Key)),PWideChar(u),0,'',
REG_OPTION_NON_VOLATILE,
fAccess,SecurityAttributes,Handle,
pdword(@Disposition));
@ -215,15 +218,15 @@ begin
end
else
begin
FLastError:=RegOpenKeyExA(GetBaseKey(RelativeKey(Key)),
P,0,fAccess,Handle);
FLastError:=RegOpenKeyExW(GetBaseKey(RelativeKey(Key)),
PWideChar(u),0,fAccess,Handle);
Result:=FLastError=ERROR_SUCCESS;
end;
If Result then begin
if RelativeKey(Key) then
S:=CurrentPath + Key
else
S:=P;
S:=UTF8Encode(u);
ChangeKey(Handle, S);
end;
end;
@ -251,7 +254,7 @@ begin
{$ifdef WinCE}
Result:=False;
{$else}
FLastError:=RegConnectRegistryA(PChar(UNCName),RootKey,newroot);
FLastError:=RegConnectRegistryW(PWideChar(UTF8Decode(UNCName)),RootKey,newroot);
Result:=FLastError=ERROR_SUCCESS;
if Result then begin
RootKey:=newroot;
@ -316,64 +319,95 @@ end;
procedure TRegistry.GetKeyNames(Strings: TStrings);
Var
L : Cardinal;
I: Integer;
Info: TRegKeyInfo;
P : PChar;
var
Info: TRegKeyInfo;
dwLen: DWORD;
lpName: LPWSTR;
dwIndex: DWORD;
lResult: LONGINT;
s: string;
begin
Strings.Clear;
if GetKeyInfo(Info) then
begin
L:=Info.MaxSubKeyLen+1;
GetMem(P,L);
Try
for I:=0 to Info.NumSubKeys-1 do
begin
L:=Info.MaxSubKeyLen+1;
RegEnumKeyExA(CurrentKey,I,P,L,Nil,Nil,Nil,Nil);
Strings.Add(StrPas(P));
end;
Finally
FreeMem(P);
end;
end;
Strings.Clear;
if GetKeyInfo(Info) then
begin
dwLen:=Info.MaxSubKeyLen+1;
GetMem(lpName,dwLen*SizeOf(WideChar));
try
for dwIndex:=0 to Info.NumSubKeys-1 do
begin
dwLen:=Info.MaxSubKeyLen+1;
lResult:=RegEnumKeyExW(CurrentKey,dwIndex,lpName,dwLen,Nil,Nil,Nil,Nil);
if lResult<>ERROR_SUCCESS then
raise ERegistryException.Create(SysErrorMessage(lResult));
if dwLen=0 then
s:=''
else
begin // dwLen>0
SetLength(s,dwLen*3);
dwLen:=UnicodeToUTF8(PChar(s),Length(s)+1,lpName,dwLen);
if dwLen<=1 then
s:=''
else // dwLen>1
SetLength(s,dwLen-1);
end; // if dwLen=0
Strings.Add(s);
end; // for dwIndex:=0 ...
finally
FreeMem(lpName);
end;
end;
end;
procedure TRegistry.GetValueNames(Strings: TStrings);
Var
L : Cardinal;
I: Integer;
Info: TRegKeyInfo;
P : PChar;
var
Info: TRegKeyInfo;
dwLen: DWORD;
lpName: LPWSTR;
dwIndex: DWORD;
lResult: LONGINT;
s: string;
begin
Strings.Clear;
if GetKeyInfo(Info) then
begin
L:=Info.MaxValueLen+1;
GetMem(P,L);
Try
for I:=0 to Info.NumValues-1 do
begin
L:=Info.MaxValueLen+1;
RegEnumValueA(CurrentKey,I,P,L,Nil,Nil,Nil,Nil);
Strings.Add(StrPas(P));
end;
Finally
FreeMem(P);
end;
end;
if GetKeyInfo(Info) then
begin
dwLen:=Info.MaxValueLen+1;
GetMem(lpName,dwLen*SizeOf(WideChar));
try
for dwIndex:=0 to Info.NumValues-1 do
begin
dwLen:=Info.MaxValueLen+1;
lResult:=RegEnumValueW(CurrentKey,dwIndex,lpName,dwLen,Nil,Nil,Nil,Nil);
if lResult<>ERROR_SUCCESS then
raise ERegistryException.Create(SysErrorMessage(lResult));
if dwLen=0 then
s:=''
else
begin // dwLen>0
SetLength(s,dwLen*3);
dwLen:=UnicodeToUTF8(PChar(s),Length(s)+1,lpName,dwLen);
if dwLen<=1 then
s:=''
else // dwLen>1
SetLength(s,dwLen-1);
end; // if dwLen=0
Strings.Add(s);
end; // for dwIndex:=0 ...
finally
FreeMem(lpName);
end;
end;
end;
Function TRegistry.SysPutData(const Name: string; Buffer: Pointer;
BufSize: Integer; RegData: TRegDataType) : Boolean;
Var
P: PChar;
u: UnicodeString;
RegDataType: DWORD;
begin
@ -384,8 +418,8 @@ begin
rdInteger : RegDataType:=REG_DWORD;
rdBinary : RegDataType:=REG_BINARY;
end;
P:=PChar(Name);
FLastError:=RegSetValueExA(fCurrentKey,P,0,RegDataType,Buffer,BufSize);
u:=UTF8Decode(Name);
FLastError:=RegSetValueExW(fCurrentKey,PWideChar(u),0,RegDataType,Buffer,BufSize);
Result:=FLastError=ERROR_SUCCESS;
end;

80
packages/fcl-registry/src/xmlreg.pp
View File

@ -39,6 +39,8 @@ Type
FCurrentKey : String;
Procedure SetFileName(Value : String);
Protected
function DoGetValueData(Name: String; out DataType: TDataType; Var Data; Var DataSize: Integer; IsUnicode: Boolean): Boolean; virtual;
function DoSetValueData(Name: String; DataType: TDataType; const Data; DataSize: Integer; IsUnicode: Boolean): Boolean; virtual;
Procedure LoadFromStream(S : TStream);
Function NormalizeKey(KeyPath : String) : String;
Procedure CreateEmptyDoc;
@ -61,7 +63,7 @@ Type
Function CreateKey(KeyPath : String) : Boolean;
Function GetValueSize(Name : String) : Integer;
Function GetValueType(Name : String) : TDataType;
Function GetValueInfo(Name : String; Out Info : TDataInfo) : Boolean;
Function GetValueInfo(Name : String; Out Info : TDataInfo; AsUnicode : Boolean = False) : Boolean;
Function GetKeyInfo(Out Info : TKeyInfo) : Boolean;
Function EnumSubKeys(List : TStrings) : Integer;
Function EnumValues(List : TStrings) : Integer;
@ -73,6 +75,9 @@ Type
Procedure Load;
Function GetValueData(Name : String; Out DataType : TDataType; Var Data; Var DataSize : Integer) : Boolean;
Function SetValueData(Name : String; DataType : TDataType; Const Data; DataSize : Integer) : Boolean;
// These interpret the Data buffer as unicode data
Function GetValueDataUnicode(Name : String; Out DataType : TDataType; Var Data; Var DataSize : Integer) : Boolean;
Function SetValueDataUnicode(Name : String; DataType : TDataType; Const Data; DataSize : Integer) : Boolean;
Property FileName : String Read FFileName Write SetFileName;
Property RootKey : String Read FRootKey Write SetRootkey;
Property AutoFlush : Boolean Read FAutoFlush Write FAutoFlush;
@ -285,7 +290,7 @@ begin
MaybeFlush;
end;
Function TXmlRegistry.GetValueData(Name : String; Out DataType : TDataType; Var Data; Var DataSize : Integer) : Boolean;
Function TXmlRegistry.DoGetValueData(Name : String; Out DataType : TDataType; Var Data; Var DataSize : Integer; IsUnicode : Boolean) : Boolean;
Type
PCardinal = ^Cardinal;
@ -295,6 +300,7 @@ Var
DataNode : TDomNode;
BL,ND,NS : Integer;
S : UTF8String;
U : UnicodeString;
HasData: Boolean;
D : DWord;
@ -321,11 +327,22 @@ begin
dtString : // DataNode is optional
if HasData then
begin
S:=UTF8Encode(DataNode.NodeValue); // Convert to ansistring
NS:=Length(S);
Result:=(DataSize>=NS);
if Result then
Move(S[1],Data,NS);
if not IsUnicode then
begin
S:=UTF8Encode(DataNode.NodeValue); // Convert to ansistring
NS:=Length(S);
Result:=(DataSize>=NS);
if Result then
Move(S[1],Data,NS);
end
else
begin
U:=DataNode.NodeValue;
NS:=Length(U)*SizeOf(UnicodeChar);
Result:=(DataSize>=NS);
if Result then
Move(U[1],Data,NS);
end
end;
dtBinary : // DataNode is optional
@ -345,7 +362,7 @@ begin
end;
end;
Function TXmlRegistry.SetValueData(Name : String; DataType : TDataType; Const Data; DataSize : Integer) : Boolean;
Function TXmlRegistry.DoSetValueData(Name : String; DataType : TDataType; Const Data; DataSize : Integer; IsUnicode : Boolean) : Boolean;
Type
PCardinal = ^Cardinal;
@ -353,7 +370,8 @@ Type
Var
Node : TDomElement;
DataNode : TDomNode;
SW : Widestring;
SW : UnicodeString;
begin
Node:=FindValueKey(Name);
If Node=Nil then
@ -367,7 +385,10 @@ begin
Case DataType of
dtDWORD : SW:=IntToStr(PCardinal(@Data)^);
dtString : begin
SW:=WideString(PAnsiChar(@Data));
if IsUnicode then
SW:=UnicodeString(PUnicodeChar(@Data))
else
SW:=UnicodeString(PAnsiChar(@Data));
//S:=UTF8Encode(SW);
end;
dtBinary : SW:=BufToHex(Data,DataSize);
@ -393,6 +414,28 @@ begin
end;
end;
Function TXmlRegistry.SetValueData(Name : String; DataType : TDataType; Const Data; DataSize : Integer) : Boolean;
begin
Result:=DoSetValueData(Name,DataType,Data,DataSize,False);
end;
Function TXmlRegistry.GetValueData(Name : String; Out DataType : TDataType; Var Data; Var DataSize : Integer) : Boolean;
begin
Result:=DoGetValueData(Name,DataType,Data,DataSize,False);
end;
function TXmlRegistry.GetValueDataUnicode(Name: String; out DataType: TDataType; Var Data; Var DataSize: Integer): Boolean;
begin
Result:=DoGetValueData(Name,DataType,Data,DataSize,True);
end;
function TXmlRegistry.SetValueDataUnicode(Name: String; DataType: TDataType; const Data; DataSize: Integer): Boolean;
begin
Result:=DoSetValueData(Name,DataType,Data,DataSize,True)
end;
Function TXmlRegistry.FindSubKey (S : String; N : TDomElement) : TDomElement;
Var
@ -607,7 +650,7 @@ begin
Result:=dtUnknown;
end;
Function TXMLRegistry.GetValueInfo(Name : String; Out Info : TDataInfo) : Boolean;
function TXmlRegistry.GetValueInfo(Name: String; out Info: TDataInfo; AsUnicode: Boolean): Boolean;
Var
N : TDomElement;
@ -620,10 +663,17 @@ begin
If Result then
begin
DN:=N.FirstChild;
if Assigned(DN) and (DN.NodeType=TEXT_NODE) then begin
S := UTF8Encode(DN.NodeValue);
L:=Length(S);
end else
if Assigned(DN) and (DN.NodeType=TEXT_NODE) then
begin
if AsUnicode then
L:=Length(DN.NodeValue)*SizeOf(UnicodeChar)
else
begin
S := UTF8Encode(DN.NodeValue);
L:=Length(S);
end
end
else
L:=0;
With Info do
begin

6
packages/fcl-registry/src/xregreg.inc
View File

@ -124,7 +124,7 @@ Var
DataType : TDataType;
begin
Result:=BufSize;
If TXmlregistry(FSysData).GetValueData(Name,DataType,Buffer^,Result) then
If TXmlregistry(FSysData).GetValueDataUnicode(Name,DataType,Buffer^,Result) then
begin
Case DataType of
dtUnknown : RegData:=rdUnknown;
@ -144,7 +144,7 @@ Var
Info : TDataInfo;
begin
Result := TXmlRegistry(FSysData).GetValueInfo(ValueName,Info);
Result := TXmlRegistry(FSysData).GetValueInfo(ValueName,Info,True);
If Not Result then
With Value do
begin
@ -270,7 +270,7 @@ begin
rdInteger : DataType := dtDword;
rdBinary : DataType := dtBinary;
end;
Result:=TXMLRegistry(FSysData).SetValueData(Name,DataType,Buffer^,BufSize);
Result:=TXMLRegistry(FSysData).SetValueDataUnicode(Name,DataType,Buffer^,BufSize);
end;
procedure TRegistry.RenameValue(const OldName, NewName: string);