mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-05 20:48:06 +02:00
47 lines
1003 B
ObjectPascal
47 lines
1003 B
ObjectPascal
{ %target=linux,haiku }
|
|
|
|
program setup;
|
|
|
|
{$mode delphi}{$H+}
|
|
|
|
Uses cthreads, Classes, SysUtils, BaseUnix;
|
|
|
|
{ don't use current directory in case it's on a network share that does not
|
|
support locking
|
|
}
|
|
Const Fn = '/tmp/fpctest.lock';
|
|
{$if defined(cpusparc) or defined(cpusparc64)}
|
|
F_RDLCK = 1;
|
|
F_WRLCK = 2;
|
|
F_UNLCK = 3;
|
|
{$else}
|
|
F_RDLCK = 0;
|
|
F_WRLCK = 1;
|
|
F_UNLCK = 2;
|
|
{$endif}
|
|
|
|
Var F, I : Integer;
|
|
Region : FLock;
|
|
res: longint;
|
|
Begin
|
|
If FileExists (Fn) Then DeleteFile (Fn);
|
|
F := FpOpen (Fn, O_RDWR Or O_CREAT, $1B6); // $1B6 = o666
|
|
For I := 0 To 255 Do FpWrite (F, I, 1);
|
|
With Region Do Begin
|
|
l_type := F_WRLCK; l_whence := SEEK_SET;
|
|
l_start := 10; l_len := 20
|
|
End;
|
|
If FpFcntl (F, F_SETLK, Region) = -1 Then
|
|
begin
|
|
FpClose (F);
|
|
deletefile(fn);
|
|
halt(1);
|
|
end;
|
|
res:=executeprocess('./tb0561a','');
|
|
FpClose (F);
|
|
deletefile(fn);
|
|
if res<>0 then
|
|
halt(2);
|
|
End.
|
|
|