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

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@48480 -
This commit is contained in:
nickysn 2021-02-01 01:13:27 +00:00
commit d52e918fc8
12 changed files with 565 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.gitattributes vendored
View File

@ -5365,7 +5365,7 @@ packages/graph/src/inc/clip.inc svneol=native#text/plain
packages/graph/src/inc/fills.inc svneol=native#text/plain
packages/graph/src/inc/fontdata.inc svneol=native#text/plain
packages/graph/src/inc/graph.inc svneol=native#text/plain
packages/graph/src/inc/graph.tex -text
packages/graph/src/inc/graph.tex svneol=native#text/plain
packages/graph/src/inc/graphh.inc svneol=native#text/plain
packages/graph/src/inc/gtext.inc svneol=native#text/plain
packages/graph/src/inc/makefile.inc svneol=native#text/plain
@ -14046,6 +14046,7 @@ tests/test/cg/tobjsize.pp svneol=native#text/plain
tests/test/cg/tpara1.pp svneol=native#text/plain
tests/test/cg/tpara2.pp svneol=native#text/plain
tests/test/cg/tpara3.pp svneol=native#text/plain
tests/test/cg/tpara4.pp svneol=native#text/pascal
tests/test/cg/tprintf.pp svneol=native#text/plain
tests/test/cg/tprintf2.pp svneol=native#text/plain
tests/test/cg/tprintf3.pp svneol=native#text/plain
@ -16174,7 +16175,9 @@ tests/test/units/fpwidestring/twide6fpwidestring.pp svneol=native#text/pascal
tests/test/units/fpwidestring/twide7fpwidestring.pp svneol=native#text/pascal
tests/test/units/lineinfo/tlininfo.pp svneol=native#text/plain
tests/test/units/linux/tepoll1.pp svneol=native#text/pascal
tests/test/units/linux/tfutimesen.pp svneol=native#text/pascal
tests/test/units/linux/tstatx.pp svneol=native#text/pascal
tests/test/units/linux/tutimensat.pp svneol=native#text/pascal
tests/test/units/math/tcmpnan.pp svneol=native#text/plain
tests/test/units/math/tdivmod.pp svneol=native#text/plain
tests/test/units/math/tmask.inc svneol=native#text/plain
@ -18718,6 +18721,7 @@ tests/webtbs/tw3840.pp svneol=native#text/plain
tests/webtbs/tw3841.pp svneol=native#text/plain
tests/webtbs/tw38412.pp svneol=native#text/pascal
tests/webtbs/tw38413.pp svneol=native#text/pascal
tests/webtbs/tw38429.pp svneol=native#text/pascal
tests/webtbs/tw3863.pp svneol=native#text/plain
tests/webtbs/tw3864.pp svneol=native#text/plain
tests/webtbs/tw3865.pp svneol=native#text/plain
@ -19255,6 +19259,7 @@ tests/webtbs/uw38069.pp svneol=native#text/pascal
tests/webtbs/uw38385a.pp svneol=native#text/pascal
tests/webtbs/uw38385b.pp svneol=native#text/pascal
tests/webtbs/uw38385c.pp svneol=native#text/pascal
tests/webtbs/uw38429.pp svneol=native#text/pascal
tests/webtbs/uw3968.pp svneol=native#text/plain
tests/webtbs/uw4056.pp svneol=native#text/plain
tests/webtbs/uw4140.pp svneol=native#text/plain

16
compiler/nmem.pas
View File

@ -938,6 +938,7 @@ implementation
htype,elementdef,elementptrdef : tdef;
newordtyp: tordtype;
valid : boolean;
minvalue, maxvalue: Tconstexprint;
begin
result:=nil;
typecheckpass(left);
@ -1054,10 +1055,19 @@ implementation
begin
{ in case of an integer type, we need a new type which covers declaration range and index range,
see tests/webtbs/tw38413.pp
This matters only if we sign extend, if the type exceeds the sint range, we can fall back only
to the index type
}
if is_integer(right.resultdef) then
newordtyp:=range_to_basetype(min(TConstExprInt(Tarraydef(left.resultdef).lowrange),torddef(right.resultdef).low),
max(TConstExprInt(Tarraydef(left.resultdef).highrange),torddef(right.resultdef).high))
if is_integer(right.resultdef) and ((torddef(right.resultdef).low<0) or (TConstExprInt(Tarraydef(left.resultdef).lowrange)<0)) then
begin
minvalue:=min(TConstExprInt(Tarraydef(left.resultdef).lowrange),torddef(right.resultdef).low);
maxvalue:=max(TConstExprInt(Tarraydef(left.resultdef).highrange),torddef(right.resultdef).high);
if maxvalue>torddef(sinttype).high then
newordtyp:=Torddef(right.resultdef).ordtype
else
newordtyp:=range_to_basetype(minvalue,maxvalue);
end
else
newordtyp:=Torddef(right.resultdef).ordtype;
end

