View Issue Details

IDProjectCategoryView StatusLast Update
0035596FPCRTLpublic2019-05-17 22:10
ReporterKevin LydaAssigned To 
PrioritynormalSeverityminorReproducibilitysometimes
Status newResolutionopen 
PlatformOSlinux / unixOS Version
Product Version3.0.4Product Build 
Target VersionFixed in Version 
Summary0035596: A better version of the linuxvcs unit
DescriptionThe linux vcsh unit needs to be a bit more robust in how it processes /proc/PID/stat files. The issue is that the second field is "(argv[0])" and argv[0] can be anything. It can have spaces in it, it can have ") " in it, whatever.

The third field is an uppercase letter. All remaining fields are numbers.

The enclosed code will parse backwards, storing the numbers until it reaches a letter. At that point it starts to pull out the data.

The best part is that the code is slightly shorter than the code that currently exists and is broken.
Steps To ReproduceRun any pascal program that uses the keyboard unit inside of tmux. It will immediately crash.
TagsNo tags attached.
Fixed in Revision
FPCOldBugId
FPCTarget
Attached Files
  • linuxvcs.diff (2,929 bytes)
    diff --git a/rtl/linux/linuxvcs.pp b/rtl/linux/linuxvcs.pp
    index c9e3d1ff50..a5c58fce1e 100644
    --- a/rtl/linux/linuxvcs.pp
    +++ b/rtl/linux/linuxvcs.pp
    @@ -82,73 +82,58 @@ 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;
    +          otherwise 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
    
    linuxvcs.diff (2,929 bytes)

Activities

Kevin Lyda

2019-05-17 21:01

reporter  

linuxvcs.diff (2,929 bytes)
diff --git a/rtl/linux/linuxvcs.pp b/rtl/linux/linuxvcs.pp
index c9e3d1ff50..a5c58fce1e 100644
--- a/rtl/linux/linuxvcs.pp
+++ b/rtl/linux/linuxvcs.pp
@@ -82,73 +82,58 @@ 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;
+          otherwise 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
linuxvcs.diff (2,929 bytes)

Kevin Lyda

2019-05-17 22:10

reporter   ~0116238

It's also available here: https://gitlab.com/lyda/freepascal/tree/linuxvcs

Issue History

Date Modified Username Field Change
2019-05-17 21:01 Kevin Lyda New Issue
2019-05-17 21:01 Kevin Lyda File Added: linuxvcs.diff
2019-05-17 22:10 Kevin Lyda Note Added: 0116238