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

* Fix bug ID #0035596: better detection of vcs device

Browse Source 
git-svn-id: trunk@42766 -
This commit is contained in:
michael 2019-08-23 06:45:11 +00:00
parent 707e05d131
commit ee6c426e05
1 changed files with 38 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

90
rtl/linux/linuxvcs.pp
View File

@ -82,73 +82,59 @@ end;
procedure detect_linuxvcs;
var f:text;
f_open : boolean;
c,pc:char;
pid,cpid,dummy:longint;
device:dword;
fields:array [0..60] of int64;
fieldct,i:integer;
pid,ppid:longint;
magnitude:int64;
s:string[15];
statln:ansistring;
begin
{Extremely aggressive VCSA detection. Works even through Midnight
Commander. Idea from the C++ Turbo Vision project, credits go
to Martynas Kunigelis <algikun@santaka.sc-uni.ktu.lt>.}
pid:=fpgetpid;
f_open:=false;
{$push}
{$I-}
{$R-}
repeat
cpid:=pid;
str(pid,s);
assign(f,'/proc/'+s+'/stat');
assign(f, '/proc/'+s+'/stat');
{$I-}
reset(f);
{$I+}
if ioresult<>0 then
exit;
f_open:=true;
{ from here we can discard I/O errors, as long as we avoid
infinite loops }
{ first number is pid }
dummy:=0;
read(f,dummy);
if dummy<>pid then
exit;
{ after comes the name of the binary within (), look for closing brace followed by space }
c:=#0;
repeat
pc:=c;
read(f,c);
if ioresult<>0 then
break;
until (pc=')') and (c=' ');
{ now comes the state letter }
repeat
read(f,c);
if ioresult<>0 then
break;
until c=' ';
{ parent pid }
pid:=-1;
read(f,pid);
{ process group }
read(f,dummy);
{ session }
read(f,dummy);
{ device number }
device:=0;
read(f,device);
break;
readln(f, statln);
close(f);
f_open:=false;
if (device and $ffffffc0)=$00000400 then {/dev/tty*}
magnitude := 1;
fieldct := 0;
fields[fieldct] := 0;
for i := high(statln) downto low(statln) do
begin
vcs_device:=device and $3f;
case statln[i] of
'-': magnitude := -1;
'0'..'9': begin
fields[fieldct] := fields[fieldct]
+ (magnitude * (ord(statln[i]) - ord('0')));
magnitude := magnitude * 10;
end;
' ': begin
magnitude := 1;
fieldct := fieldct + 1;
fields[fieldct] := 0;
end;
else
break;
end;
end;
ppid := pid;
pid := fields[fieldct - 1];
if (fields[fieldct - 4] and $ffffffc0) = $00000400 then {/dev/tty*}
begin
vcs_device:=fields[fieldct - 4] and $3f;
break;
end;
until (device=0) {Not attached to a terminal, i.e. an xterm.}
or (pid=-1)
or (cpid=pid);
if f_open then
close(f);
{$pop}
until (fields[fieldct - 4]=0) {Not attached to a terminal, i.e. an xterm.}
or (pid=-1)
or (ppid=pid);
end;
begin