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

* Fix bug ID #31385

Browse Source 
git-svn-id: trunk@42974 -
This commit is contained in:
michael 2019-09-11 07:40:44 +00:00
parent fa2e751f9f
commit fbe36d91da
3 changed files with 61 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
packages/fcl-db/src/memds/memds.pp
View File

@ -464,9 +464,9 @@ var
begin
FD := FieldDefs.Items[FieldNo-1];
case FD.DataType of
ftString,
ftGuid: result:=FD.Size+1;
ftFixedChar:result:=FD.Size+1;
ftString : Result:=FD.Size*FD.CharSize+1;
ftGuid: result:=FD.Size+1;
ftFixedChar:result:=FD.Size*FD.CharSize+1;
ftBoolean: result:=SizeOf(Wordbool);
ftCurrency,
ftFloat: result:=SizeOf(Double);
@ -1037,7 +1037,7 @@ end;
procedure TMemDataset.calcrecordlayout;
var
i,Count : integer;
i,Count,aSize : integer;
begin
Count := FieldDefs.Count;
// Avoid mem-leak if CreateTable is called twice
@ -1057,8 +1057,9 @@ begin
for i:= 0 to Count-1 do
begin
GetIntegerPointer(FFieldOffsets, i)^ := FRecSize;
GetIntegerPointer(FFieldSizes, i)^ := MDSGetBufferSize(i+1);
FRecSize:= FRecSize+GetIntegerPointer(FFieldSizes, i)^;
aSize:=MDSGetBufferSize(i+1);
GetIntegerPointer(FFieldSizes, i)^ := aSize;
FRecSize:= FRecSize+aSize;
end;
FRecInfoOffset:=FRecSize;
FRecSize:=FRecSize+SizeRecInfo;
@ -1220,7 +1221,8 @@ var
AKeyValues: variant;
i: integer;
AField: TField;
s1,s2: string;
s1,s2: UTF8String;
begin
Result := false;
SaveState := SetTempState(dsFilter);
@ -1259,8 +1261,16 @@ begin
// string fields
if AField.DataType in [ftString, ftFixedChar] then
begin
s1 := AField.AsString;
s2 := VarToStr(AKeyValues[i]);
if TStringField(AField).CodePage=CP_UTF8 then
begin
s1 := AField.AsUTF8String;
s2 := UTF8Encode(VarToUnicodeStr(AKeyValues[i]));
end
else
begin
s1 := AField.AsString;
s2 := VarToStr(AKeyValues[i]);
end;
if loPartialKey in Options then
s1 := copy(s1, 1, length(s2));
if loCaseInsensitive in Options then

3
packages/fcl-db/tests/dbtestframework.pas
View File

@ -7,6 +7,9 @@ program dbtestframework;
{$APPTYPE CONSOLE}
uses
{$ifdef unix}
cwstring,
{$endif}
SysUtils,
fpcunit, testreport, testregistry,
DigestTestReport,

39
packages/fcl-db/tests/testspecifictmemdataset.pas
View File

@ -5,6 +5,7 @@ unit TestSpecificTMemDataSet;
}
{$mode objfpc}{$H+}
{$codepage UTF8}
interface
@ -25,6 +26,7 @@ type
procedure TestFileName;
procedure TestCopyFromDataset; //is copied dataset identical to original?
procedure TestCopyFromDatasetMoved; //move record then copy. Is copy identical? Has record position changed?
Procedure TestLocateUTF8;
end;
implementation
@ -128,6 +130,43 @@ begin
CheckEquals(CurrentID,NewID,'Mismatch between ID field contents - the record has moved.');
end;
procedure TTestSpecificTMemDataset.TestLocateUTF8;
Var
MemDataset1: TMemDataset;
S : UTF8String;
begin
MemDataset1:=TMemDataset.Create(Nil);
With MemDataset1 do
try
FieldDefs.Add('first',ftString,40,0,true,False,1,cp_UTF8);
FieldDefs.Add('second',ftString,40,0,true,False,2,cp_ACP);
CreateTable;
Active:=True;
Append;
Fields[0].AsUTF8String:='♯abcd';
Fields[1].AsString:='native';
Post;
Append;
Fields[0].AsUTF8String:='défaut';
Fields[1].AsString:='morenative';
Post;
First;
While not eof do
begin
S:=fields[0].AsUTF8String;
Writeln(S);
next;
end;
First;
AssertTrue('UTF8 1 ok',Locate('first','♯abcd',[]));
AssertTrue('UTF8 2 ok',Locate('first','défaut',[]));
AssertTrue('ANSI 1 ok',Locate('second','native',[]));
AssertTrue('ANSI 1 ok',Locate('second','morenative',[]));
finally
Free;
end;
end;
initialization