4
packages/rtl-objpas/src/inc/variants.pp
View File

@ -2351,10 +2351,14 @@ begin
end;
procedure DoVarCast(var aDest : TVarData; const aSource : TVarData; aVarType : LongInt);
var
Handler: TCustomVariantType;
begin
with aSource do
if vType = aVarType then
DoVarCopy(aDest, aSource)
else if FindCustomVariantType(vType, Handler) then
Handler.CastTo(aDest, aSource, aVarType)
else begin
if (vType = varNull) and NullStrictConvert then
VarCastError(varNull, aVarType);

64
rtl/linux/linux.pp
View File

@ -517,7 +517,7 @@ Type
end;
pstatx_timestamp = ^statx_timestamp;
statx = record
tstatx = record
stx_mask : __u32;
stx_blksize : __u32;
stx_attributes : __u64;
@ -540,9 +540,23 @@ Type
stx_dev_minor : __u32;
__spare2 : array[0..13] of __u64;
end;
pstatx = ^statx;
pstatx = ^tstatx;
function Fpstatx(dfd: cint; filename: pchar; flags,mask: cuint; var buf: statx):cint; {$ifdef FPC_USE_LIBC} cdecl; external name 'statx'; {$ENDIF}
function statx(dfd: cint; filename: pchar; flags,mask: cuint; var buf: tstatx):cint; {$ifdef FPC_USE_LIBC} cdecl; external name 'statx'; {$ENDIF}
Type
kernel_time64_t = clonglong;
kernel_timespec = record
tv_sec : kernel_time64_t;
tv_nsec : clonglong;
end;
pkernel_timespec = ^kernel_timespec;
tkernel_timespecs = array[0..1] of kernel_timespec;
Function utimensat(dfd: cint; path:pchar;const times:tkernel_timespecs;flags:cint):cint; {$ifdef FPC_USE_LIBC} cdecl; external name 'statx'; {$ENDIF}
Function futimens(fd: cint; const times:tkernel_timespecs):cint; {$ifdef FPC_USE_LIBC} cdecl; external name 'futimens'; {$ENDIF}
implementation
@ -854,11 +868,51 @@ begin
end;
function Fpstatx(dfd: cint; filename: pchar; flags,mask: cuint; var buf: statx):cint;
function statx(dfd: cint; filename: pchar; flags,mask: cuint; var buf: tstatx):cint;
begin
Fpstatx:=do_syscall(syscall_nr_statx,TSysParam(dfd),TSysParam(filename),TSysParam(flags),TSysParam(mask),TSysParam(@buf));
statx:=do_syscall(syscall_nr_statx,TSysParam(dfd),TSysParam(filename),TSysParam(flags),TSysParam(mask),TSysParam(@buf));
end;
{$endif}
Function utimensat(dfd: cint; path:pchar;const times:tkernel_timespecs;flags:cint):cint;
var
tsa: Array[0..1] of timespec;
begin
{$if sizeof(clong)<=4}
utimensat:=do_syscall(syscall_nr_utimensat_time64,dfd,TSysParam(path),TSysParam(@times),0);
if (utimensat>=0) or (fpgeterrno<>ESysENOSYS) then
exit;
{ try 32 bit fall back }
tsa[0].tv_sec := times[0].tv_sec;
tsa[0].tv_nsec := times[0].tv_nsec;
tsa[1].tv_sec := times[1].tv_sec;
tsa[1].tv_nsec := times[1].tv_nsec;
utimensat:=do_syscall(syscall_nr_utimensat,dfd,TSysParam(path),TSysParam(@tsa),0);
{$else sizeof(clong)<=4}
utimensat:=do_syscall(syscall_nr_utimensat,dfd,TSysParam(path),TSysParam(@times),0);
{$endif sizeof(clong)<=4}
end;
Function futimens(fd: cint; const times:tkernel_timespecs):cint;
var
tsa: Array[0..1] of timespec;
begin
{$if sizeof(clong)<=4}
futimens:=do_syscall(syscall_nr_utimensat_time64,fd,TSysParam(nil),TSysParam(@times),0);
if (futimens>=0) or (fpgeterrno<>ESysENOSYS) then
exit;
{ try 32 bit fall back }
tsa[0].tv_sec := times[0].tv_sec;
tsa[0].tv_nsec := times[0].tv_nsec;
tsa[1].tv_sec := times[1].tv_sec;
tsa[1].tv_nsec := times[1].tv_nsec;
futimens:=do_syscall(syscall_nr_utimensat,fd,TSysParam(nil),TSysParam(@tsa),0);
{$else sizeof(clong)<=4}
futimens:=do_syscall(syscall_nr_utimensat,fd,TSysParam(nil),TSysParam(@times),0);
{$endif sizeof(clong)<=4}
end;
end.

