Merged revision(s) 45409, 46897-46898, 47007, 47011, 47065, 47084 from trunk:

* fix for Mantis #37042: apply patch and test (adjusted for Big Endian) by Bi0T1N to add support for TBitConverter
........
* avoid range check error when using SwapEndian with 16-bit constants
+ added test
........
* readd SmallInt typecasts to SmallInt overload of SwapEndian
........
* when removing a method from the synchronization queue using TThread.RemoveQueuedEvent then both the Code and the Data need to match (Delphi does the same)
+ added test
........
* simplify TThread.RemoveQueuedEvent - decide what to delete and not what to leave (better corresponds with the docs)
........
+ add ability to specify a SQLite VFS when opening a SQLite database
........
* fix test: TThread.WaitFor calls CheckSynchronize as well, so the thread needs to signal when it's done with removing entries from the queue
........

git-svn-id: branches/fixes_3_2@47782 -
This commit is contained in:
svenbarth 2020-12-15 22:31:59 +00:00
parent 8a249b2d74
commit 432fcd52bc
10 changed files with 584 additions and 37 deletions

3
.gitattributes vendored
View File

@ -12931,6 +12931,8 @@ tests/tbs/tb0665.pp svneol=native#text/pascal
tests/tbs/tb0666a.pp svneol=native#text/pascal
tests/tbs/tb0666b.pp svneol=native#text/pascal
tests/tbs/tb0669.pp svneol=native#text/pascal
tests/tbs/tb0676.pp svneol=native#text/pascal
tests/tbs/tb0678.pp svneol=native#text/pascal
tests/tbs/tb205.pp svneol=native#text/plain
tests/tbs/tb610.pp svneol=native#text/pascal
tests/tbs/tb613.pp svneol=native#text/plain
@ -15567,6 +15569,7 @@ tests/test/units/sysutils/tunifile.pp svneol=native#text/plain
tests/test/units/sysutils/tuplow.pp svneol=native#text/plain
tests/test/units/sysutils/twstralloc.pp svneol=native#text/plain
tests/test/units/sysutils/twstrcmp.pp svneol=native#text/plain
tests/test/units/types/ttbitconverter.pp svneol=native#text/pascal
tests/test/units/ucomplex/tcsqr1.pp svneol=native#text/pascal
tests/test/units/variants/tcustomvariant.pp svneol=native#text/plain
tests/test/units/variants/tvararrayofintf.pp svneol=native#text/plain

View File

