home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
vp21beta.zip
/
ARTLSRC.RAR
/
VPSYSLNX.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
2000-08-15
|
94KB
|
3,591 lines
//█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█
//█ █
//█ Virtual Pascal Runtime Library. Version 2.1. █
//█ System interface layer Linux █
//█ ─────────────────────────────────────────────────█
//█ Copyright (C) 1995-2000 vpascal.com █
//█ Initial Port to Linux (C) 1999 Jörg Pleumann █
//█ █
//▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀
function IntToStr(I: Integer): string;
begin
Str(I, Result);
end;
procedure TrmDone; forward;
//▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ DATE/TIME CONVERSION FUNCTIONS ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
const
// The number of seconds in a day.
SecsPerDay = 24 * 60 * 60;
// The number of days from (assumed) date 31-Dec-0000 to UTC base
// day 01-Jan-1970.
UTCBaseDay = 719163;
// The number of days that have passed since 01-Jan to the beginning
// of a given month. Two variants, one for non-leap years, the other
// for leap years.
DaysPassed: array[False..True, 1..13] of Integer =
((0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365),
(0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366));
type
// A record holding all the fields needed for a date/time
// conversion.
TDateTime = record
Year,Month,Day,DayOfWeek,Hour,Min,Sec: LongInt;
end;
// Packs a TDateTime record to a single UTC date/time value. No
// timezone adjustment is performed.
function PackUTCTime(DateTime: TDateTime): LongInt;
var
Date, Time: LongInt;
begin
with DateTime do
begin
if Month > 2 then
Dec(Month, 3)
else
begin
Inc (Month, 9);
Dec (Year);
end;
Date := (146097 * (Year div 100)) shr 2
+ (1461 * (Year mod 100)) shr 2
+ (153 * Month + 2) div 5 + Day - 306;
Time := (Hour * 60 + Min) * 60 + Sec;
Result := (Date - UTCBaseDay) * SecsPerDay + Time;
end;
end;
// Unpacks a UTC date/time value to a TDateTime record. No timezone
// adjustment is performed.
function UnpackUTCTime(Value: LongInt): TDateTime;
const
Days400 = 146097;
Days100 = 36524;
Days4 = 1461;
var
Count, DayNum: LongInt;
LeapYear: Boolean;
begin
with Result do
begin
DayNum := Value div SecsPerDay + UTCBaseDay;
DayOfWeek := DayNum mod 7;
Year := 1;
while DayNum > Days400 do
begin
Inc(Year, 400);
Dec(DayNum, Days400);
end;
Count := 0;
while (DayNum > Days100) and (Count < 3) do
begin
Inc(Year, 100);
Dec(DayNum, Days100);
Inc(Count);
end;
while DayNum > Days4 do
begin
Inc(Year, 4);
Dec(DayNum, Days4);
end;
Count := 0;
while (DayNum > 365) and (Count < 3) do
begin
Inc(Year);
Dec(DayNum, 365);
Inc(Count);
end;
LeapYear := (Year mod 4 = 0) and not (Year mod 100 = 0) or (Year mod 400 = 0);
Month := 0;
while DaysPassed[LeapYear, Month + 1] < DayNum do Inc(Month);
Day := DayNum - DaysPassed[LeapYear, Month];
Sec := Value mod SecsPerDay;
Min := Sec div 60;
Sec := Sec mod 60;
Hour := Min div 60;
Min := Min mod 60;
end;
end;
// Packs a TDateTime record to a DOS time value. Taken from the DOS
// unit.
procedure PackDosTime(var T: TDateTime; var P: Longint);
var
FDateTime: TDateTimeRec absolute P;
begin
with T,FDateTime do
begin
FDate := (Year - 1980) shl 9 + Month shl 5 + Day;
FTime := Hour shl 11 + Min shl 5 + (Sec div 2);
end;
end;
// Unpacks a DOS time value to a TDateTime record. Taken from the DOS
// unit.
procedure UnpackDosTime(P: Longint; var T: TDateTime);
var
FDateTime: TDateTimeRec absolute P;
begin
with T,FDateTime do
begin
Year := (FDate and $FE00) shr 9 + 1980;
Month := (FDate and $01E0) shr 5;
Day := (FDate and $001F);
Hour := (FTime and $F800) shr 11;
Min := (FTime and $07E0) shr 5;
Sec := (FTime and $001F) * 2;
end;
end;
//▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ FILENAME CONVERSION FUNCTIONS ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
type
// A buffer for file names. TFileNameBuf
TFileNameBuf = array[0..511] of Char;
// Converts file name given given in Source according to the source
// and destination file systems given in SourceFS and DestFS. The
// result is written to the Dest buffer, and Dest is returned. In
// case no conversion is necessary, the function returns Source
// and the Dest buffer stays unchanged.
function SysConvertFileName(Dest, Source: PChar; DestFS, SourceFS: TFileSystem): PChar;
var
SourceChar, DestChar: Char;
P: PChar;
begin
if DestFS = SourceFS then
begin
Result := Source;
Exit;
end;
if DestFS = fsUnix then
begin
if (Source[0] <> #0) and (Source[1] = ':') then
Inc(Source, 2);
SourceChar := '\';
DestChar := '/';
end
else
begin
SourceChar := '/';
DestChar := '\';
end;
StrCopy(Dest, Source);
if SourceFS = fsDosUpper then
StrUpper(Dest)
else if SourceFS = fsDosLower then
StrLower(Dest);
P := StrScan(Dest, SourceChar);
while P <> nil do
begin
P^ := DestChar;
P := StrScan(P, SourceChar);
end;
Result := Dest;
end;
// Checks whether a file name is valid for the given file system.
function SysIsValidFileName(FileName: PChar; FileSystem: TFileSystem): Boolean;
var
P: PChar;
begin
Result := False;
P := FileName;
while P[0] <> #0 do
begin
case P[0] of
'\', ':': if FileSystem = fsUnix then Exit;
'/' : if FileSystem <> fsUnix then Exit;
'a'..'z': if (FileSystem = fsDosUpper) and (P[1] <> ':') then Exit;
'A'..'Z': if (FileSystem = fsDosLower) and (P[1] <> ':') then Exit;
end;
Inc(P);
end;
Result := True;
end;
//▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ OTHER HELPER FUNCTIONS ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
procedure Unimplemented(const S: string);
begin
WriteLn('Fatal error: Function "', S,'" not implemented yet.');
Halt(255);
end;
//▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ BASIC FILE FUNCTIONS ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
// Please refer to the online help for VpSysLow for details
function SysFileStdIn: Longint;
begin
Result := STDIN_FILENO;
end;
function SysFileStdOut: Longint;
begin
Result := STDOUT_FILENO;
end;
function SysFileStdErr: Longint;
begin
Result := STDERR_FILENO;
end;
function SysFileOpen_Create(Open: Boolean;FileName: PChar; Mode,Attr,Action: Longint; var Handle: Longint): Longint;
var
Buffer: TFileNameBuf;
LnxMode, LnxAttr: Longint;
begin
FileName := SysConvertFileName(Buffer, FileName, fsUnix, FileSystem);
if Open then
begin
case Action of
Open_FailIfNew: LnxMode := 0;
Open_CreateIfNew: LnxMode := O_CREAT;
Open_TruncateIfExists: LnxMode := O_TRUNC;
end;
end
else
begin
case Action of
Create_FailIfExists: LnxMode := O_CREAT or O_EXCL;
Create_TruncateIfExists: LnxMode := O_CREAT or O_TRUNC;
end;
end;
LnxMode := LnxMode or Mode and O_ACCMODE;
LnxAttr := S_IRWXU or S_IRWXG or S_IRWXO;
if Attr and 1 = 1 then
LnxAttr := LnxAttr and not (S_IWUSR or S_IWGRP or S_IWOTH);
Result := LnxOpen(FileName, LnxMode, LnxAttr);
if Result < 0 then
Result := -Result
else
begin
Handle := Result;
Result := 0;
end;
end;
function SysFileOpen(FileName: PChar; Mode: Longint; var Handle: Longint): Longint;
var
Buffer: TFileNameBuf;
LnxMode: Longint;
begin
FileName := SysConvertFileName(Buffer, FileName, fsUnix, FileSystem);
LnxMode := Mode and O_ACCMODE;
Result := LnxOpen(FileName, LnxMode, 0);
if Result < 0 then
Result := -Result
else
begin
Handle := Result;
Result := 0;
end;
end;
function SysFileCreate(FileName: PChar; Mode,Attr: Longint; var Handle: Longint): Longint;
var
Buffer: TFileNameBuf;
LnxMode, LnxAttr: Longint;
begin
FileName := SysConvertFileName(Buffer, FileName, fsUnix, FileSystem);
LnxMode := Mode and O_ACCMODE;
LnxAttr := S_IRWXU or S_IRWXG or S_IRWXO;
if Attr and 1 = 1 then
LnxAttr := LnxAttr and not (S_IWUSR or S_IWGRP or S_IWOTH);
Result := LnxCreat(FileName, LnxMode or LnxAttr);
if Result < 0 then
Result := -Result
else
begin
Handle := Result;
Result := 0;
end;
end;
function SysFileCopy(_Old, _New: PChar; _Overwrite: Boolean): Boolean;
var
Attr, Src, Dst, Error, Actual: Longint;
Buffer: array[0..1023] of Char;
begin
Result := False;
SysGetFileAttr(_Old, Attr);
Error := SysFileOpen(_Old, Open_Access_ReadOnly, Src);
if Error = 0 then
begin
if _Overwrite then
Error := SysFileCreate(_New, Open_Access_ReadWrite, Attr, Dst)
else
Error := SysFileOpen_Create(False, _New, Open_Access_ReadWrite, Attr, 0, Dst);
if Error = 0 then
begin
Actual := 1;
while (Error = 0) and (Actual > 0) do
begin
Error := SysFileRead(Src, Buffer, SizeOf(Buffer), Actual);
if Error = 0 then
Error := SysFileWrite(Dst, Buffer, Actual, Actual);
end;
Result := SysFileClose(Dst) = 0;
end
else
SysFileClose(Src);
end;
end;
function SysFileSeek(Handle, Distance, Method: Longint; var Actual: Longint): Longint;
begin
Result := LnxLSeek(Handle, Distance, Method);
if Result < 0 then
Result := -Result
else
begin
Actual := Result;
Result := 0;
end;
end;
function SysFileRead(Handle: Longint; var Buffer; Count: Longint; var Actual: Longint): Longint;
begin
Result := LnxRead(Handle, Buffer, Count);
if Result < 0 then
Result := -Result
else
begin
Actual := Result;
Result := 0;
end;
end;
function SysFileWrite(Handle: Longint; const Buffer; Count: Longint; var Actual: Longint): Longint;
begin
Result := LnxWrite(Handle, Buffer, Count);
if Result < 0 then
Result := -Result
else
begin
Actual := Result;
Result := 0;
end;
end;
function SysFileSetSize(Handle,NewSize: Longint): Longint;
begin
Result := -LnxFTruncate(Handle, NewSize);
end;
function SysFileClose(Handle: Longint): Longint;
begin
Result := -LnxClose(Handle);
end;
function SysFileFlushBuffers(Handle: Longint): Longint;
begin
Result := -LnxFSync(Handle);
end;
function SysFileDelete(FileName: PChar): Longint;
var
Buffer: TFileNameBuf;
begin
FileName := SysConvertFileName(@Buffer, FileName, fsUnix, FileSystem);
Result := -LnxUnlink(FileName);
end;
function SysFileMove(OldName,NewName: PChar): Longint;
var
OldBuffer, NewBuffer: TFileNameBuf;
begin
OldName := SysConvertFileName(@OldBuffer, OldName, fsUnix, FileSystem);
NewName := SysConvertFileName(@NewBuffer, NewName, fsUnix, FileSystem);
Result := -LnxRename(OldName, NewName);
end;
function SysFileIsDevice(Handle: Longint): Longint;
var
Stat: TStat;
begin
Result := -LnxFStat(Handle, Stat);
if Result = 0 then
begin
if Stat.st_rdev and S_IFCHR <> 0 then
Result := 1
else if Stat.st_rdev and S_IFIFO <> 0 then
Result := 2;
end;
end;
// Retrieve current directory via the proc file system
function GetCwdViaProc(Buffer: PChar): Longint;
begin
Result := LnxReadLink('/proc/self/cwd', Buffer, SizeOf(TFileNameBuf) - 1);
if Result > 0 then
Buffer[Result] := #0;
end;
// Retrieve the current directory through FS
function GetCwdViaFS(Path: PChar): Longint;
var
Root, This, RootDev, ThisDev: Longint;
Temp, TempDev, Find, FindDev, Handle, Count: LongInt;
Stat: TStat;
DirEnt: TDirEnt;
Name, Buffer: TFileNameBuf;
MountPoint: Boolean;
NameBeg: PChar;
begin
Result := -1;
// Get INode of root directory
LnxStat('/', Stat);
Root := Stat.st_Ino;
RootDev := Stat.st_Dev;
// Get INode of current directory
LnxStat('.', Stat);
This := Stat.st_Ino;
ThisDev := Stat.st_Dev;
Find := This;
FindDev := ThisDev;
// Initialze the buffers
StrCopy(Path, '');
StrCopy(@Name, '..');
StrCopy(@Buffer, '/');
{ As long as the current directory is not the root }
{ directory, we go one directory upwards and search }
{ for an entry whose INode is equal to the one of }
{ our current directory. }
while (This <> Root) or (ThisDev <> RootDev) do
begin
if SysFileOpen(@Name, OPEN_ACCESS_READONLY, Handle) = 0 then
begin
// Get stats of parent directory
LnxFStat(Handle, Stat);
Temp := Stat.st_Ino;
TempDev := Stat.st_Dev;
MountPoint := TempDev <> ThisDev;
// Find INode of this directory in parent directory
while LnxReadDir(Handle, DirEnt, 1) = 1 do
begin
if DirEnt.d_Name[0] = '.' then
if (DirEnt.d_Name[1] = #0) or ((DirEnt.d_Name[1] = '.') and (DirEnt.d_Name[2] = #0)) then
Continue;
if MountPoint or (DirEnt.d_Ino = This) then
begin
if MountPoint then
begin
NameBeg := StrECopy(StrECopy(@Buffer[1], @Name), '/');
StrCopy(StrECopy(NameBeg, @DirEnt.d_Name), Path);
if LnxStat(@Buffer, Stat) <> 0 then Continue;
if (Stat.st_INo <> Find) or (Stat.st_Dev <> FindDev) then Continue;
StrCopy(@Buffer[1], NameBeg);
end
else
StrCopy(StrECopy(@Buffer[1], @DirEnt.d_Name), Path);
StrCopy(Path, @Buffer);
This := Temp;
ThisDev := TempDev;
Break;
end;
end;
SysFileClose(Handle);
if ThisDev <> TempDev then
begin
// Not found
StrCopy(Path, '');
Exit;
end;
end
else
begin
// File could not be opened
StrCopy(Path, '');
Exit;
end;
StrCat(@Name, '/..');
end; // While
if StrLen(Path) = 0 then
StrCopy(Path, '/');
Result := StrLen(Path);
end;
function SysDirGetCurrent(Drive: Longint; Path: PChar): Longint;
var
Buffer: TFileNameBuf;
begin
Buffer[0] := 'c';
Buffer[1] := ':';
if (Drive <> 0) and (Drive <> 3) then
begin
Result := -1;
Exit;
end;
if GetCwdViaProc(@Buffer[2]) < 1 then
if GetCwdViaFs(@Buffer[2]) < 1 then
begin
Result := -1;
Exit;
end;
if FileSystem = fsUnix then
begin
if SysConvertFileName(Path, @Buffer[2], FileSystem, fsUnix) <> Path then
StrCopy(Path, @Buffer[2]);
end
else
begin
if SysConvertFileName(Path, @Buffer, FileSystem, fsUnix) <> Path then
StrCopy(Path, @Buffer);
end;
Result := 0;
end;
function SysDirSetCurrent(Path: PChar): Longint;
var
Buffer: TFileNameBuf;
begin
Path := SysConvertFileName(@Buffer, Path, fsUnix, FileSystem);
Result := LnxChDir(Path);
end;
function SysDirCreate(Path: PChar): Longint;
var
Buffer: TFileNameBuf;
begin
Path := SysConvertFileName(@Buffer, Path, fsUnix, FileSystem);
Result := LnxMkDir(Path, S_IRWXU or S_IRWXG or S_IRWXO);
end;
function SysDirDelete(Path: PChar): Longint;
var
Buffer: TFileNameBuf;
begin
Path := SysConvertFileName(@Buffer, Path, fsUnix, FileSystem);
Result := LnxRmDir(Path);
end;
//▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ MEMORY MANAGEMENT ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
// Memory management stuff. Since the Linux munmap call needs to
// know the size of the block to be disposed, but Virtual Pascal
// doesn't pass it to the functions (OS/2 and NT don't need this),
// we have to store the size of each kernel-allocated memory block
// in a special list. This is quite some unnecessary overhead in
// memory management, but at least it should work.
type
(**
* An entry of the memory block list.
*)
PMemBlock = ^TMemBlock;
TMemBlock = record
FAddress: Pointer;
FSize: LongInt;
end;
(*
* The list of memory blocks.
*)
PMemBlockList = ^TMemBlockList;
TMemBlockList = array[0..MaxInt div SizeOf(TMemBlock) - 1] of TMemBlock;
var
(**
* Points to the list of currently
* allocated memory blocks.
*)
MemBlockList: PMemBlockList = nil;
(**
* Holds the number of currently
* allocated memory blocks.
*)
MemBlockCount: LongInt = 0;
(**
* Holds the current size of the
* memory block list.
*)
MemBlockLimit: LongInt = 0;
const
(**
* The growth of the memory block
* list. 512 * 8 bytes is exactly
* one page.
*)
MemBlockDelta = 4096 div SizeOf(TMemBlock);
(**
* Adds a block to the list of currrently
* allocated memory blocks.
*)
procedure SysMemAddBlock(Address: Pointer; Size: LongInt);
var
TmpList: Pointer;
TmpLimit: LongInt;
begin
if MemBlockCount = MemBlockLimit then
begin
TmpLimit := MemBlockLimit + MemBlockDelta;
TmpList := LnxMMap(nil, TmpLimit * SizeOf(TMemBlock), HeapAllocFlags, MAP_ANON or MAP_COPY, 0, 0);
if (LongInt(TmpList) >= -4095) and (LongInt(TmpList) <= 0) then
begin
WriteLn('Internal error in SysMemAddBlock: mmap failed.');
Halt(255);
end;
if MemBlockLimit <> 0 then
begin
Move(MemBlockList^, TmpList^, MemBlockLimit * SizeOf(TMemBlock));
if LnxMUnmap(MemBlockList, MemBlockLimit * SizeOf(TMemBlock)) <> 0 then
begin
WriteLn('Internal error in SysMemAddBlock: munmap failed.');
Halt(255);
end;
end;
MemBlockList := TmpList;
MemBlockLimit := TmpLimit;
end;
with MemBlockList^[MemBlockCount] do
begin
FAddress := Address;
FSize := Size;
end;
// Write('AddBlock(', MemBlockCount, ', ', LongInt(Address), ', ', Size, ')', #10);
Inc(MemBlockCount);
// Write(MemBlockCount, ' ');
end;
(**
* Deletes a block from the list of currrently
* allocated memory blocks. Returns its size.
*)
function SysMemDeleteBlock(Address: Pointer): LongInt;
var
I: LongInt;
begin
I := MemBlockCount - 1;
while (I <> -1) and (MemBlockList^[I].FAddress <> Address) do
Dec(I);
if I <> - 1 then
begin
Result := MemBlockList^[I].FSize;
Move(MemBlockList^[I + 1], MemBlockList^[I], (MemBlockCount - I - 1) * SizeOf(TMemBlock));
Dec(MemBlockCount);
end
else
begin
WriteLn('Internal error in SysMemDeleteBlock: block ', LongInt(Address), ' not found.');
Halt(255);
end;
end;
function SysMemAvail: Longint;
var
Info: TSysInfo;
begin
LnxSysInfo(Info);
Result := Info.FreeRam + Info.FreeSwap;
end;
function SysMemAlloc(Size,Flags: Longint; var MemPtr: Pointer): Longint;
begin
Result := LongInt(LnxMMap(nil, Size, Flags, MAP_ANON or MAP_COPY, 0, 0));
if (Result < -4095) or (Result > 0) then
begin
MemPtr := Pointer(Result);
SysMemAddBlock(MemPtr, Size);
Result := 0;
end
else
begin
Result := -Result;
MemPtr := nil;
end;
end;
function SysMemFree(MemPtr: Pointer): Longint;
begin
Result := -LnxMUnmap(MemPtr, SysMemDeleteBlock(MemPtr));
end;
function SysSysMsCount: Longint;
var
TimeVal: TTimeVal;
TimeZone: TTimeZone;
begin
if LnxGetTimeOfDay(TimeVal, TimeZone) = 0 then
Result := TimeVal.tv_Sec*1000 + TimeVal.tv_USec div 1000
else
Result := 0;
end;
procedure SysSysSelToFlat(var P: Pointer);
begin
// Nothing to do.
end;
procedure SysSysFlatToSel(var P: Pointer);
begin
// Nothing to do.
end;
function SysCtrlSelfAppType: Longint;
begin
// Hardcoded: Text mode
Result := 2;
end;
//▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ THREAD MANAGEMENT ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
// Since Linux does not have thread IDs starting from 1, but
// assigns each thread a unique process ID instead, we need
// a mapping between TIDs and PIDs.
const
MaxThread = 256; // Maximum number of threads
tsRunning = 0; // Thread is up and running
tsSuspended = 1; // Thread has been suspended
tsTerminated = 2; // Thread has (been) terminated
type
PThreadInfo = ^TThreadInfo;
TThreadInfo = record // Thread information structure
ExceptChain: Pointer; // Head of exception registration chain
Stack: Pointer; // Lower limit of stack
StackLimit: Pointer; // Upper limit of stack
Handle: LongInt; // One-based thread handle
ThreadPid: LongInt; // PID of thread itself
ProcessPid: LongInt; // PID of process to which thread belongs
State: LongInt; // State of thread
TibSelector: LongInt; // Selector pointing to thread information block
end;
var
Threads: array[1..MaxThread] of PThreadInfo; // List of threads
MainThread: TThreadInfo = ( // Thread info block for main thread
ExceptChain: nil;
Stack: Pointer($C0000000);
StackLimit: Pointer($C0000000);
Handle: 1;
ThreadPid: 0;
ProcessPid: 0;
State: tsRunning;
TibSelector: 0
);
ThreadSemaphore: LongInt = 0; // Thread info list access semaphore
(**
* Adds a thread, returns the info block or -1, if no more threads can
* be created.
*)
function AddThreadInfo(StackSize, Flags: LongInt): PThreadInfo;
var
Index: LongInt;
begin
Index := 1;
while Index <= MaxThread do
begin
if Threads[Index] = nil then
begin
New(Result);
Threads[Index] := Result;
with Result do
begin
ExceptChain := nil;
if StackSize <> 0 then
begin
GetMem(Stack, StackSize);
StackLimit := Stack;
Inc(LongInt(StackLimit), StackSize);
end;
Handle := Index;
ThreadPid := 0;
ProcessPid := LnxGetPid;
State := Flags and 1;
TibSelector := 0;
end;
Exit;
end;
Inc(Index);
end;
Result := nil;
end;
(**
* Removes a thread.
*)
procedure RemoveThreadInfo(Thread: PThreadInfo);
var
Handle: LongInt;
begin
if Thread.Stack <> nil then FreeMem(Thread.Stack);
Handle := Thread.Handle;
Dispose(Threads[Handle]);
Threads[Handle] := nil;
end;
function GetThread(Handle: LongInt): PThreadInfo;
begin
SysSysWaitSem(ThreadSemaphore);
if (Handle < 1) or (Handle > MaxThread) or (Threads[Handle] = nil) then
Result := nil
else
Result := Threads[Handle];
ThreadSemaphore := 0;
end;
// State signal handler
procedure HandleStateSignal(SigNum: LongInt); cdecl; {&Frame-}
asm
@@LOOP:
mov eax, fs:[0].TThreadInfo.State
cmp eax, tsRunning
je @@RET
cmp eax, tsTerminated
je SysCtrlExitThread
mov eax, esp
push 0
call LnxSigSuspend
pop eax
@@RET:
end;
// Child signal handler
procedure HandleChildSignal(SigNum: LongInt); cdecl; {&Frame-}
var
I: LongInt;
begin
// Make sure all child signals go to the main thread.
if GetThreadID <> 1 then
begin
LnxKill(MainThread.ProcessPid, SIGCHLD);
Exit;
end;
// Walk the thread list and remove the blocks
// of all terminated threads.
SysSysWaitSem(ThreadSemaphore);
for I := 2 to MaxThread do
begin
if Threads[I] <> nil then
if Threads[I].State = tsTerminated then
RemoveThreadInfo(Threads[I]);
end;
ThreadSemaphore := 0;
end;
function SysCtrlGetTlsMapMem: Pointer;
begin
// Implementation using normal memory, for the time being.
// Shared memory will have to be used later, in order for DLLs
// to work with TLS.
SysMemAlloc(SharedMemSize, $06, Result);
FillChar(Result^, SharedMemSize, $FF);
FillChar(Result^, SizeOf(TSharedMem), 0);
with PSharedMem(Result)^ do
begin
// Set up pointers to functions to use when allocating memory
TlsMemMgr := System.GetPMemoryManager;
// Set up pointer to function managing the TlsSemaphore
TlsSemMgr := @SysSysWaitSem;
// Initialise the TlsSemaphore
TlsSemaphore := 0;
end;
end;
function SysCtrlKillThread(Handle: Longint): Longint;
var
Thread: PThreadInfo;
begin
Thread := GetThread(Handle);
if Thread <> nil then
begin
Thread.State := tsTerminated;
Result := -LnxKill(Thread.ThreadPid, SIGUSR1);
end
else
Result := ESRCH;
end;
function SysCtrlSuspendThread(Handle: Longint): Longint;
var
Thread: PThreadInfo;
begin
Thread := GetThread(Handle);
if Thread <> nil then
begin
Thread.State := tsSuspended;
Result := -LnxKill(Thread.ThreadPid, SIGUSR1);
end
else
Result := ESRCH;
end;
function SysCtrlResumeThread(Handle: Longint): Longint;
var
Thread: PThreadInfo;
begin
Thread := GetThread(Handle);
if Thread <> nil then
begin
Thread.State := tsRunning;
Result := -LnxKill(Thread.ThreadPid, SIGUSR1);
end
else
Result := ESRCH;
end;
procedure SysCtrlExitThread(ExitCode: Longint);
begin
asm
mov fs:[0].TThreadInfo.State, tsTerminated
end;
// If the main thread terminates, this is also
// the termiantion of the whole process.
if GetThreadID = 1 then
SysCtrlExitProcess(ExitCode);
LnxExit(ExitCode);
end;
procedure SysCtrlExitProcess(ExitCode: Longint);
var
I, J: LongInt;
begin
I := GetThreadID;
// Kill all threads except the current one.
for J := 1 to MaxThread do
if (I <> J) and (Threads[J] <> nil) then
KillThread(J);
TrmDone;
LnxExit(ExitCode);
end;
// Creates a new selector in the process' local descriptor table
// and returns it. * If the result is zero, something went wrong.
function GetNewSelector(Index: LongInt; Address: Pointer; Size: LongInt): Word;
var
LDT: TModifyLDT;
begin
LDT.Index := Index;
LDT.Base := Address;
LDT.Limit := Size - 1;
LDT.Flags := 64; // 64: Segment is usable
if LnxModifyLDT(1, LDT, SizeOf(LDT)) = 0 then
Result := Index shl 3 or 7 // 7: LDT entry, user priveleges
else
Result := 0;
end;
function SysGetThreadId: Longint;
asm
mov eax, fs:[0].TThreadInfo.ThreadPid
end;
function SysCtrlCreateThread(Attrs: Pointer; StackSize: Longint; Func,Param: Pointer; Flags: Longint; var Tid: Longint): Longint;
const
CloneFlags = CLONE_VM or CLONE_FS or CLONE_FILES or SIGCHLD;
var
Thread: PThreadInfo;
begin
SysSysWaitSem(ThreadSemaphore);
// Try to get a new thread handle
Thread := AddThreadInfo(StackSize, Flags and 1);
if Thread = nil then
begin
Result := -1;
ThreadSemaphore := 0;
Exit;
end;
// Create thread
asm
mov edx, Thread;
mov ecx, [edx].TThreadInfo.StackLimit;
mov eax, Param;
sub ecx, 4;
mov [ecx], eax;
mov eax, Func;
sub ecx, 4;
mov [ecx], eax;
mov eax, [edx].TThreadInfo.Handle // LDT entry = thread handle
sub ecx, 4;
mov DWORD [ecx], eax;
sub ecx, 4;
mov [ecx], edx;
sub ecx, 4;
mov DWORD [ecx], TYPE TThreadInfo;
// Create the new thread
mov eax, 120;
mov ebx, CloneFlags;
int $80;
// Both threads land here. Check whether we deal with
// the parent (EAX=new PID) or the child (EAX=0).
or eax, eax;
jnz @Parent;
// Create FS selector for new thread. The arguments
// are already on the stack.
call GetNewSelector;
mov fs, ax;
mov fs:[0].TThreadInfo.TibSelector, fs;
// Let the thread wait until the parent has
// finished the initialization of the thread
// control block.
push OFFSET ThreadSemaphore
call SysSysWaitSem
btr ThreadSemaphore, 0
// Call handle state signal to hold back
// those threads that shall be created in
// suspended state. Clean up stack, since
// this is a C function.
push SIGUSR1;
call HandleStateSignal;
pop eax;
// Call real thread function for child thread.
pop eax;
call eax;
// Terminate child thread. Normally, this should be
// done by code from the System unit, but just in case...
mov ebx, eax;
mov eax, 1;
int $80;
@Parent:
// Store the new PID
mov [edx].TThreadInfo.ThreadPid, eax;
end;
if Thread.ThreadPid < 1 then
begin
Result := -Thread.ThreadPid;
RemoveThreadInfo(Thread);
ThreadSemaphore := 0;
Exit;
end;
Tid := Thread.Handle;
Result := 0;
ThreadSemaphore := 0;
end;
function SysCtrlGetModuleName(Handle: Longint; Buffer: PChar): Longint;
begin
Unimplemented('SysCtrlGetModuleName');
end;
procedure SysCtrlEnterCritSec;
begin
Unimplemented('SysCtrlEnterCritSec');
end;
procedure SysCtrlLeaveCritSec;
begin
Unimplemented('SysCtrlLeaveCritSec');
end;
//▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ ENVIRONMENT ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
type
TPCharArray = array[0..1023] of PChar;
PPCharArray = ^TPCharArray;
var
Env: PPCharArray;
Argv: PPCharArray;
Argc: LongInt;
function SysCmdln: PChar;
begin
Result := Argv^[0];
end;
function SysCmdlnCount: Longint;
begin
Result := Argc - 1;
end;
procedure SysCmdlnParam(Index: Longint; var Param: ShortString);
var
Buffer1, Buffer2: TFileNameBuf;
P: PChar;
L: LongInt;
begin
if (Index < 0) or (Index >= Argc) then
Param := ''
else
if Index = 0 then
begin
L := LnxReadLink('/proc/self/exe', @Buffer1, SizeOf(Buffer1) - 1);
if L > 0 then
begin
Buffer1[L] := #0;
P := @Buffer1;
end
else
P := Argv^[0];
Param := StrPas(SysConvertFileName(@Buffer2, P, FileSystem, fsUnix));
end
else
Param := StrPas(Argv^[Index]);
end;
function SysGetEnvironment: PChar;
begin
Result := Env^[0];
end;
function SysGetEnvString(EnvVar, Default: PChar): PChar;
var
P: PChar;
L: Word;
begin
L := StrLen(EnvVar);
P := SysGetEnvironment;
while P^ <> #0 do
begin
if (StrLIComp(P, EnvVar, L) = 0) and (P[L] = '=') then
begin
Result := P + L + 1;
Exit;
end;
Inc(P, StrLen(P) + 1);
end;
Result := Default;
end;
function SysOsVersion: Longint;
var
Handle, Actual, Error, Dot, VerLo, VerHi: LongInt;
Buffer: ShortString;
begin
Result := 0;
if SysFileOpen('/proc/version', OPEN_ACCESS_READONLY, Handle) = 0 then
begin
Error := SysFileRead(Handle, Buffer[1], 255, Actual);
SysFileClose(Handle);
if Error = 0 then
begin
SetLength(Buffer, Actual);
Dot := Pos('version ', Buffer);
Delete(Buffer, 1, Dot + 7);
Dot := Pos('.', Buffer + '.');
Val(Copy(Buffer, 1, Dot - 1), VerHi, Error);
Delete(Buffer, 1, Dot);
Dot := Pos('.', Buffer + '.');
Val(Copy(Buffer, 1, Dot - 1), VerLo, Error);
Delete(Buffer, 1, Dot);
Result := VerLo shl 8 + VerHi;
end;
end;
end;
function SysPlatformID: Longint;
begin
Result := -3;
end;
procedure SysGetDateTime(Year,Month,Day,DayOfWeek,Hour,Minute,Second,MSec: PLongint);
var
TimeVal: TTimeVal;
TimeZone: TTimeZone;
DateTime: TDateTime;
begin
LnxGetTimeOfDay(TimeVal, TimeZone);
DateTime := UnpackUTCTime(TimeVal.tv_Sec - TimeZone.tz_MinutesWest * 60);
if Year <> nil then Year^ := DateTime.Year;
if Month <> nil then Month^ := DateTime.Month;
if Day <> nil then Day^ := DateTime.Day;
if DayOfWeek <> nil then DayOfWeek^ := DateTime.DayOfWeek;
if Hour <> nil then Hour^ := DateTime.Hour;
if Minute <> nil then Minute^ := DateTime.Min;
if Second <> nil then Second^ := DateTime.Sec;
if MSec <> nil then MSec^ := TimeVal.tv_USec div 1000;
end;
procedure SysSetDateTime(Year,Month,Day,Hour,Minute,Second,MSec: PLongint);
var
TimeVal: TTimeVal;
TimeZone: TTimeZone;
DateTime: TDateTime;
begin
LnxGetTimeOfDay(TimeVal, TimeZone);
DateTime := UnpackUTCTime(TimeVal.tv_Sec - TimeZone.tz_MinutesWest * 60);
if Year <> nil then DateTime.Year := Year^;
if Month <> nil then DateTime.Month := Month^;
if Day <> nil then DateTime.Day := Day^;
if Hour <> nil then DateTime.Hour := Hour^;
if Minute <> nil then DateTime.Min := Minute^;
if Second <> nil then DateTime.Sec := Second^;
if MSec <> nil then TimeVal.tv_USec := 1000 * MSec^;
TimeVal.tv_Sec := PackUTCTime(DateTime);
Inc(TimeVal.tv_Sec, TimeZone.tz_MinutesWest * 60);
LnxSetTimeOfDay(TimeVal, TimeZone);
end;
//▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ DISK FUNCTIONS ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
const
VerifyFlag: Boolean = False;
function SysVerify(SetValue: Boolean; Value: Boolean): Boolean;
begin
Result := VerifyFlag;
if SetValue then
VerifyFlag := Value;
end;
function SysDiskFreeLong(Drive: Byte): TQuad;
var
Buffer: TStatFS;
begin
if (Drive <> 0) and (Drive <> 3) then
begin
Result := -1;
Exit;
end;
if LnxStatFS('/', Buffer) = 0 then
Result := 1.0 * Buffer.f_BSize * Buffer.f_BAvail
else
Result := -1;
end;
function SysDiskSizeLong(Drive: Byte): TQuad;
var
Buffer: TStatFS;
begin
if (Drive <> 0) and (Drive <> 3) then
begin
Result := -1;
Exit;
end;
if LnxStatFS('/', Buffer) = 0 then
Result := 1.0 * Buffer.f_BSize * Buffer.f_Blocks
else
Result := -1;
end;
function SysGetFileAttr(FileName: PChar; var Attr: Longint): Longint;
var
Stat: TStat;
Buffer: TFileNameBuf;
begin
FileName := SysConvertFileName(@Buffer, FileName, fsUnix, FileSystem);
Result := -LnxStat(FileName, Stat);
Attr := 0;
if Stat.st_Mode and S_IFDIR <> 0 then Attr := Attr or $10;
if Stat.st_Mode and S_IWUSR = 0 then Attr := Attr or $01;
if FileName[0] = '.' then Attr := Attr or $02;
end;
function SysSetFileAttr(FileName: PChar; Attr: Longint): Longint;
var
Stat: TStat;
Buffer: TFileNameBuf;
begin
FileName := SysConvertFileName(@Buffer, FileName, fsUnix, FileSystem);
Result := -LnxStat(FileName, Stat);
if Result <> 0 then Exit;
if Attr and $10 <> 0 then
Stat.st_Mode := Stat.st_Mode or S_IFDIR
else
Stat.st_Mode := Stat.st_Mode and not S_IFDIR;
if Attr and $01 = 0 then
Stat.st_Mode := Stat.st_Mode or S_IWUSR
else
Stat.st_Mode := Stat.st_Mode and not S_IWUSR;
Result := -LnxChMod(FileName, Stat.st_Mode)
end;
function SysGetFileTime(Handle: Longint; var Time: Longint): Longint;
var
Stat: TStat;
TimeVal: TTimeVal;
TimeZone: TTimeZone;
DateTime: TDateTime;
begin
Result := -LnxFStat(Handle, Stat);
LnxGetTimeOfDay(TimeVal, TimeZone);
DateTime := UnpackUTCTime(Stat.st_Mtime - TimeZone.tz_MinutesWest * 60);
PackDosTime(DateTime, Time);
end;
function SysSetFileTime(Handle: Longint; Time: Longint): Longint;
var
Stat: TStat;
TimeVal: TTimeVal;
TimeZone: TTimeZone;
DateTime: TDateTime;
Buf: TUTimBuf;
FileName: string;
begin
LnxFStat(Handle, Stat);
LnxGetTimeOfDay(TimeVal, TimeZone);
UnpackDosTime(Time, DateTime);
Buf.modtime := PackUTCTime(DateTime);
Inc(Buf.modtime, TimeZone.tz_MinutesWest * 60);
buf.actime := Stat.st_ATime;
Str(Handle, FileName);
FileName := '/proc/self/fd/' + FileName + #0;
Result := -LnxUTime(@FileName[1], Buf);
end;
// Compare a string with a pattern. The pattern can contain any
// combination of * and ? characters. The string can be up to 253
// characters in length, and the pattern up to 252.
// The text must not contain ascii 0 characters.
function MatchStr(Pat, Txt: string): Boolean;
var
SubLen, ComPos, NextStar, SubPos: LongInt;
begin
// First make sure that the pattern doesn't start with *, and always
// ends with *. Change the text accordingly.
Pat := #0 + Pat + #0 + '*';
Txt := #0 + Txt + #0;
Result := True;
while (Pat <> '') and Result do
begin
// Look for the first *. At least 1 character before this will be
// a normal character, i.e. neither ? nor *
NextStar := Pos('*', Pat);
SubLen := NextStar - 1;
// Ignore double-*
while (NextStar < Length(Pat)) and (Pat[NextStar + 1] = '*') do
Inc(NextStar);
SubPos := 0;
repeat
Inc(SubPos);
Result := True;
ComPos := 0;
while (ComPos < SubLen) and Result do
begin
if (Txt[SubPos + ComPos] <> Pat[ComPos + 1]) and
(Pat[ComPos + 1] <> '?') then
Result := False;
Inc(ComPos);
end;
until (SubPos + SubLen > Length(Txt)) or Result;
// When a match is found, cut a piece off the text and continue.
if Result then
begin
Delete(Txt, 1, SubPos + SubLen - 1);
Delete(Pat, 1, NextStar);
end;
end;
end;
function DoFindFile(var F: TOSSearchRec): Longint;
var
Buffer: TDirEnt;
Stat: TStat;
FileName: TFileNameBuf;
DateTime: TDateTime;
TimeVal: TTimeVal;
TimeZone: TTimeZone;
Ok: Boolean;
I: LongInt;
begin
repeat
Result := -LnxReadDir(F.Handle, Buffer, 1);
case Result of
-1: Result := 0;
0: begin
Result := 254;
Exit;
end;
else
Exit;
end;
F.Name := StrPas(@Buffer.d_Name);
StrCopy(@FileName, @F.FindDir);
StrCopy(StrEnd(@FileName), '/');
StrCopy(StrEnd(@FileName), @Buffer.d_Name);
LnxStat(@FileName, Stat);
F.Size := Stat.st_Size;
F.Attr := 0;
if Stat.st_Mode and S_IFDIR <> 0 then F.Attr := F.Attr or $10;
if Stat.st_Mode and S_IWUSR = 0 then F.Attr := F.Attr or $01;
LnxGetTimeOfDay(TimeVal, TimeZone);
DateTime := UnpackUTCTime(Stat.st_Mtime - TimeZone.tz_MinutesWest * 60);
PackDosTime(DateTime, F.Time);
Ok := (F.FindAttr and F.Attr = F.Attr)
and (MatchStr(F.FindName, F.Name) or (F.FindName = '*') or (F.FindName = '*.*'))
and SysIsValidFileName(@Buffer.d_Name, FileSystem);
until Ok;
end;
function SysFindFirst(Path: PChar; Attr: Longint; var F: TOSSearchRec; IsPChar: Boolean): Longint;
var
P, Q: LongInt;
Buffer: TFileNameBuf;
begin
Path := SysConvertFileName(@Buffer, Path, fsUnix, FileSystem);
Q := StrLen(Path);
P := Q;
while (P > -1) and (Path[P] <> '/') do
Dec(P);
if P <> Q then
SetString(F.FindName, @Path[P + 1], Q - P - 1)
else
F.FindName := '*';
if P <> -1 then
begin
if Path[P] = '/' then Dec(P);
Move(Path[0], F.FindDir, P + 1);
F.FindDir[P + 1] := #0;
end
else
begin
F.FindDir[0] := '.';
F.FindDir[1] := #0;
end;
F.FindAttr := Attr;
Result := SysFileOpen(@F.FindDir, OPEN_ACCESS_READONLY, F.Handle);
if Result = 0 then
Result := DoFindFile(F);
end;
function SysFindNext(var F: TOSSearchRec; IsPChar: Boolean): Longint;
begin
Result := DoFindFile(F);
end;
function SysFindClose(var F: TOSSearchRec): Longint;
begin
Result := SysFileClose(F.Handle);
end;
// Check if file exists; if it does, update FileName parameter
// to include correct case of existing file
function SysFileAsOS(FileName: PChar): Boolean;
var
Buffer: TFileNameBuf;
begin
FileName := SysConvertFileName(@Buffer, FileName, fsUnix, FileSystem);
Result := (LnxAccess(@FileName, F_OK) = 0);
end;
function SysFileSearch(Dest,Name,List: PChar): PChar;
var
I, P, L: Integer;
Buffer, NameBuffer, ListBuffer: TFileNameBuf;
begin
Name := SysConvertFileName(@NameBuffer, Name, fsUnix, FileSystem);
List := SysConvertFileName(@ListBuffer, List, fsUnix, FileSystem);
Result := Dest;
StrCopy(Buffer, Name);
P := 0;
L := StrLen(List);
while True do
begin
if LnxAccess(@Buffer, F_OK) = 0 then
begin
if SysConvertFileName(@NameBuffer, @Buffer, FileSystem, fsUnix) = @Buffer then
begin
StrCopy(@NameBuffer, @Buffer);
SysFileExpand(Dest, @NameBuffer);
end
else
SysFileExpand(Dest, @NameBuffer);
Exit;
end;
while (P < L) and (List[P] in [':', ';']) do
Inc(P);
if P >= L then
Break;
I := P;
while (P < L) and not (List[P] in [':', ';']) do
Inc(P);
StrLCopy(Buffer, List + I, P - I);
if not (List[P-1] = '/') then
StrLCat(Buffer, '/', 259);
StrLCat(Buffer, Name, 259);
end;
Dest^ := #0;
end;
function SysFileExpand(Dest,Name: PChar): PChar;
begin
Result := Dest;
if FileSystem <> fsUnix then
begin
if (Name[0] <> #0) and (Name[1] = ':') then
Inc(Name, 2);
if Name[0] <> '\' then
begin
SysDirGetCurrent(0, Dest);
if (Dest[0] = '\') and (Dest[1] = #0) then Dest[0] := #0;
StrCopy(StrECopy(StrEnd(Dest), '\'), Name);
end
else
begin
Dest[0] := 'c';
Dest[1] := ':';
StrCopy(Dest + 2, Name);
end;
end
else
begin
if Name[0] <> '/' then
begin
SysDirGetCurrent(0, Dest);
if (Dest[0] = '/') and (Dest[1] = #0) then
Dest[0] := #0;
StrCopy(StrECopy(StrEnd(Dest), '/'), Name);
end
else
StrCopy(Dest, Name);
end;
end;
threadvar
ExecProcID: LongInt;
ExecResult: LongInt;
ExecAsync: Boolean;
function SysExecute(Path,CmdLine,Env: PChar; Async: Boolean; PID: PLongint; StdIn,StdOut,StdErr: Longint): Longint;
procedure MakeArgList(Source: PChar; var Dest: TPCharArray);
var
I, J, K: LongInt;
SQ, DQ: Boolean;
begin
I := 0;
K := 0;
SQ := False;
DQ := False;
while Source[I] <> #0 do
begin
J := I;
while True do
begin
case Source[J] of
'"': if not SQ then DQ := not DQ;
'''': if not DQ then SQ := not SQ;
' ': if not (SQ or DQ) then Break;
#0: Break;
end;
Inc(J);
end;
if J > I then
begin
Source[J] := #0;
Dest[K] := @Source[I];
Inc(K);
end;
I := J;
Inc(I);
end;
Dest[K] := nil;
end;
procedure MakeEnvList(Source: PChar; var Dest: TPCharArray);
var
I, J, K: LongInt;
begin
I := 0;
K := 0;
while Source[I] <> #0 do
begin
J := I;
while Source[J] <> #0 do Inc(J);
if J > I then
begin
// WriteLn('>', Source + I, '<');
Dest[K] := @Source[I];
Inc(K);
end;
I := J;
Inc(I);
end;
Dest[K] := nil;
end;
var
Buffer: TFileNameBuf;
ArgBuf: array[0..1023] of Char;
ArgLst, EnvLst: TPCharArray;
P: PChar;
begin
Path := SysConvertFileName(@Buffer, Path, fsUnix, FileSystem);
P := StrECopy(@ArgBuf, Path);
P^ := #0;
Inc(P);
StrCopy(P, CmdLine);
MakeArgList(ArgBuf, ArgLst);
if Env <> nil then
MakeEnvList(Env, EnvLst);
ExecProcID := 0;
ExecProcID := LnxFork;
if ExecProcID = 0 then
begin
// This is what happens in the child process after the fork
if Env <> nil then
Result := LnxExecve(Path, @ArgLst, @EnvLst)
else
Result := LnxExecve(Path, @ArgLst, VpSysLow.Env);
Halt(254);
end
else
begin
// This is what happens in the parent process after the fork
if ExecProcID < 0 then
begin
Result := -ExecProcID;
Exit;
end;
ExecAsync := Async;
if PID <> nil then
PID^ := ExecProcID;
if not Async then
LnxWaitPID(ExecProcID, ExecResult, 0);
end;
end;
function SysExitCode: Longint;
begin
if ExecAsync then
LnxWaitPID(ExecProcID, ExecResult, 0);
Result := ExecResult;
end;
//▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ STRING HANDLING ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
type
TCharCaseTable = array[0..255] of Char;
var
UpperCaseTable: TCharCaseTable;
LowerCaseTable: TCharCaseTable;
AnsiUpperCaseTable: TCharCaseTable;
AnsiLowerCaseTable: TCharCaseTable;
WeightTable: TCharCaseTable;
const
CaseTablesInitialized: Boolean = False;
procedure InitCaseTables;
var
I,J: Integer;
begin
for I := 0 to 255 do
begin
UpperCaseTable[I] := Chr(I);
LowerCaseTable[I] := Chr(I);
AnsiUpperCaseTable[I] := Chr(I);
AnsiLowerCaseTable[I] := Chr(I);
if I in [Ord('A')..Ord('Z')] then
LowerCaseTable[I] := Chr(I + (Ord('a')-Ord('A')));
if I in [Ord('a')..Ord('z')] then
UpperCaseTable[I] := Chr(I - (Ord('a')-Ord('A')));
end;
SysGetCaseMap(SizeOf(AnsiUpperCaseTable), AnsiUpperCaseTable);
for I := 0 to 255 do
begin
J := Ord(AnsiUpperCaseTable[I]);
if (J <> I) {and (AnsiLowerCaseTable[J] <> chr(J))} then
AnsiLowerCaseTable[J] := Chr(I);
end;
SysGetWeightTable(SizeOf(WeightTable), WeightTable);
CaseTablesInitialized := True;
end;
procedure ConvertCase(S1,S2: PChar; Count: Integer; var Table: TCharCaseTable); {&USES esi,edi} {&FRAME-}
asm
cmp CaseTablesInitialized,0
jne @@1
Call InitCaseTables
@@1:
xor eax,eax
mov esi,S1
mov edi,S2
mov ecx,Count
mov edx,Table
jecxz @@3
@@2:
dec ecx
mov al,[esi+ecx]
mov al,[edx+eax]
mov [edi+ecx],al
jnz @@2
@@3:
end;
procedure SysChangeCase(Source, Dest: PChar; Len: Longint; NewCase: TCharCase);
begin
case NewCase of
ccLower: ConvertCase(Source, Dest, Len, LowerCaseTable);
ccUpper: ConvertCase(Source, Dest, Len, UpperCaseTable);
ccAnsiLower: ConvertCase(Source, Dest, Len, AnsiLowerCaseTable);
ccAnsiUpper: ConvertCase(Source, Dest, Len, AnsiUpperCaseTable);
end;
end;
function SysLowerCase(s: PChar): PChar;
begin
ConvertCase(s, s, strlen(s), AnsiLowerCaseTable);
Result := s;
end;
function SysUpperCase(s: PChar): PChar;
begin
ConvertCase(s, s, strlen(s), AnsiUpperCaseTable);
Result := s;
end;
function MemComp(P1,P2: Pointer; L1,L2: Integer; T1,T2: PChar): Integer; {&USES ebx,esi,edi,ebp} {&FRAME-}
asm
cmp CaseTablesInitialized,0
jne @@0
Call InitCaseTables
@@0:
mov ecx,L1
mov eax,L2
mov esi,P1
mov edi,P2
cmp ecx,eax
jbe @@1
mov ecx,eax
@@1:
mov ebx,T1
mov ebp,T2
xor eax,eax
xor edx,edx
test ecx,ecx
jz @@5
@@2:
mov al,[esi]
mov dl,[edi]
inc esi
inc edi
test ebp,ebp
mov al,[ebx+eax] // Table1
mov dl,[ebx+edx]
jz @@3
mov al,[ebp+eax] // Table2
mov dl,[ebp+edx]
@@3:
cmp al,dl
jne @@RET
dec ecx
jnz @@2
@@5:
mov eax,L1
mov edx,L2
@@RET:
sub eax,edx
end;
function SysCompareStrings(s1, s2: PChar; l1, l2: Longint; IgnoreCase: Boolean): Longint;
begin
if IgnoreCase then
Result := MemComp(s1, s2, l1, l2, @WeightTable, nil)
else
Result := MemComp(s1, s2, l1, l2, @AnsiUpperCaseTable, @WeightTable);
end;
procedure SysGetCaseMap(TblLen: Longint; Tbl: PChar );
var
I: LongInt;
begin
for I := 0 to TblLen - 1 do
Tbl[I] := UpCase(Tbl[I]);
end;
procedure SysGetWeightTable(TblLen: Longint; WeightTable: PChar);
var
I: LongInt;
begin
for I := 0 to TblLen - 1 do
WeightTable[I] := Chr(I);
end;
function SysGetCodePage: Longint;
begin
Result := 1004; // ISO-Latin-1
end;
procedure SysCtrlSetCBreakHandler;
begin
// Unimplemented('SysCtrlSetCBreakHandler');
end;
function SysFileIncHandleCount(Count: Longint): Longint;
begin
Result := 0;
end;
//▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ SCREEN AND KEYBOARD ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
var
// Terminal in/out handle
TrmHandle: LongInt = -1;
// Saved terminal attributes
TrmSaveAttr: TTermios;
function TrmInit: string;
var
Attr: TTermios;
Ctrl: string;
begin
// Get terminal name
Result := StrPas(SysGetEnvString('TERM', 'unknown'));
// If already initialized, return immediately
if TrmHandle <> -1 then Exit;
// Open device
TrmHandle := LnxOpen('/dev/tty', O_RDWR, 0);
// Get terminal information and store it
LnxIoCtl(TrmHandle, TCGETS, @Attr);
TrmSaveAttr := Attr;
// Change some flags
with Attr do
begin
c_lflag := c_lflag and not (ECHO or ICANON or IEXTEN);
c_iflag := c_iflag and not (INPCK or ISTRIP or IXON);
c_cflag := c_cflag and not (CSIZE or PARENB);
c_cflag := c_cflag or CS8;
c_oflag := c_oflag and not (OPOST);
c_cc[VMIN] := 1;
c_cc[VTIME] := 0;
end;
// Activate the new terminal settings
LnxIoCtl(TrmHandle, TCSETS, @Attr);
// Enter XMIT mode
Ctrl := #27'[?1h'; // #27'='; // #27'[?7l';
LnxWrite(TrmHandle, Ctrl[1], Length(Ctrl));
end;
procedure TrmDone;
var
Ctrl: string;
begin
// Reset old terminal settings
if TrmHandle <> -1 then
begin
LnxIoCtl(TrmHandle, TCSETS, @TrmSaveAttr);
// Enter LOCAL mode
Ctrl := #27'[?1l'; // #27'>'; // #27'[?7h';
LnxWrite(TrmHandle, Ctrl[1], Length(Ctrl));
// Reset all attributes, activate normal character set
Ctrl := #27'[0m'#27'(B';
LnxWrite(TrmHandle, Ctrl[1], Length(Ctrl));
// Free terminal handle
LnxClose(TrmHandle);
TrmHandle := -1;
end;
end;
function TrmRead(var Buffer; Count: Integer): Integer;
begin
Result := LnxRead(TrmHandle, Buffer, Count);
end;
function TrmWrite(const Buffer; Count: Integer): Integer;
begin
Result := LnxWrite(TrmHandle, Buffer, Count);
end;
const
{ Video modes }
MON1 = $FE; { Monochrome, ASCII chars only }
MON2 = $FD; { Monochrome, graphics chars }
COL1 = $FC; { Color, ASCII chars only }
COL2 = $FB; { Color, graphics chars }
type
// A single cell on the screen
TScrCell = record
Chr: Char; // Character
Att: Byte; // Attribute
end;
// A buffer for the whole screen
TScrBuffer = array[0..8191] of TScrCell;
PScrBuffer = ^TScrBuffer;
var
// Current screen mode
ScrMode: Integer;
// Screen buffer
ScrBuffer: PScrBuffer;
// Screen size and coordinates
ScrWidth, ScrHeight, ScrColors, ScrSize, ScrRow, ScrColumn: Integer;
// True if Cursor is visible
ScrCursor: Boolean = True;
// Color table
ScrPalette: array[0..7] of Byte;
// Graphics character table
ScrGraphs: array[#00..#31] of Char;
const
// --- Table for mapping 'ESC <0..9>' to scancodes --------------------
KbdScanCtlNum: array['0'..'9'] of SmallWord =
// 0 1 2 3 4 5 6 7 8 9
($8100, $7800, $7900, $7A00, $7B00, $7C00, $7D00, $7E00, $7F00, $8000);
// --- Table for mapping 'ESC <0..9>' to scancodes --------------------
KbdScanAltNum: array['0'..'9'] of SmallWord =
// 0 1 2 3 4 5 6 7 8 9
($8100, $7800, $7900, $7A00, $7B00, $7C00, $7D00, $7E00, $7F00, $8000);
// --- Table for mapping 'ESC <A..Z>' to scancodes --------------------
KbdScanAltChr: array['A'..'Z'] of SmallWord =
// A B C D E F G H I J
($1E00, $3000, $2E00, $2000, $1200, $2100, $2200, $2300, $1700, $2400,
// K L M N O P Q R S T
$2500, $2600, $3200, $3100, $1800, $1900, $1000, $1300, $1F00, $1400,
// U V W X Y Z
$1600, $2F00, $1100, $2D00, $1500, $2C00);
// --- Table for mapping 'ESC O <A..Z>' to scancodes ------------------
KbdScanNrmFn1: array['A'..'Z'] of SmallWord =
// UP DOWN RIGHT LEFT ----- END ----- HOME ----- -----
($4800, $5000, $4D00, $4B00, $0000, $4F00, $0000, $4700, $0000, $0000,
// ----- ----- ENTER ----- ----- F1 F2 F3 F4 -----
$0000, $0000, $1C0D, $0000, $0000, $3B00, $3C00, $3D00, $3E00, $0000,
// ----- ----- ----- ----- ----- -----
$0000, $0000, $0000, $0000, $0000, $0000);
KbdScanSftFn1: array['A'..'Z'] of SmallWord =
// UP DOWN RIGHT LEFT ----- END ----- HOME ----- -----
($4800, $5000, $4D00, $4B00, $0000, $4F00, $0000, $4700, $0000, $0000,
// ----- ----- ENTER ----- ----- F1 F2 F3 F4 -----
$0000, $0000, $1C0D, $0000, $0000, $5400, $5500, $5600, $5700, $0000,
// ----- ----- ----- ----- ----- -----
$0000, $0000, $0000, $0000, $0000, $0000);
KbdScanCtlFn1: array['A'..'Z'] of SmallWord =
// UP DOWN RIGHT LEFT ----- END ----- HOME ----- -----
($8D00, $9100, $7400, $7300, $0000, $7500, $0000, $7700, $0000, $0000,
// ----- ----- ENTER ----- ----- F1 F2 F3 F4 -----
$0000, $0000, $1C0A, $0000, $0000, $5E00, $5F00, $6000, $6100, $0000,
// ----- ----- ----- ----- ----- -----
$0000, $0000, $0000, $0000, $0000, $0000);
// --- Table for mapping 'ESC ESC O <A..Z>' to scancodes --------------
KbdScanAltFn1: array['A'..'Z'] of SmallWord =
// UP DOWN RIGHT LEFT ----- END ----- HOME ----- -----
($9800, $A000, $9D00, $9B00, $0000, $9F00, $0000, $9700, $0000, $0000,
// ----- ----- ENTER ----- ----- F1 F2 F3 F4 -----
$0000, $0000, $1C00, $0000, $0000, $6800, $6900, $6A00, $6B00, $0000,
// ----- ----- ----- ----- ----- -----
$0000, $0000, $0000, $0000, $0000, $0000);
// --- Table for mapping 'ESC O <a..z>' to scancodes ------------------
KbdScanNrmFn2: array['a'..'z'] of SmallWord =
// ----- ----- ----- ----- ----- ----- ----- ----- ----- -----
($0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000,
// ----- ----- ----- ----- ----- ----- ----- ----- ----- F5
$0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $3F00,
// F6 F7 F8 F9 F10 -----
$4000, $4100, $4200, $4300, $4400, $0000);
// --- Table for mapping 'ESC O <a..z>' to scancodes ------------------
KbdScanSftFn2: array['a'..'z'] of SmallWord =
// ----- ----- ----- ----- ----- ----- ----- ----- ----- -----
($0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000,
// ----- ----- ----- ----- ----- ----- ----- ----- ----- F5
$0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $5800,
// F6 F7 F8 F9 F10 -----
$5900, $5A00, $5B00, $5C00, $5D00, $0000);
// --- Table for mapping 'ESC O <a..z>' to scancodes ------------------
KbdScanCtlFn2: array['a'..'z'] of SmallWord =
// ----- ----- ----- ----- ----- ----- ----- ----- ----- -----
($0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000,
// ----- ----- ----- ----- ----- ----- ----- ----- ----- F5
$0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $6200,
// F6 F7 F8 F9 F10 -----
$6300, $6400, $6500, $6600, $6700, $0000);
// --- Table for mapping 'ESC ESC O <a..z>' to scancodes --------------
KbdScanAltFn2: array['a'..'z'] of SmallWord =
// ----- ----- ----- ----- ----- ----- ----- ----- ----- -----
($0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000,
// ----- ----- ----- ----- ----- ----- ----- ----- ----- F5
$0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $6C00,
// F6 F7 F8 F9 F10 -----
$6D00, $6E00, $6F00, $7000, $7100, $0000);
// --- Table for mapping 'ESC [ <1..26> ~' to scancodes ---------------
KbdScanNrmFn3: array[1..26] of SmallWord =
// HOME INS DEL END PGUP PGDN ----- ----- ----- -----
($4700, $5200, $5300, $4F00, $4900, $5100, $0000, $0000, $0000, $0000,
// F1 F2 F3 F4 F5 ----- F6 F7 F8 F9
$3B00, $3C00, $3D00, $3E00, $3F00, $0000, $4000, $4100, $4200, $4300,
// F10 ----- F11 F12 ----- -----
$4400, $0000, $8500, $8600, $0000, $0000);
// --- Table for mapping 'ESC [ <1..26> ~' to scancodes ---------------
KbdScanSftFn3: array[1..26] of SmallWord =
// HOME INS DEL END PGUP PGDN ----- ----- ----- -----
($4700, $0500, $0700, $4F00, $4900, $5100, $0000, $0000, $0000, $0000,
// F1 F2 F3 F4 F5 ----- F6 F7 F8 F9
$5400, $5500, $5600, $5700, $5800, $0000, $5900, $5A00, $5B00, $5C00,
// F5D ----- F11 F12 ----- -----
$4400, $0000, $8700, $8800, $0000, $0000);
// --- Table for mapping 'ESC [ <1..26> ~' to scancodes ---------------
KbdScanCtlFn3: array[1..26] of SmallWord =
// HOME INS DEL END PGUP PGDN ----- ----- ----- -----
($7700, $0400, $0600, $7500, $8400, $7600, $0000, $0000, $0000, $0000,
// F1 F2 F3 F4 F5 ----- F6 F7 F8 F9
$5E00, $5F00, $6000, $6100, $6200, $0000, $6300, $6500, $6600, $6700,
// F10 ----- F11 F12 ----- -----
$6800, $0000, $8900, $9000, $0000, $0000);
// --- Table for mapping 'ESC ESC [ <1..26> ~' to scancodes -----------
KbdScanAltFn3: array[1..26] of SmallWord =
// HOME INS DEL END PGUP PGDN ----- ----- ----- -----
($9700, $A200, $A300, $9F00, $9900, $A100, $0000, $0000, $0000, $0000,
// F1 F2 F3 F4 F5 ----- F6 F7 F8 F9
$6800, $6900, $6A00, $6B00, $6C00, $0000, $6D00, $6E00, $6F00, $7000,
// F10 ----- F11 F12 ----- -----
$7100, $0000, $8B00, $8C00, $0000, $0000);
// --- Table for mapping 'ESC [ [ <A..E>' to scancodes ----------------
KbdScanNrmFn5: array['A'..'E'] of SmallWord =
// F1 F2 F3 F4 F5
($3B00, $3C00, $3D00, $3E00, $3F00);
// --- Table for mapping 'ESC [ [ <A..E>' to scancodes ----------------
KbdScanSftFn5: array['A'..'E'] of SmallWord =
// F1 F2 F3 F4 F5
($5400, $5500, $5600, $5700, $5800);
// --- Table for mapping 'ESC [ [ <A..E>' to scancodes ----------------
KbdScanCtlFn5: array['A'..'E'] of SmallWord =
// F1 F2 F3 F4 F5
($5E00, $5F00, $6000, $6100, $6200);
// --- Table for mapping 'ESC ESC [ [ <A..E>' to scancodes ------------
KbdScanAltFn5: array['A'..'E'] of SmallWord =
// F1 F2 F3 F4 F5
($6800, $6900, $6A00, $6B00, $6C00);
var
// Thread handle of keyboard thread
KbdThreadID: LongInt = 0;
// Keyboard buffer
KbdBuffer: TPipe;
// Number of characters in the keyboard buffer
KbdBufferCount: LongInt = 0;
// Semaphore for accessing the keyboard buffer counter
KbdBufferMutex: LongInt = 0;
// Next keyboard event to be read from keyboard - needed for TV
KbdNextKey: TSysKeyEvent = (skeKeyCode: 0; skeShiftState: 0);
// Keyboard worker thread function for use in terminal
function KbdTerminalThread(Args: Pointer): LongInt;
var
I, L: SmallWord;
Buffer: array[0..15] of Char;
Key: TSysKeyEvent;
// Decode 'ESC <single character>'
procedure DecodeEscChr(C: Char);
begin
// ALT and a normal key
case C of
'0'..'9':
begin
Key.skeKeyCode := KbdScanAltNum[C];
Key.skeShiftState := Key.skeShiftState or 8; // ALT
end;
'A'..'Z':
begin
Key.skeKeyCode := KbdScanAltChr[C];
Key.skeShiftState := Key.skeShiftState or 8; // SHIFT+ALT
end;
'a'..'z':
begin
Key.skeKeyCode := KbdScanAltChr[UpCase(C)];
Key.skeShiftState := Key.skeShiftState or 8; // ALT
end;
#27:
begin
Key.skeKeyCode := $011B; // ESC ESC means ESC itself
end;
end;
end;
// Decode 'ESC <character sequence>'
procedure DecodeEscSeq(P: PChar);
var
X: Integer;
A: Boolean;
begin
if P[0] = #27 then
begin
Key.skeShiftState := Key.skeShiftState or 8; // ALT
Inc(P);
end;
if (P[0] = 'O') and (P[2] = #0) then
begin
case P[1] of
'A'..'Z':
begin
if Key.skeShiftState and 8 = 8 then
Key.skeKeyCode := KbdScanAltFn1[P[1]]
else if Key.skeShiftState and 4 = 4 then
Key.skeKeyCode := KbdScanCtlFn1[P[1]]
else if Key.skeShiftState and 2 = 2 then
Key.skeKeyCode := KbdScanSftFn1[P[1]]
else
Key.skeKeyCode := KbdScanNrmFn1[P[1]]
end;
'a'..'z':
begin
if Key.skeShiftState and 8 = 8 then
Key.skeKeyCode := KbdScanAltFn2[P[1]]
else if Key.skeShiftState and 4 = 4 then
Key.skeKeyCode := KbdScanCtlFn2[P[1]]
else if Key.skeShiftState and 2 = 2 then
Key.skeKeyCode := KbdScanSftFn2[P[1]]
else
Key.skeKeyCode := KbdScanNrmFn2[P[1]]
end;
end;
end
else if P[0] = '[' then
begin
if P[1] in ['0'..'9'] then
begin
X := Ord(P[1]) - Ord('0');
if P[2] in ['0'..'9'] then
begin
X := 10 * X + Ord(P[2]) - Ord('0');
if P[3] <> '~' then X := 0;
end
else if P[2] <> '~' then X := 0;
if X in [1..26] then
begin
if Key.skeShiftState and 8 = 8 then
Key.skeKeyCode := KbdScanAltFn3[X]
else if Key.skeShiftState and 4 = 4 then
Key.skeKeyCode := KbdScanCtlFn3[X]
else if Key.skeShiftState and 2 = 2 then
Key.skeKeyCode := KbdScanSftFn3[X]
else
Key.skeKeyCode := KbdScanNrmFn3[X];
end;
end
else if P[1] in ['A'..'D'] then
begin
if Key.skeShiftState and 8 = 8 then
Key.skeKeyCode := KbdScanAltFn1[P[1]]
else if Key.skeShiftState and 4 = 4 then
Key.skeKeyCode := KbdScanCtlFn1[P[1]]
else if Key.skeShiftState and 2 = 2 then
Key.skeKeyCode := KbdScanSftFn1[P[1]]
else
Key.skeKeyCode := KbdScanNrmFn1[P[1]];
end
else if (P[1] = '[') and (P[2] in ['A'..'E']) then
begin
if Key.skeShiftState and 8 = 8 then
Key.skeKeyCode := KbdScanAltFn5[P[2]]
else if Key.skeShiftState and 4 = 4 then
Key.skeKeyCode := KbdScanCtlFn5[P[2]]
else if Key.skeShiftState and 2 = 2 then
Key.skeKeyCode := KbdScanSftFn5[P[2]]
else
Key.skeKeyCode := KbdScanNrmFn5[P[2]];
end;
end;
end;
begin
while True do
begin
TrmRead(Buffer, 1);
Buffer[1] := #0;
// ALT simulation via ESC
if Buffer[0] = #27 then
begin
L := 1 + TrmRead(Buffer[1], 14);
Buffer[L] := #0;
end;
Key.skeKeyCode := 0;
Key.skeShiftState := SysTVGetShiftState;;
// Decode key
if (Buffer[0] = #27) and (Buffer[1] <> #0) then
begin
if Buffer[2] = #0 then
DecodeEscChr(Buffer[1])
else
DecodeEscSeq(@Buffer[1]);
end
else
begin
Key.skeKeyCode := Ord(Buffer[0]);
if (Key.skeKeyCode >= 1) and (Key.skeKeyCode <= 27) then
begin
case Key.skeKeyCode of
$09: Key.skeKeyCode := $0F09; // TAB
$0A: Key.skeKeyCode := $1C0D; // CR (instead of LF)
$1B: Key.skeKeyCode := $011B; // ESC
else
Key.skeShiftState := Key.skeShiftState or 4 // Ctrl
end;
end;
end;
if Key.skeKeyCode <> 0 then
begin
LnxWrite(KbdBuffer.WrFile, Key, SizeOf(Key));
SysSysWaitSem(KbdBufferMutex);
Inc(KbdBufferCount);
KbdBufferMutex := 0;
end;
end;
end;
function SysKeyPressed: Boolean;
var
C: Char;
begin
Result := SysPeekKey(C);
end;
function SysPeekKey(Var Ch: Char): Boolean;
begin
if KbdNextKey.skeKeyCode = 0 then
begin
if KbdBufferCount <> 0 then
begin
LnxRead(KbdBuffer.RdFile, KbdNextKey, SizeOf(KbdNextKey));
Ch := Chr(Lo(KbdNextKey.skeKeyCode));
SysSysWaitSem(KbdBufferMutex);
Dec(KbdBufferCount);
KbdBufferMutex := 0;
Result := True;
end
else
Result := False;
end
else
begin
Ch := Chr(Lo(KbdNextKey.skeKeyCode));
Result := True;
end;
end;
function SysReadKey: Char;
begin
if KbdNextKey.skeKeyCode = 0 then
begin
LnxRead(KbdBuffer.RdFile, KbdNextKey, SizeOf(KbdNextKey));
Result := Chr(Lo(KbdNextKey.skeKeyCode));
SysSysWaitSem(KbdBufferMutex);
Dec(KbdBufferCount);
KbdBufferMutex := 0;
end
else
Result := Chr(Lo(KbdNextKey.skeKeyCode));
if Result = #0 then
KbdNextKey.skeKeyCode := KbdNextKey.skeKeyCode shr 8
else
KbdNextKey.skeKeyCode := 0;
end;
procedure SysFlushKeyBuf;
var
I: Integer;
begin
SysSysWaitSem(KbdBufferMutex);
for I := 0 to KbdBufferCount - 1 do
LnxRead(KbdBuffer.RdFile, KbdNextKey, SizeOf(KbdNextKey));
KbdNextKey.skeKeyCode := 0;
KbdBufferMutex := 0;
end;
procedure SysWrtCharStrAtt(CharStr: Pointer; Len, X, Y: SmallWord; var Attr: Byte);
var
Src: PChar;
Dst, I: LongInt;
begin
Src := CharStr;
Dst := Y * ScrWidth + X;
for I := 0 to Len - 1 do
begin
ScrBuffer^[Dst + I].Chr := Src[I];
ScrBuffer^[Dst + I].Att := Attr;
end;
SysTVShowBuf(Dst * 2, Len * 2);
end;
function SysReadAttributesAt(x,y: SmallWord): Byte;
begin
Result := ScrBuffer^[Y * ScrWidth + X].Att;
end;
function SysReadCharAt(x,y: SmallWord): Char;
begin
Result := ScrBuffer^[Y * ScrWidth + X].Chr;
end;
procedure SysScrollUp(X1,Y1,X2,Y2,Lines,Cell: SmallWord);
var
I, J, Src, Dst, Len: Integer;
FullScreen: Boolean;
Ctrl: string;
begin
if Lines > Y2 - Y1 + 1 then Lines := Y2 - Y1 + 1;
// FullScreen := (Lines = 1) and (X1 = 0) and (Y1 = 0) and (X2 = ScrWidth - 1) and (Y2 = ScrHeight - 1);
Src := ScrWidth * (Y1 + Lines) + X1;
Dst := ScrWidth * Y1 + X1;
Len := X2 - X1 + 1;
for I := Y1 to Y2 - Lines do
begin
Move(ScrBuffer^[Src], ScrBuffer^[Dst], Len * 2);
SysTVShowBuf(Dst * 2, Len * 2);
Inc(Src, ScrWidth);
Inc(Dst, ScrWidth);
end;
for I := 1 to Lines do
begin
for J := 0 to Len - 1 do
begin
ScrBuffer^[Dst + J].Chr := Chr(Cell and $FF);
ScrBuffer^[Dst + J].Att := Cell shr $08;
end;
SysTVShowBuf(Dst * 2, Len * 2);
Inc(Src, ScrWidth);
Inc(Dst, ScrWidth);
end;
// if FullScreen then
begin
Ctrl := #27'D';
TrmWrite(Ctrl[1], Length(Ctrl));
SysTVShowBuf(ScrWidth * (ScrHeight - 1) * 2, Len * 2);
end;
end;
procedure SysScrollDn(X1,Y1,X2,Y2,Lines,Cell: SmallWord);
var
I, J, Src, Dst, Len: Integer;
begin
if Lines > Y2 - Y1 + 1 then Lines := Y2 - Y1 + 1;
Src := ScrWidth * (Y2 - Lines) + X1;
Dst := ScrWidth * Y2 + X1;
Len := X2 - X1 + 1;
for I := Y1 to Y2 - Lines do
begin
Move(ScrBuffer^[Src], ScrBuffer^[Dst], Len * 2);
SysTVShowBuf(Dst * 2, Len * 2);
Dec(Src, ScrWidth);
Dec(Dst, ScrWidth);
end;
for I := 1 to Lines do
begin
for J := 0 to Len - 1 do
begin
ScrBuffer^[Dst + J].Chr := Chr(Cell and $FF);
ScrBuffer^[Dst + J].Att := Cell shr $08;
end;
SysTVShowBuf(Dst * 2, Len * 2);
Dec(Src, ScrWidth);
Dec(Dst, ScrWidth);
end;
end;
procedure SysGetCurPos(var X,Y: SmallWord);
begin
X := ScrColumn;
Y := ScrRow;
end;
function SysTVDetectMouse: Longint;
begin
Result := 0;
end;
procedure SysTVInitMouse(var X,Y: Integer);
begin
end;
procedure SysTVDoneMouse(Close: Boolean);
begin
end;
procedure SysTVShowMouse;
begin
end;
procedure SysTVHideMouse;
begin
end;
procedure SysTVUpdateMouseWhere(var X,Y: Integer);
begin
end;
function SysTVGetMouseEvent(var Event: TSysMouseEvent): Boolean;
begin
Result := False;
end;
procedure SysTVKbdInit;
begin
// Get a pipe for the keyboard buffer
LnxPipe(KbdBuffer);
// Start keyboard converter thread
SysCtrlCreateThread(nil, 1024, @KbdTerminalThread, nil, 0, KbdThreadID);
end;
function SysTVGetKeyEvent(var Event: TSysKeyEvent): Boolean;
begin
if KbdNextKey.skeKeyCode = 0 then
begin
SysSysWaitSem(KbdBufferMutex);
if KbdBufferCount <> 0 then
begin
LnxRead(KbdBuffer.RdFile, Event, SizeOf(KbdNextKey));
Dec(KbdBufferCount);
Result := True;
end
else
Result := False;
KbdBufferMutex := 0;
end
else
begin
Event := KbdNextKey;
KbdNextKey.skeKeyCode := 0;
Result := True;
end;
end;
function SysTVPeekKeyEvent(var Event: TSysKeyEvent): Boolean;
begin
if KbdNextKey.skeKeyCode = 0 then
begin
SysSysWaitSem(KbdBufferMutex);
if KbdBufferCount <> 0 then
begin
LnxRead(KbdBuffer.RdFile, KbdNextKey, SizeOf(KbdNextKey));
Event := KbdNextKey;
Dec(KbdBufferCount);
Result := True;
end
else
Result := False;
KbdBufferMutex := 0;
end
else
begin
Event := KbdNextKey;
Result := True;
end;
end;
function SysTVGetShiftState: Byte;
var
B: Byte;
begin
B := 6;
if LnxIoCtl(TrmHandle, TIOCLINUX, @B) < 0 then
B := 0;
Result := (B and 12) or (B and 1) shl 1;
end;
procedure SysTVSetCurPos(X,Y: Integer);
var
S: string;
begin
ScrColumn := X;
ScrRow := Y;
S := #27'[' + IntToStr(Y + 1) + ';' + IntToStr(X + 1) + 'H';
TrmWrite(S[1], Length(S));
end;
procedure SysTVSetCurType(Y1,Y2: Integer; Show: Boolean);
var
Ctrl: string;
begin
ScrCursor := Show;
if Show then
Ctrl := #27'[?25h' else Ctrl := #27'[?25l';
TrmWrite(Ctrl[1], Length(Ctrl));
end;
procedure SysTVGetCurType(var Y1,Y2: Integer; var Visible: Boolean);
begin
Y1 := 0;
Y2 := 0;
Visible := ScrCursor;
end;
procedure SysTVShowBuf(Pos,Size: Integer);
var
Attr, LastAttr: Byte;
Mode: Boolean;
Ctrl, Data: string;
J, X, Y: Integer;
begin
if Odd(Pos) then
begin
Dec(Pos);
Inc(Size);
end;
if Odd(Size) then
Inc(Size);
if ScrCursor then
Ctrl := #27'[?25l'#27'7'
else
Ctrl := #27'7';
TrmWrite(Ctrl[1], Length(Ctrl));
Y := Pos div (2 * ScrWidth);
X := (Pos mod (2 * ScrWidth)) div 2;
Ctrl := #27'[' + IntToStr(Y + 1) + ';' + IntToStr(X + 1) + 'H';
TrmWrite(Ctrl[1], Length(Ctrl));
LastAttr := 0;
Mode := False;
Data := '';
for J := 0 to Size div 2 - 1 do
begin
Attr := ScrBuffer^[Pos div 2 + J].Att;
if Attr <> LastAttr then
begin
TrmWrite(Data[1], Length(Data));
Data := '';
LastAttr := Attr;
Ctrl := #27'[0';
if (Attr and $80) <> 0 then Ctrl := Ctrl + ';5';
if (Attr and $08) <> 0 then Ctrl := Ctrl + ';1';
Attr := Attr and $77;
if ScrColors > 2 then
begin
Ctrl := Ctrl + ';3' + IntToStr(ScrPalette[Attr and $0F])
+ ';4' + IntToStr(ScrPalette[Attr shr $04]) + 'm';
end;
TrmWrite(Ctrl[1], Length(Ctrl));
end;
case ScrBuffer^[Pos div 2 + J].Chr of
#1..#6:
begin
if Mode then
begin
Data := Data + #27'(B';
Mode := False;
end;
Data := Data + ScrGraphs[ScrBuffer^[Pos div 2 + J].Chr];
end;
#7..#31:
begin
if not (Mode or (ScrMode = MON1) or (ScrMode = COL1)) then
begin
Data := Data + #27'(0';
Mode := True;
end;
Data := Data + ScrGraphs[ScrBuffer^[Pos div 2 + J].Chr];
end;
#0, #127..#159:
begin
Data := Data + ' ';
end;
else
if Mode then
begin
Data := Data + #27'(B';
Mode := False;
end;
Data := Data + ScrBuffer^[Pos div 2 + J].Chr;
end;
if Length(Data) > 127 then
begin
TrmWrite(Data[1], Length(Data));
Data := '';
end;
end;
if Mode then
Data := Data + #27'(B';
TrmWrite(Data[1], Length(Data));
if ScrCursor then
Ctrl := #27'[?25h'#27'8'
else
Ctrl := #27'8';
TrmWrite(Ctrl[1], Length(Ctrl));
end;
procedure SysTVClrScr;
var
I: LongInt;
begin
for I := 0 to ScrSize div 2 - 1 do
begin
ScrBuffer^[I].Chr := ' ';
ScrBuffer^[I].Att := 0;
end;
for I := 0 to ScrHeight - 1 do
SysTVShowBuf(I * 2 * ScrWidth, 2 * ScrWidth);
SysTVSetCurPos(0, 0);
end;
function SysTVGetScrMode(Size: PSysPoint): Integer;
begin
if Size <> nil then
begin
Size^.X := ScrWidth;
Size^.Y := ScrHeight;
end;
Result := ScrMode;
end;
procedure SysTVSetScrMode(Mode: Integer);
begin
// Set color mapping
case Mode of
MON1, MON2:
begin
ScrColors := 2;
ScrPalette[0] := 0; ScrPalette[1] := 0;
ScrPalette[2] := 0; ScrPalette[3] := 0;
ScrPalette[4] := 0; ScrPalette[5] := 0;
ScrPalette[6] := 0; ScrPalette[7] := 0;
end;
COL1, COL2:
begin
ScrColors := 8;
ScrPalette[0] := 0; ScrPalette[1] := 4;
ScrPalette[2] := 2; ScrPalette[3] := 6;
ScrPalette[4] := 1; ScrPalette[5] := 5;
ScrPalette[6] := 3; ScrPalette[7] := 7;
end;
else
Exit;
end;
// Set mapping of graphics characters
case Mode of
MON1, COL1: ScrGraphs := #032#094#086#060#062#043#045#079
+ #032#032#091#093#035#061#032#043
+ #043#043#043#045#124#043#043#043
+ #043#043#043#043#043#043#045#124;
MON2, COL2: ScrGraphs := #032#094#086#060#062#043#177#096
+ #032#048#048#048#048#104#097#108
+ #107#106#109#113#120#118#119#117
+ #116#110#108#107#106#109#113#120;
else
Exit;
end;
ScrMode := Mode;
end;
function SysTVGetSrcBuf: Pointer;
begin
Result := ScrBuffer;
end;
function StrToIntDef(const S: string; Default: Integer): Integer;
var
Error: LongInt;
begin
Val(S, Result, Error);
if Error <> 0 then
Result := Default;
end;
procedure SysTVInitCursor;
var
Term: string;
Size: TWinSize;
begin
// Initialize terminal
Term := TrmInit;
// Get window size, calculate usable screen, get buffer
if LnxIoCtl(TrmHandle, TIOCGWINSZ, @Size) = 0 then
begin
ScrWidth := Size.ws_Col;
ScrHeight := Size.ws_Row;
end;
ScrSize := ScrWidth * ScrHeight * 2;
if ScrSize > 16384 then
begin
ScrHeight := 16384 div (2 * ScrWidth);
ScrSize := ScrWidth * ScrHeight * 2;
end;
GetMem(ScrBuffer, ScrSize);
// Try to default to a reasonable video mode
if (Term = 'xterm') or (Term = 'linux') then
SysTVSetScrMode(COL2)
else if (Term = 'vt100') then
SysTVSetScrMode(MON2)
else
SysTVSetScrMode(MON1);
// Clear the screen
SysTVClrScr;
end;
procedure SysCtrlSleep(Delay: Integer);
var
Req, Rem: TTimeSpec;
Result: LongInt;
begin
Req.tv_Sec := Delay div 1000;
Req.tv_NSec := (Delay mod 1000) * 1000000;
repeat
Result := -LnxNanoSleep(Req, Rem);
Req := Rem;
until Result <> EAGAIN;
end;
function SysGetValidDrives: Longint;
begin
Result := 4; // 000..000100 -- drive C: only
end;
procedure SysDisableHardErrors;
begin
// nop
end;
function SysKillProcess(Process: Longint): Longint;
begin
Result := -LnxKill(Process, SIGKILL);
end;
function SysAllocSharedMem(Size: Longint; var MemPtr: Pointer): Longint;
begin
Unimplemented('SysAllocSharedMem');
end;
function SysGiveSharedMem(MemPtr: Pointer): Longint;
begin
Unimplemented('SysGiveSharedMem');
end;
function SysPipeCreate(var ReadHandle,WriteHandle: Longint; Size: Longint): Longint;
begin
Unimplemented('SysPipeCreate');
end;
function SysPipePeek(Pipe: Longint; Buffer: Pointer; BufSize: Longint; var BytesRead: Longint; var IsClosing: Boolean): Longint;
begin
Unimplemented('SysPipePeek');
end;
function SysPipeClose(Pipe: Longint): Longint;
begin
Unimplemented('SysPipeClose');
end;
function SysLoadResourceString(ID: Longint; Buffer: PChar; BufSize: Longint): PChar;
var
p: PChar;
Len: Longint;
begin
Buffer^ := #0;
p := PChar( LnxGetResourceStringAddress(ID) );
if assigned(p) then
begin
Len := pSmallWord(p)^;
if Len > BufSize then
Len := BufSize;
StrLCopy(Buffer, p+2, Len);
end;
Result := Buffer;
end;
function SysFileUNCExpand(Dest,Name: PChar): PChar;
begin
Unimplemented('SysFileUNCExpand');
end;
function SysGetSystemError(Code: Longint; Buffer: PChar; BufSize: Longint;var MsgLen: Longint): PChar;
begin
Result := SysLoadResourceString(57344 + Code, Buffer, BufSize);
MsgLen := StrLen(Buffer);
end;
procedure SysGetCurrencyFormat(CString: PChar; var CFormat, CNegFormat, CDecimals: Byte; var CThousandSep, CDecimalSep: Char);
begin
StrCopy(CString, '$');
CFormat := 0;
CNegFormat := 0;
CThousandSep := ',';
CDecimalSep := '.';
CDecimals := 2;
end;
procedure SysGetDateFormat(var DateSeparator: Char; ShortDateFormat,LongDateFormat: PChar);
begin
DateSeparator := '/';
StrCopy(ShortDateFormat, 'mm/dd/yy');
StrCopy(LongDateFormat, 'mmmm d, yyyy');
end;
procedure SysGetTimeFormat(var TimeSeparator: Char; TimeAMString,TimePMString,ShortTimeFormat,LongTimeFormat: PChar);
begin
TimeSeparator := ':';
StrCopy(TimeAmString, 'am');
StrCopy(TimePmString, 'pm');
StrCopy(ShortTimeFormat, 'hh:mm');
StrCopy(LongTimeFormat, 'hh:mm:ss');
end;
function SysGetModuleName(var Address: Pointer; Buffer: PChar; BufSize: Longint): PChar;
var
ModuleName, Temp: PChar;
begin
StrCopy(Buffer, 'UNKNOWN');
Result := Buffer;
//
ModuleName := Argv^[0];
Temp := StrRScan(ModuleName, '/');
if Temp = nil then Temp := ModuleName else Temp := Temp + 1;
StrLCopy(Buffer, Temp, BufSize - 1);
Result := Buffer;
end;
procedure SysDisplayConsoleError(PopupErrors: Boolean; Title, Msg: PChar);
var
Count: Longint;
begin
SysFileWrite(SysFileStdErr, Msg^, StrLen(Msg), Count);
end;
procedure SysDisplayGUIError(Title, Msg: PChar);
begin
Unimplemented('SysDisplayGUIError');
end;
procedure SysBeep;
begin
Unimplemented('SysBeep');
end;
procedure SysBeepEx(Freq,Dur: Longint);
begin
Unimplemented('SysBeepEx');
end;
function SysGetVolumeLabel(Drive: Char): ShortString;
begin
Result := '';
end;
function SysSetVolumeLabel(Drive: Char; _Label: ShortString): Boolean;
begin
Result := False;
end;
function SysGetForegroundProcessId: Longint;
begin
Unimplemented('SysGetForegroundProcessId');
end;
function SysGetBootDrive: Char;
begin
if FileSystem = fsDosUpper then Result := 'C' else Result := 'c';
end;
function SysGetDriveType(Drive: Char): TDriveType;
var
StatFS: TStatFS;
begin
if (Drive <> 'C') and (Drive <> 'c') then
begin
Result := dtInvalid;
Exit;
end;
LnxStatFS('/', StatFS);
with StatFS do
begin
if f_fsid[0] = $00004D44 then
Result := dtHDFAT
else if f_fsid[0] = $F995E849 then
Result := dtHDHPFS
else if (f_fsid[0] = $0000EF51) or (f_fsid[0] = $0000EF53) then
Result := dtHDEXT2
else
Result := dtInvalid;
end;
end;
function SysGetVideoModeInfo( Var Cols, Rows, Colours : Word ): Boolean;
begin
Cols := ScrWidth;
Rows := ScrHeight;
if (ScrMode = COL1) or (ScrMode = COL2) then
Colours := 8
else
Colours := 2;
Result := True;
end;
function SysGetVisibleLines( var Top, Bottom: Longint ): Boolean;
var
Cols, Rows, Colours: Word;
begin
if SysGetVideoModeInfo( Cols, Rows, Colours ) then
begin
Result := True;
Top := 1;
Bottom := Rows;
end
else
Result := False;
end;
function SysSetVideoMode( Cols, Rows: Word ): Boolean;
begin
Unimplemented('SysSetVideoMode');
end;
//▒▒▒▒▒▒▒▒▒▒▒▒▒▒[ SEMPAHORE FUNCTIONS ]▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
function SemCreateEvent(_Name: pChar; _Shared, _State: Boolean): TSemHandle;
begin
Unimplemented('SemCreateEvent');
end;
function SemAccessEvent(_Name: PChar): TSemHandle;
begin
Unimplemented('SemAccessEvent');
end;
function SemPostEvent(_Handle: TSemhandle): Boolean;
begin
Unimplemented('SemPostEvent');
end;
function SemWaitEvent(_Handle: TSemHandle; _TimeOut: Longint): Boolean;
begin
Unimplemented('SemWaitEvent');
end;
function SemCreateMutex(_Name: PChar; _Shared, _State: Boolean): TSemHandle;
begin
Unimplemented('SemCreateMutex');
end;
function SemRequestMutex(_Handle: TSemHandle; _TimeOut: Longint): Boolean;
begin
Unimplemented('SemRequestMutex');
end;
function SemAccessMutex(_Name: PChar): TSemHandle;
begin
Unimplemented('SemAccessMutex');
end;
function SemReleaseMutex(_Handle: TSemHandle): Boolean;
begin
Unimplemented('SemReleaseMutex');
end;
procedure SemCloseEvent(_Handle: TSemHandle);
begin
Unimplemented('SemCloseEvent');
end;
procedure SemCloseMutex(_Handle: TSemHandle);
begin
Unimplemented('SemCloseMutex');
end;
function SysMemInfo(_Base: Pointer; _Size: Longint; var _Flags: Longint): Boolean;
begin
// Doesn't seem to be supported. Could be emulated by storing the
// access flags in the list of allocated mmap memory blocks and
// getting the flags from this list.
_Flags := sysmem_read or sysmem_execute;
Result := False;
end;
function SysSetMemProtection(_Base: Pointer; _Size: Longint; _Flags: Longint): Boolean;
begin
Result := (LnxMProtect(_Base, _Size, _Flags) = 0);
end;
procedure SysMessageBox(_Msg, _Title: PChar; _Error: Boolean);
begin
Unimplemented('SysMessageBox');
end;
function SysClipCanPaste: Boolean;
begin
Result := False;
end;
function SysClipCopy(P: PChar; Size: Longint): Boolean;
begin
Result := False;
end;
function SysClipPaste(var Size: Integer): Pointer;
begin
Result := nil;
end;
// Retrieve various system settings, bitmapped:
// 0: Enhanced keyboard installed
function SysGetSystemSettings: Longint;
begin
Result := 1;
end;
type
PFpReg = ^TFpReg;
TFpReg = record
losig: LongInt;
hisig: LongInt;
signexp: SmallWord;
end;
PContextRecord = ^TContextRecord;
TContextRecord = record
ContextFlags: LongInt;
ctx_env: array [0..6] of LongInt;
ctx_stack: array [0..7] of TFpReg;
ctx_SegGs: LongInt;
ctx_SegFs: LongInt;
ctx_SegEs: LongInt;
ctx_SegDs: LongInt;
ctx_RegEdi: LongInt;
ctx_RegEsi: LongInt;
ctx_RegEax: LongInt;
ctx_RegEbx: LongInt;
ctx_RegEcx: LongInt;
ctx_RegEdx: LongInt;
ctx_RegEbp: LongInt;
ctx_RegEip: LongInt;
ctx_SegCs: LongInt;
ctx_EFlags: LongInt;
ctx_RegEsp: LongInt;
ctx_SegSs: LongInt;
end;
PExcFrame = ^TExcFrame;
TExcFrame = record
Next: PExcFrame;
Desc: Pointer;
end;
PSignalInfoBlock = ^TSignalInfoBlock;
TSignalInfoBlock = record
Number: LongInt;
Report: TXcptReportRecord;
Context: TContextRecord;
Next: PSignalInfoBlock;
end;
procedure GetContextRecord(Context: PContextRecord); {&frame-} {&uses none}
asm
push eax
push edi
mov edi, [esp + 12]
mov [edi].TContextRecord.ContextFlags, 7
mov [edi].TContextRecord.ctx_RegEax, eax
mov [edi].TContextRecord.ctx_RegEbx, ebx
mov [edi].TContextRecord.ctx_RegEcx, ecx
mov [edi].TContextRecord.ctx_RegEdx, edx
mov [edi].TContextRecord.ctx_RegEsi, esi
mov eax, [esp + 4]
mov [edi].TContextRecord.ctx_RegEdi, eax
mov [edi].TContextRecord.ctx_RegEbp, ebp
mov eax, [esp + 16]
mov [edi].TContextRecord.ctx_RegEsp, eax
mov eax, [esp + 8]
mov [edi].TContextRecord.ctx_RegEip, eax
pushfd
pop eax
mov [edi].TContextRecord.ctx_EFlags, eax
pop edi
pop eax
end;
function SysRaiseException(Xcpt: PXcptReportRecord): LongInt; stdcall; orgname; {&uses ecx,edx} {&frame-}
asm
mov ecx, fs:[0] // First exception frame
mov edx, Xcpt // Xcpt
@@LOOP:
pushad
sub esp, 8 // Two unused parameters
push ecx // Registration
push edx // Report
call [ecx].TExcFrame.Desc // Call handler
add esp, 16 // Cleanup stack
or eax, eax // XCPT_CONTINUE_SEARCH ?
popad
jnz @@RET
mov ecx, [ecx].TExcFrame.Next // Get previous frame
jmp @@LOOP
@@RET:
xor eax, eax
end;
function SysUnwindException(Handler: PExcFrame; TargetIP: Pointer; Xcpt: PXcptReportRecord): LongInt; stdcall; orgname; {&uses ecx,edx} {&Frame-}
asm
mov eax, TargetIP // Get TargetIP
mov [esp+@locals+@uses], eax; // And store it as return address
mov ecx, fs:[0] // First exception frame
mov eax, Handler // Handler
mov edx, Xcpt // Xcpt
// or [edx].TXcptReportRecord.fHandlerFlags, $02
@@LOOP:
cmp ecx, eax // Target handler reached ?
je @@RET // If so, return
pushad
sub esp, 8 // Two unused parameters
push ecx // Registration
push edx // Report
call [ecx].TExcFrame.Desc // Call handler
add esp, 16 // Cleanup stack
popad
mov ecx, [ecx].TExcFrame.Next // Get previous frame
mov fs:[0], ecx // Remove current frame
jmp @@LOOP
@@RET:
xor eax, eax
end;
var
P: PSignalInfoBlock;
procedure RaiseSignalException;
begin
SysRaiseException(@P.Report);
end;
// Except signal handler
procedure HandleExceptSignal(SigNum: LongInt; _Context: LongInt); cdecl;
var
SigContext: TSigContext absolute _Context;
Signal: TSignalInfoBlock;
begin
FillChar(Signal, SizeOf(Signal), 0);
with Signal do
begin
Number := SigNum;
with Report do
begin
{ Linux exception code are $C00xyyzz, with...
x: Signal number, see SIG* constants in Linux.pas for details
yy: i386 Trap code (for signals which are caused by a trap)
zz: Lower 7 bit of coprocessor status (for signals which are
caused by a floating point fault) }
ExceptionNum := $C0000000 or (SigNum shl 16);
if SigNum in [SIGBUS, SIGFPE, SIGHUP, SIGSEGV, SIGTERM, SIGTRAP] then
ExceptionNum := ExceptionNum or (SigContext.TrapNo shl 8);
case ExceptionNum of
xcpt_Float_Generic:
ExceptionNum := ExceptionNum or (SigContext.FpState.Status and $7F);
xcpt_In_Page_Error, xcpt_Access_Violation:
begin
cParameters := 2;
ExceptionInfo[0] := SigContext.err and $02;
ExceptionInfo[1] := SigContext.cr2;
end;
end;
ExceptionNum := ExceptionNum and $F0FFFFFF;
ExceptionAddress := Pointer(SigContext.Eip);
end;
with Context, SigContext do
begin
ctx_SegSs := Ss;
ctx_SegGs := Gs;
ctx_SegFs := Fs;
ctx_SegEs := Es;
ctx_SegDs := Ds;
ctx_SegCs := Cs;
ctx_RegEdi := Edi;
ctx_RegEsi := Esi;
ctx_RegEdx := Edx;
ctx_RegEcx := Ecx;
ctx_RegEbx := Ebx;
ctx_RegEax := Eax;
ctx_RegEbp := Ebp;
ctx_RegEsp := Esp;
ctx_RegEip := Eip;
ctx_EFlags := EFlags;
end;
end;
// Xcpt.Next := GetThreadInfoBlock.ExceptReports;
// GetThreadInfoBlock.ExceptReports := Xcpt;
// SigContext.eip := LongInt(@RaiseSignalException);
SysRaiseException(@Signal.Report);
end;
procedure SetSignalHandlers;
const
OtherSignals: array[1..21] of LongInt =
(SIGABRT, SIGALRM, SIGBUS, SIGFPE, SIGHUP, SIGILL, SIGINT,
SIGIO, SIGIOT, SIGKILL, SIGPIPE, SIGPOLL, SIGPWR, SIGQUIT,
SIGSEGV, SIGTERM, SIGTRAP, SIGUSR2, SIGVTALRM, SIGXCPU, SIGXFSZ);
var
Act, Old: TSigAction;
I: LongInt;
begin
FillChar(Act, SizeOf(Act), 0);
// Set handler for SIGUSR1 - needed for
// supending and restarting threads
Act.sa_Handler := @HandleStateSignal;
LnxSigAction(SIGUSR1, Act, Old);
// Set handler for SIGCHLD - needed for
// notifying the main thread when a
// child thread terminates.
Act.sa_Handler := @HandleChildSignal;
LnxSigAction(SIGCHLD, Act, Old);
// Set other handlers - needed for
// mapping of signals to exceptions.
for I := Low(OtherSignals) to High(OtherSignals) do
begin
Act.sa_Handler := @HandleExceptSignal;
Act.sa_Flags := SA_NODEFER;
LnxSigAction(OtherSignals[I], Act, Old);
end;
end;
procedure SysLowInit; {&USES All} {&FRAME-}
asm
// Adjust stack bottom
sub MainThread.Stack, eax
// Get process ID
call LnxGetPid
mov MainThread.ThreadPid, eax
mov MainThread.ProcessPid, eax
// Create FS selector for main thread
push 1 // LDT entry #1
push OFFSET MainThread
push TYPE MainThread
call GetNewSelector
mov fs, ax
mov MainThread.TibSelector, fs
// Clear exception handler chain
xor eax, eax
mov MainThread.ExceptChain, eax
// Initialize thread info table
mov edi, OFFSET Threads
mov DWORD [edi], OFFSET MainThread
add edi, 4
mov ecx, TYPE Threads / 4 - 4
repnz stosw
// Get argument values
mov ebx, esp
add ebx, @uses+32
mov Argv, ebx
// Get argument count
mov ebx, [esp+28+@uses]
mov Argc, ebx
// Get environment strings
shl ebx, 2
add ebx, esp
add ebx, 36+@uses;
mov Env, ebx;
mov Environment, ebx;
// Set needed signal handlers
call SetSignalHandlers;
end;