162
rtl/unix/sysutils.pp
View File

@ -56,7 +56,12 @@ uses
{$ENDIF}
{$if defined(LINUX)}
{$DEFINE HAS_STATX}
{$if sizeof(clong)<8}
{$DEFINE USE_STATX}
{$DEFINE USE_UTIMENSAT}
{$endif sizeof(clong)<=4}
{$DEFINE USE_FUTIMES}
{$endif}
{ Include platform independent interface part }
@ -556,20 +561,20 @@ Function FileAge (Const FileName : RawByteString): Int64;
Var
Info : Stat;
SystemFileName: RawByteString;
{$ifdef HAS_STATX}
Infox : Statx;
{$endif HAS_STATX}
{$ifdef USE_STATX}
Infox : TStatx;
{$endif USE_STATX}
begin
SystemFileName:=ToSingleByteFileSystemEncodedFileName(FileName);
{$ifdef HAS_STATX}
{$ifdef USE_STATX}
{ first try statx }
if (Fpstatx(0,pchar(SystemFileName),0,STATX_MTIME or STATX_MODE,Infox)>=0) and not(fpS_ISDIR(Infox.stx_mode)) then
if (statx(0,pchar(SystemFileName),0,STATX_MTIME or STATX_MODE,Infox)>=0) and not(fpS_ISDIR(Infox.stx_mode)) then
begin
Result:=Infox.stx_mtime.tv_sec;
exit;
end;
{$endif HAS_STATX}
{$endif USE_STATX}
If (fpstat(pchar(SystemFileName),Info)<0) or fpS_ISDIR(info.st_mode) then
exit(-1)
@ -605,6 +610,36 @@ begin
end;
{$ifdef USE_STATX}
Function LinuxToWinAttr (const FN : RawByteString; Const Info : TStatx) : Longint;
Var
LinkInfo : Stat;
nm : RawByteString;
begin
Result:=faArchive;
If fpS_ISDIR(Info.stx_mode) then
Result:=Result or faDirectory;
nm:=ExtractFileName(FN);
If (Length(nm)>=2) and
(nm[1]='.') and
(nm[2]<>'.') then
Result:=Result or faHidden;
If (Info.stx_Mode and S_IWUSR)=0 Then
Result:=Result or faReadOnly;
If fpS_ISSOCK(Info.stx_mode) or fpS_ISBLK(Info.stx_mode) or fpS_ISCHR(Info.stx_mode) or fpS_ISFIFO(Info.stx_mode) Then
Result:=Result or faSysFile;
If fpS_ISLNK(Info.stx_mode) Then
begin
Result:=Result or faSymLink;
// Windows reports if the link points to a directory.
{ as we are only interested in the st_mode field here, we do not need to use statx }
if (fpstat(pchar(FN),LinkInfo)>=0) and fpS_ISDIR(LinkInfo.st_mode) then
Result := Result or faDirectory;
end;
end;
{$endif USE_STATX}
function FileGetSymLinkTarget(const FileName: RawByteString; out SymLinkRec: TRawbyteSymLinkRec): Boolean;
var
Info : Stat;
@ -892,26 +927,54 @@ end;
Function FindGetFileInfo(const s: RawByteString; var f: TAbstractSearchRec; var Name: RawByteString):boolean;
Var
{$ifdef USE_STATX}
stx : linux.tstatx;
{$endif USE_STATX}
st : baseunix.stat;
WinAttr : longint;
begin
{$ifdef USE_STATX}
if Assigned(f.FindHandle) and ( (PUnixFindData(F.FindHandle)^.searchattr and faSymlink) > 0) then
FindGetFileInfo:=(fplstat(pointer(s),st)=0)
FindGetFileInfo:=statx(AT_FDCWD,pointer(s),AT_SYMLINK_NOFOLLOW,STATX_ALL,stx)=0
else
FindGetFileInfo:=(fpstat(pointer(s),st)=0);
if not FindGetFileInfo then
exit;
WinAttr:=LinuxToWinAttr(s,st);
FindGetFileInfo:=(WinAttr and Not(PUnixFindData(f.FindHandle)^.searchattr))=0;
FindGetFileInfo:=statx(AT_FDCWD,pointer(s),0,STATX_ALL,stx)=0;
if FindGetFileInfo then
begin
Name:=ExtractFileName(s);
f.Attr:=WinAttr;
f.Size:=st.st_Size;
f.Mode:=st.st_mode;
f.Time:=st.st_mtime;
FindGetFileInfo:=true;
WinAttr:=LinuxToWinAttr(s,stx);
FindGetFileInfo:=(WinAttr and Not(PUnixFindData(f.FindHandle)^.searchattr))=0;
if FindGetFileInfo then
begin
Name:=ExtractFileName(s);
f.Attr:=WinAttr;
f.Size:=stx.stx_Size;
f.Mode:=stx.stx_mode;
f.Time:=stx.stx_mtime.tv_sec;
FindGetFileInfo:=true;
end;
end
{ no statx? try stat }
else if fpgeterrno=ESysENOSYS then
{$endif USE_STATX}
begin
if Assigned(f.FindHandle) and ( (PUnixFindData(F.FindHandle)^.searchattr and faSymlink) > 0) then
FindGetFileInfo:=(fplstat(pointer(s),st)=0)
else
FindGetFileInfo:=(fpstat(pointer(s),st)=0);
if not FindGetFileInfo then
exit;
WinAttr:=LinuxToWinAttr(s,st);
FindGetFileInfo:=(WinAttr and Not(PUnixFindData(f.FindHandle)^.searchattr))=0;
if FindGetFileInfo then
begin
Name:=ExtractFileName(s);
f.Attr:=WinAttr;
f.Size:=st.st_Size;
f.Mode:=st.st_mode;
f.Time:=st.st_mtime;
FindGetFileInfo:=true;
end;
end;
end;
@ -1014,22 +1077,42 @@ End;
Function FileGetDate (Handle : Longint) : Int64;
Var Info : Stat;
Var
Info : Stat;
{$ifdef USE_STATX}
Infox : TStatx;
{$endif USE_STATX}
begin
If (fpFStat(Handle,Info))<0 then
Result:=-1
else
Result:=Info.st_Mtime;
Result:=-1;
{$ifdef USE_STATX}
if statx(Handle,nil,0,STATX_MTIME,Infox)=0 then
Result:=Infox.stx_Mtime.tv_sec
else if fpgeterrno=ESysENOSYS then
{$endif USE_STATX}
begin
If fpFStat(Handle,Info)=0 then
Result:=Info.st_Mtime;
end;
end;
Function FileSetDate (Handle : Longint;Age : Int64) : Longint;
{$ifdef USE_FUTIMES}
var
times : tkernel_timespecs;
{$endif USE_FUTIMES}
begin
// Impossible under Linux from FileHandle !!
Result:=0;
{$ifdef USE_FUTIMES}
times[0].tv_sec:=Age;
times[0].tv_nsec:=0;
times[1].tv_sec:=Age;
times[1].tv_nsec:=0;
if futimens(Handle,times) = -1 then
Result:=fpgeterrno;
{$else USE_FUTIMES}
FileSetDate:=-1;
{$endif USE_FUTIMES}
end;
@ -1086,14 +1169,29 @@ end;
Function FileSetDate (Const FileName : RawByteString; Age : Int64) : Longint;
var
SystemFileName: RawByteString;
{$ifdef USE_UTIMENSAT}
times : tkernel_timespecs;
{$endif USE_UTIMENSAT}
t: TUTimBuf;
begin
SystemFileName:=ToSingleByteFileSystemEncodedFileName(FileName);
Result:=0;
t.actime:= Age;
t.modtime:=Age;
if fputime(PChar(SystemFileName), @t) = -1 then
{$ifdef USE_UTIMENSAT}
times[0].tv_sec:=Age;
times[0].tv_nsec:=0;
times[1].tv_sec:=Age;
times[1].tv_nsec:=0;
if utimensat(AT_FDCWD,PChar(SystemFileName),times,0) = -1 then
Result:=fpgeterrno;
if fpgeterrno=ESysENOSYS then
{$endif USE_UTIMENSAT}
begin
Result:=0;
t.actime:= Age;
t.modtime:=Age;
if fputime(PChar(SystemFileName), @t) = -1 then
Result:=fpgeterrno;
end
end;
{****************************************************************************

22
tests/test/cg/tpara4.pp Normal file
View File

@ -0,0 +1,22 @@
{ This test ensures that a "const TVarData" parameter is passed as a reference.
This is required for Delphi compatibility as implementers of IVarInvokable or
inheritors of TInvokableVariantType need to modify the variant data by using
a pointer to the TVarData because it's passed as const and thus not modifyable
by itself.
This behavior is documented in so far as the C++ builder documentation shows
that the same parameter is implemented as "const&". }
program tpara4;
var
d: TVarData;
procedure Test(const v: TVarData);
begin
if @d <> @v then
Halt(1);
end;
begin
Test(d);
end.

84
tests/test/units/linux/tfutimesen.pp Normal file
View File

@ -0,0 +1,84 @@
{ %target=linux }
uses
ctypes,baseunix,linux;
var
un : utsname;
res : cint;
f1,f2 : text;
err : word;
mystatx1,mystatx2 : tstatx;
times : tkernel_timespecs;
st,major,minor : string;
i,p,e : longint;
major_release, minor_release : longint;
begin
fpuname(un);
st:=un.release;
for i:=1 to UTSNAME_LENGTH do
if st[i]='.' then
begin
p:=i;
major:=system.copy(st,1,p-1);
system.val(major,major_release,err);
if err<>0 then
begin
writeln('Unable to parse first part of linux version ',st,'(',major,') correctly');
halt(2);
end;
break;
end;
for i:=p+1 to UTSNAME_LENGTH do
if st[i]='.' then
begin
e:=i;
minor:=system.copy(st,p+1,e-p-1);
system.val(minor,minor_release,err);
if err<>0 then
begin
writeln('Unable to second part of parse linux version ',st,'i(',minor,') correctly');
halt(2);
end;
break;
end;
if (major_release<4) or ((major_release=4) and (minor_release<11)) then
begin
writeln('This version of Linux: ',st,' does not have fstatx syscall');
halt(0);
end
else
writeln('This linux version ',st,' should support statx syscall');
assign(f1,'tutimensat1.txt');
rewrite(f1);
write(f1,'ccccc');
assign(f2,'tutimensat2.txt');
rewrite(f2);
write(f2,'ccccc');
res:=statx(AT_FDCWD,'tutimensat1.txt',AT_SYMLINK_NOFOLLOW,STATX_ALL,mystatx1);
if res<>0 then
halt(1);
times[0].tv_sec:=mystatx1.stx_atime.tv_sec;
times[0].tv_nsec:=mystatx1.stx_atime.tv_nsec;
times[1].tv_sec:=mystatx1.stx_mtime.tv_sec;
times[1].tv_nsec:=mystatx1.stx_mtime.tv_nsec;
res:=futimens(textrec(f2).handle,times);
if res<>0 then
halt(1);
res:=statx(AT_FDCWD,'tutimensat2.txt',AT_SYMLINK_NOFOLLOW,STATX_ALL,mystatx2);
if res<>0 then
halt(1);
close(f1);
close(f2);
erase(f1);
erase(f2);
if (mystatx1.stx_atime.tv_sec<>mystatx2.stx_atime.tv_sec) or (mystatx1.stx_atime.tv_nsec<>mystatx2.stx_atime.tv_nsec) or
(mystatx1.stx_mtime.tv_sec<>mystatx2.stx_mtime.tv_sec) or (mystatx1.stx_mtime.tv_nsec<>mystatx2.stx_mtime.tv_nsec) then
halt(1);
writeln('ok');
end.

16
tests/test/units/linux/tstatx.pp
View File

@ -1,10 +1,10 @@
{ %target=linux }
uses
ctypes,baseunix,linux;
var
un : utsname;
mystatx : statx;
mystatx : tstatx;
res : cint;
f : text;
st,major,minor : string;
@ -21,13 +21,13 @@ begin
major:=system.copy(st,1,p-1);
system.val(major,major_release,err);
if err<>0 then
begin
begin
writeln('Unable to parse first part of linux version ',st,'(',major,') correctly');
halt(2);
end;
break;
end;
for i:=p+1 to UTSNAME_LENGTH do
if st[i]='.' then
begin
@ -35,25 +35,25 @@ begin
minor:=system.copy(st,p+1,e-p-1);
system.val(minor,minor_release,err);
if err<>0 then
begin
begin
writeln('Unable to second part of parse linux version ',st,'i(',minor,') correctly');
halt(2);
end;
break;
end;
if (major_release<4) or (minor_release<11) then
if (major_release<4) or ((major_release=4) and (minor_release<11)) then
begin
writeln('This version of Linux: ',st,' does not have fstatx syscall');
halt(0);
end
else
writeln('This linux version ',st,' should support statx syscall');
assign(f,'test.txt');
rewrite(f);
write(f,'ccccc');
close(f);
res:=fpstatx(AT_FDCWD,'test.txt',AT_SYMLINK_NOFOLLOW,STATX_ALL,mystatx);
res:=statx(AT_FDCWD,'test.txt',AT_SYMLINK_NOFOLLOW,STATX_ALL,mystatx);
erase(f);
if res<>0 then
begin

83
tests/test/units/linux/tutimensat.pp Normal file
View File

@ -0,0 +1,83 @@
{ %target=linux }
uses
ctypes,baseunix,linux;
var
un : utsname;
res : cint;
f1,f2 : text;
err : word;
mystatx1,mystatx2 : tstatx;
times : tkernel_timespecs;
st,major,minor : string;
i,p,e : longint;
major_release, minor_release : longint;
begin
fpuname(un);
st:=un.release;
for i:=1 to UTSNAME_LENGTH do
if st[i]='.' then
begin
p:=i;
major:=system.copy(st,1,p-1);
system.val(major,major_release,err);
if err<>0 then
begin
writeln('Unable to parse first part of linux version ',st,'(',major,') correctly');
halt(2);
end;
break;
end;
for i:=p+1 to UTSNAME_LENGTH do
if st[i]='.' then
begin
e:=i;
minor:=system.copy(st,p+1,e-p-1);
system.val(minor,minor_release,err);
if err<>0 then
begin
writeln('Unable to second part of parse linux version ',st,'i(',minor,') correctly');
halt(2);
end;
break;
end;
if (major_release<4) or ((major_release=4) and (minor_release<11)) then
begin
writeln('This version of Linux: ',st,' does not have fstatx syscall');
halt(0);
end
else
writeln('This linux version ',st,' should support statx syscall');
assign(f1,'tutimensat1.txt');
rewrite(f1);
write(f1,'ccccc');
close(f1);
assign(f2,'tutimensat2.txt');
rewrite(f2);
write(f2,'ccccc');
close(f2);
res:=statx(AT_FDCWD,'tutimensat1.txt',AT_SYMLINK_NOFOLLOW,STATX_ALL,mystatx1);
if res<>0 then
halt(1);
times[0].tv_sec:=mystatx1.stx_atime.tv_sec;
times[0].tv_nsec:=mystatx1.stx_atime.tv_nsec;
times[1].tv_sec:=mystatx1.stx_mtime.tv_sec;
times[1].tv_nsec:=mystatx1.stx_mtime.tv_nsec;
res:=utimensat(AT_FDCWD,'tutimensat2.txt',times,0);
if res<>0 then
halt(1);
res:=statx(AT_FDCWD,'tutimensat2.txt',AT_SYMLINK_NOFOLLOW,STATX_ALL,mystatx2);
if res<>0 then
halt(1);
erase(f1);
erase(f2);
if (mystatx1.stx_atime.tv_sec<>mystatx2.stx_atime.tv_sec) or (mystatx1.stx_atime.tv_nsec<>mystatx2.stx_atime.tv_nsec) or
(mystatx1.stx_mtime.tv_sec<>mystatx2.stx_mtime.tv_sec) or (mystatx1.stx_mtime.tv_nsec<>mystatx2.stx_mtime.tv_nsec) then
halt(1);
writeln('ok');
end.

7
tests/test/units/sysutils/tfile1.pp
View File

@ -32,6 +32,13 @@ BEGIN
if FileSetDate('datetest.dat', DateTimeToFileDate(dateTime))<>0 then
do_error(1002);
dateTime := IncMonth(Now, -1);
Assign(f,'datetest.dat');
Rewrite(f);
if FileSetDate(filerec(f).handle, DateTimeToFileDate(dateTime))<>0 then
do_error(1003);
Close(f);
if FileExists('datetest.dat') then
begin
Assign(f,'datetest.dat');

61
tests/webtbs/tw38429.pp Normal file
View File

@ -0,0 +1,61 @@
program tw38429;
{$mode objfpc}{$h+}
uses
SysUtils, Variants, uw38429;
var
v, d: Variant;
I: Integer = 42;
begin
Writeln('Test VarAsType');
d := I;
try
v := VarAsType(d, varMyVar);
except
on e: exception do begin
WriteLn('cast ', VarTypeAsText(VarType(d)), ' to ',VarTypeAsText(varMyVar),
' raises ', e.ClassName, ' with message: ', e.Message);
Halt(1);
end;
end;
WriteLn('now v is ', VarTypeAsText(VarType(v)));
VarClear(d);
try
d := VarAsType(v, varInteger);
except
on e: exception do begin
WriteLn('cast ', VarTypeAsText(VarType(v)), ' to ',VarTypeAsText(varInteger),
' raises ', e.ClassName, ' with message: ', e.Message);
Halt(2);
end;
end;
WriteLn('now d is ', VarTypeAsText(VarType(d)));
{ also test VarCast from #20849 }
Writeln('Test VarCast');
d := I;
try
VarCast(v, d, varMyVar);
except
on e: exception do begin
WriteLn('cast ', VarTypeAsText(VarType(d)), ' to ',VarTypeAsText(varMyVar),
' raises ', e.ClassName, ' with message: ', e.Message);
Halt(3);
end;
end;
WriteLn('now v is ', VarTypeAsText(VarType(v)));
VarClear(d);
try
VarCast(d, v, varInteger);
except
on e: exception do begin
WriteLn('cast ', VarTypeAsText(VarType(v)), ' to ',VarTypeAsText(varInteger),
' raises ', e.ClassName, ' with message: ', e.Message);
Halt(4);
end;
end;
WriteLn('now d is ', VarTypeAsText(VarType(d)));
end.

88
tests/webtbs/uw38429.pp Normal file
View File

@ -0,0 +1,88 @@
unit uw38429;
{$mode objfpc}{$H+}
{$modeswitch advancedrecords}
interface
uses
SysUtils, Variants;
type
TMyVar = packed record
VType: TVarType;
Dummy1: array[0..Pred(SizeOf(Pointer) - 2)] of Byte;
Dummy2,
Dummy3: Pointer;
procedure Init;
end;
{ TMyVariant }
TMyVariant = class(TInvokeableVariantType)
procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override;
procedure Clear(var V: TVarData); override;
procedure Cast(var Dest: TVarData; const Source: TVarData); override;
procedure CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); override;
end;
function MyVarCreate: Variant;
function varMyVar: TVarType;
implementation
var
MyVariant: TMyVariant;
function MyVarCreate: Variant;
begin
VarClear(Result);
TMyVar(Result).Init;
end;
function VarMyVar: TVarType;
begin
Result := MyVariant.VarType;
end;
{ TMyVar }
procedure TMyVar.Init;
begin
VType := VarMyVar;
end;
{ TMyVariant }
procedure TMyVariant.Copy(var Dest: TVarData; const Source: TVarData;
const Indirect: Boolean);
begin
Dest := Source;
end;
procedure TMyVariant.Clear(var V: TVarData);
begin
TMyVar(v).VType := varEmpty;
end;
procedure TMyVariant.Cast(var Dest: TVarData; const Source: TVarData);
begin
WriteLn('TMyVariant.Cast');
VarClear(Variant(Dest));
TMyVar(Dest).Init;
end;
procedure TMyVariant.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);
begin
WriteLn('TMyVariant.CastTo');
VarClear(Variant(Dest));
TVarData(Dest).VType := aVarType;
end;
initialization
MyVariant := TMyVariant.Create;
finalization
MyVariant.Free;
end.