@ -44,7 +44,6 @@ type
TArrayStringArray = Array of TStringArray;
PArrayStringArray = ^TArrayStringArray;
// VFS not supported at this time.
// Do not change the order. See NativeFlags constant in GetSQLiteOpenFlags.
TSQLiteOpenFlag = (
@ -69,8 +68,10 @@ Type
private
fhandle: psqlite3;
FOpenFlags: TSQLiteOpenFlags;
FVFS: String;
function GetSQLiteOpenFlags: Integer;
procedure SetOpenFlags(AValue: TSQLiteOpenFlags);
procedure SetVFS(const AValue: String);
protected
procedure DoInternalConnect; override;
procedure DoInternalDisconnect; override;
@ -125,6 +126,7 @@ Type
procedure LoadExtension(const LibraryFile: string);
Published
Property OpenFlags : TSQLiteOpenFlags Read FOpenFlags Write SetOpenFlags default DefaultOpenFlags;
Property VFS : String Read FVFS Write SetVFS;
Property AlwaysUseBigint : Boolean Read GetAlwaysUseBigint Write SetAlwaysUseBigint;
end;
@ -857,16 +859,28 @@ begin
FOpenFlags:=AValue;
end;
procedure TSQLite3Connection.SetVFS(const AValue: String);
begin
if FVFS=AValue then Exit;
CheckDisConnected;
FVFS:=AValue;
end;
procedure TSQLite3Connection.DoInternalConnect;
var
filename: ansistring;
pvfs: PChar;
begin
Inherited;
if DatabaseName = '' then
DatabaseError(SErrNoDatabaseName,self);
InitializeSQLite;
filename := DatabaseName;
checkerror(sqlite3_open_v2(PAnsiChar(filename),@fhandle,GetSQLiteOpenFlags,Nil));
if FVFS <> '' then
pvfs := PAnsiChar(FVFS)
else
pvfs := Nil;
checkerror(sqlite3_open_v2(PAnsiChar(filename),@fhandle,GetSQLiteOpenFlags,pvfs));
if (Length(Password)>0) and assigned(sqlite3_key) then
checkerror(sqlite3_key(fhandle,PChar(Password),StrLen(PChar(Password))));
if Params.IndexOfName('foreign_keys') <> -1 then

View File

@ -1134,13 +1134,13 @@ function SwapEndian(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inlin
{ is turned into "longint(AValue) shr 8", so if AValue < 0 then }
{ the sign bits from the upper 16 bits are shifted in rather than }
{ zeroes. }
Result := SmallInt((Word(AValue) shr 8) or (Word(AValue) shl 8));
Result := SmallInt(((Word(AValue) shr 8) or (Word(AValue) shl 8)) and $ffff);
end;
function SwapEndian(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result := Word((AValue shr 8) or (AValue shl 8));
Result := ((AValue shr 8) or (AValue shl 8)) and $ffff;
end;
(*

View File

@ -2643,13 +2643,13 @@ function SwapEndian(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inlin
{ is turned into "longint(AValue) shr 8", so if AValue < 0 then }
{ the sign bits from the upper 16 bits are shifted in rather than }
{ zeroes. }
Result := SmallInt((Word(AValue) shr 8) or (Word(AValue) shl 8));
Result := SmallInt(((Word(AValue) shr 8) or (Word(AValue) shl 8)) and $ffff);
end;
{$ifndef cpujvm}
function SwapEndian(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result := Word((AValue shr 8) or (AValue shl 8));
Result := ((AValue shr 8) or (AValue shl 8)) and $ffff;
end;
{$endif}

View File

@ -596,38 +596,35 @@ begin
lastentry := Nil;
entry := ThreadQueueHead;
while Assigned(entry) do begin
{ first check for the thread }
if Assigned(aThread) and (entry^.Thread <> aThread) and (entry^.ThreadID <> aThread.ThreadID) then begin
if
{ only entries not added by Synchronize }
not Assigned(entry^.SyncEvent)
{ check for the thread }
and (not Assigned(aThread) or (entry^.Thread = aThread) or (entry^.ThreadID = aThread.ThreadID))
{ check for the method }
and (not Assigned(aMethod) or
(
(TMethod(entry^.Method).Code = TMethod(aMethod).Code) and
(TMethod(entry^.Method).Data = TMethod(aMethod).Data)
))
then begin
{ ok, we need to remove this entry }
tmpentry := entry;
if Assigned(lastentry) then
lastentry^.Next := entry^.Next;
entry := entry^.Next;
if ThreadQueueHead = tmpentry then
ThreadQueueHead := entry;
if ThreadQueueTail = tmpentry then
ThreadQueueTail := lastentry;
{ only dispose events added by Queue }
if not Assigned(tmpentry^.SyncEvent) then
Dispose(tmpentry);
end else begin
{ leave this entry }
lastentry := entry;
entry := entry^.Next;
Continue;
end;
{ then check for the method }
if Assigned(aMethod) and (entry^.Method <> aMethod) then begin
lastentry := entry;
entry := entry^.Next;
Continue;
end;
{ skip entries added by Synchronize }
if Assigned(entry^.SyncEvent) then begin
lastentry := entry;
entry := entry^.Next;
Continue;
end;
{ ok, we need to remove this entry }
tmpentry := entry;
if Assigned(lastentry) then
lastentry^.Next := entry^.Next;
entry := entry^.Next;
if ThreadQueueHead = tmpentry then
ThreadQueueHead := entry;
if ThreadQueueTail = tmpentry then
ThreadQueueTail := lastentry;
{ only dispose events added by Queue }
if not Assigned(tmpentry^.SyncEvent) then
Dispose(tmpentry);
end;
{$ifdef FPC_HAS_FEATURE_THREADING}
finally

View File

@ -341,6 +341,16 @@ function InflateRect(var Rect: TRect; dx: Integer; dy: Integer): Boolean;
function Size(AWidth, AHeight: Integer): TSize; inline;
function Size(const ARect: TRect): TSize;
{$ifndef VER3_0}
type
TBitConverter = class
generic class procedure UnsafeFrom<T>(const ASrcValue: T; var ADestination: Array of Byte; AOffset: Integer = 0); static; {inline;}
generic class procedure From<T>(const ASrcValue: T; var ADestination: Array of Byte; AOffset: Integer = 0); static;
generic class function UnsafeInTo<T>(const ASource: Array of Byte; AOffset: Integer = 0): T; static; {inline;}
generic class function InTo<T>(const ASource: Array of Byte; AOffset: Integer = 0): T; static;
end;
{$endif}
implementation
Uses Math;
@ -712,4 +722,44 @@ begin
bottom:=bottom+dy; top:=top+dy;
end;
{$ifndef VER3_0}
generic class procedure TBitConverter.UnsafeFrom<T>(const ASrcValue: T; var ADestination: Array of Byte; AOffset: Integer = 0);
begin
move(ASrcValue, ADestination[AOffset], SizeOf(T));
end;
generic class procedure TBitConverter.From<T>(const ASrcValue: T; var ADestination: Array of Byte; AOffset: Integer = 0);
begin
if AOffset < 0 then
System.Error(reRangeError);
if IsManagedType(T) then
System.Error(reInvalidCast);
if Length(ADestination) < (SizeOf(T) + AOffset) then
System.Error(reRangeError);
TBitConverter.specialize UnsafeFrom<T>(ASrcValue, ADestination, AOffset);
end;
generic class function TBitConverter.UnsafeInTo<T>(const ASource: Array of Byte; AOffset: Integer = 0): T;
begin
move(ASource[AOffset], Result, SizeOf(T));
end;
generic class function TBitConverter.InTo<T>(const ASource: Array of Byte; AOffset: Integer = 0): T;
begin
if AOffset < 0 then
System.Error(reRangeError);
if IsManagedType(T) then
System.Error(reInvalidCast);
if Length(ASource) < (SizeOf(T) + AOffset) then
System.Error(reRangeError);
Result := TBitConverter.specialize UnsafeInTo<T>(ASource, AOffset);
end;
{$endif}
end.

View File

@ -1014,13 +1014,13 @@ function SwapEndian(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inlin
{ is turned into "longint(AValue) shr 8", so if AValue < 0 then }
{ the sign bits from the upper 16 bits are shifted in rather than }
{ zeroes. }
Result := SmallInt((Word(AValue) shr 8) or (Word(AValue) shl 8));
Result := SmallInt(((Word(AValue) shr 8) or (Word(AValue) shl 8)) and $ffff);
end;
function SwapEndian(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result := Word((AValue shr 8) or (AValue shl 8));
Result := ((AValue shr 8) or (AValue shl 8)) and $ffff;
end;

14
tests/tbs/tb0676.pp Normal file
View File

@ -0,0 +1,14 @@
{ %NORUN }
program tb0676;
{$warn 4110 error}
begin
SwapEndian(UInt16($1234));
SwapEndian(Int16($8765));
SwapEndian(UInt32($12345678));
SwapEndian(Int32($87654321));
SwapEndian(UInt64($1234567887654321));
SwapEndian(Int64($8765432112345678));
end.

80
tests/tbs/tb0678.pp Normal file
View File

@ -0,0 +1,80 @@
{%skiptarget=$nothread }
program tqueue;
{$mode objfpc}
uses
{$ifdef unix}
cthreads,
{$endif}
SysUtils, Classes;
type
TTest = class
procedure DoTest;
end;
TTestThread = class(TThread)
protected
procedure Execute; override;
end;
var
count: LongInt = 0;
procedure TTest.DoTest;
begin
Inc(count);
end;
var
e: PRTLEvent;
t1, t2: TTest;
procedure TTestThread.Execute;
var
method: TMethod;
begin
Queue(@t1.DoTest);
Queue(@t2.DoTest);
{ should remove nothing }
method.Code := @TTest.DoTest;
method.Data := Nil;
RemoveQueuedEvents(TThreadMethod(method));
{ should remove only one }
RemoveQueuedEvents(@t1.DoTest);
RTLEventSetEvent(e);
end;
var
t: TTestThread;
begin
e := Nil;
t := TTestThread.Create(True);
try
e := RTLEventCreate;
t1 := TTest.Create;
t2 := TTest.Create;
t.Start;
RTLEventWaitFor(e);
t.WaitFor;
CheckSynchronize;
if count <> 1 then
Halt(1);
finally
t1.Free;
t2.Free;
t.Free;
RTLEventDestroy(e);
end;
end.

View File

@ -0,0 +1,389 @@
program ttbitconverter;
{$mode Delphi}
uses
SysUtils, Types;
type
TMyRecord = record
Number: Integer;
SmallNumber: Word;
UseIt: Boolean;
end;
TMyPackedRecord = packed record
Number: Integer;
SmallNumber: Word;
UseIt: Boolean;
end;
procedure TestFromInteger;
var
arr: TBytes;
item: Byte;
i: Integer;
begin
i := 0;
SetLength(arr, SizeOf(Integer));
TBitConverter.From<Integer>(NtoLE(Integer(1038)), arr);
for item in arr do
begin
Inc(i);
writeln(i.ToString + ': ' + item.ToString);
end;
if arr[0] <> 14 then halt(1);
if arr[1] <> 4 then halt(1);
if arr[2] <> 0 then halt(1);
if arr[3] <> 0 then halt(1);
writeln('');
end;
procedure TestFromDouble;
var
arr: TBytes;
item: Byte;
i: Integer;
begin
i := 0;
SetLength(arr, SizeOf(Double));
TBitConverter.From<Double>(Double(3.14), arr);
for item in arr do
begin
Inc(i);
writeln(i.ToString + ': ' + item.ToString);
end;
if PDouble(@arr[0])^ <> Double(3.14) then halt(2);
writeln('');
end;
procedure TestFromTMyRecord;
var
arr: TBytes;
item: Byte;
rec: TMyRecord;
i: Integer;
begin
i := 0;
SetLength(arr, SizeOf(TMyRecord));
rec := Default(TMyRecord);
rec.Number := NToLE(LongInt(42));
rec.SmallNumber := NToLE(Word(5));
rec.UseIt := True;
TBitConverter.From<TMyRecord>(rec, arr);
for item in arr do
begin
Inc(i);
writeln(i.ToString + ': ' + item.ToString);
end;
if arr[0] <> 42 then halt(3);
if arr[1] <> 0 then halt(3);
if arr[2] <> 0 then halt(3);
if arr[3] <> 0 then halt(3);
if arr[4] <> 5 then halt(3);
if arr[5] <> 0 then halt(3);
if arr[6] <> 1 then halt(3);
if arr[7] <> 0 then halt(3);
writeln('');
end;
procedure TestFromTMyPackedRecord;
var
arr: TBytes;
item: Byte;
rec: TMyPackedRecord;
i: Integer;
begin
i := 0;
SetLength(arr, SizeOf(TMyPackedRecord));
rec := Default(TMyPackedRecord);
rec.Number := NToLe(Integer(42));
rec.SmallNumber := NToLe(Word(289));
rec.UseIt := True;
TBitConverter.From<TMyPackedRecord>(rec, arr);
for item in arr do
begin
Inc(i);
writeln(i.ToString + ': ' + item.ToString);
end;
if arr[0] <> 42 then halt(4);
if arr[1] <> 0 then halt(4);
if arr[2] <> 0 then halt(4);
if arr[3] <> 0 then halt(4);
if arr[4] <> 33 then halt(4);
if arr[5] <> 1 then halt(4);
if arr[6] <> 1 then halt(4);
writeln('');
end;
procedure TestFromAnsiChar;
var
arr: TBytes;
item: Byte;
c: AnsiChar;
i: Integer;
begin
i := 0;
c := 'A';
SetLength(arr, SizeOf(c));
TBitConverter.From<AnsiChar>(c, arr);
for item in arr do
begin
Inc(i);
writeln(i.ToString + ': ' + item.ToString);
end;
if arr[0] <> 65 then halt(5);
writeln('');
end;
procedure TestFromUnicodeChar;
var
arr: TBytes;
item: Byte;
c: UnicodeChar;
i: Integer;
begin
i := 0;
c := 'A';
SetLength(arr, SizeOf(c));
TBitConverter.From<UnicodeChar>(UnicodeChar(NToLE(Ord(c))), arr);
for item in arr do
begin
Inc(i);
writeln(i.ToString + ': ' + item.ToString);
end;
if arr[0] <> 65 then halt(6);
if arr[1] <> 0 then halt(6);
writeln('');
end;
procedure TestInToInteger;
var
arr: TBytes;
num: Integer;
begin
arr := TArray<Byte>.Create(1, 0, 1, 0);
num := TBitConverter.InTo<Integer>(arr, 0);
num := LEToN(num);
writeln(num.ToString);
if num <> 65537 then halt(7);
writeln('');
end;
procedure TestInToDouble;
var
arr: TBytes;
num: Double;
tmp: Int64;
begin
arr := TArray<Byte>.Create($1C, $C7, $71, $1C, $C7, $71, $BC, $3F);
num := TBitConverter.InTo<Double>(arr, 0);
tmp := LEToN(PInt64(@num)^);
num := PDouble(@tmp)^;
writeln(num.ToString);
if num <> Double(0.1111111111111111111) then halt(8);
writeln('');
end;
procedure TestInToTMyRecord;
var
arr: TBytes;
rec: TMyRecord;
begin
arr := TArray<Byte>.Create(66, 0, 0, 0, 15, 0, 0, 0);
rec := TBitConverter.InTo<TMyRecord>(arr, 0);
rec.Number := LEToN(rec.Number);
rec.SmallNumber := LEToN(rec.SmallNumber);
writeln(rec.Number.ToString);
writeln(rec.SmallNumber.ToString);
writeln(BoolToStr(rec.UseIt, True));
if rec.Number <> 66 then halt(9);
if rec.SmallNumber <> 15 then halt(9);
if rec.UseIt <> False then halt(9);
writeln('');
end;
procedure TestInToTMyPackedRecord;
var
arr: TBytes;
rec: TMyPackedRecord;
begin
arr := TArray<Byte>.Create(255, 1, 0, 0, 15, 0, 1);
rec := TBitConverter.InTo<TMyPackedRecord>(arr, 0);
rec.Number := LEToN(rec.Number);
rec.SmallNumber := LEToN(rec.SmallNumber);
writeln(rec.Number.ToString);
writeln(rec.SmallNumber.ToString);
writeln(BoolToStr(rec.UseIt, True));
if rec.Number <> 511 then halt(10);
if rec.SmallNumber <> 15 then halt(10);
if rec.UseIt <> True then halt(10);
writeln('');
end;
procedure TestInToAnsiChar;
var
arr: TBytes;
c: AnsiChar;
begin
arr := TArray<Byte>.Create(65);
c := TBitConverter.InTo<AnsiChar>(arr, 0);
writeln(c);
if c <> 'A' then halt(11);
writeln('');
end;
procedure TestInToUnicodeChar;
var
arr: TBytes;
c: UnicodeChar;
begin
arr := TArray<Byte>.Create(66, 0);
c := TBitConverter.InTo<UnicodeChar>(arr, 0);
c := UnicodeChar(LEToN(Ord(c)));
writeln(c);
if c <> 'B' then halt(12);
writeln('');
end;
procedure TestFromIntegerOffset;
var
arr: TBytes;
item: Byte;
i: Integer;
begin
i := 0;
SetLength(arr, SizeOf(Integer) + 2);
TBitConverter.From<Integer>(NToLE(Integer(257)), arr, 2);
for item in arr do
begin
Inc(i);
writeln(i.ToString + ': ' + item.ToString);
end;
if arr[0] <> 0 then halt(13);
if arr[1] <> 0 then halt(13);
if arr[2] <> 1 then halt(13);
if arr[3] <> 1 then halt(13);
if arr[4] <> 0 then halt(13);
if arr[5] <> 0 then halt(13);
writeln('');
end;
procedure TestInToIntegerOffset;
var
arr: TBytes;
num: Integer;
begin
arr := TArray<Byte>.Create(2, 0, 2, 0, 1, 0, 2, 0);
num := TBitConverter.InTo<Integer>(arr, 2);
num := LEToN(num);
writeln(num.ToString);
if num <> 65538 then halt(14);
writeln('');
end;
{
procedure TestInToAnsiString;
var
arr: TBytes;
str: AnsiString;
begin
arr := TArray<Byte>.Create(44, 44, 45, 67, 66);
str := TBitConverter.InTo<AnsiString>(arr, 0);
writeln(str);
if str <> 'hello' then halt(15);
writeln('');
end;
procedure TestFromAnsiString;
var
arr: TBytes;
item: Byte;
str: AnsiString;
i: Integer;
begin
i := 0;
str := 'hello world!';
SetLength(arr, Length(str));
TBitConverter.From<AnsiString>(str, arr);
for item in arr do
begin
Inc(i);
writeln(i.ToString + ': ' + item.ToString);
end;
writeln('');
end;
}
begin
{* testing TBitConverter.From<T> *}
TestFromInteger;
TestFromDouble;
TestFromTMyRecord;
TestFromTMyPackedRecord;
TestFromAnsiChar;
TestFromUnicodeChar;
{* testing TBitConverter.InTo<T> *}
TestInToInteger;
TestInToDouble;
TestInToTMyRecord;
TestInToTMyPackedRecord;
TestInToAnsiChar;
TestInToUnicodeChar;
{* testing offset *}
TestFromIntegerOffset;
TestInToIntegerOffset;
{* non base types *}
//TestInToAnsiString;
//TestFromAnsiString;
writeln('ok');
//readln;
end.