View Issue Details

IDProjectCategoryView StatusLast Update
0035596FPCRTLpublic2019-08-23 08:45
ReporterKevin LydaAssigned ToMichael Van Canneyt 
PrioritynormalSeverityminorReproducibilitysometimes
Status resolvedResolutionfixed 
PlatformOSlinux / unixOS Version
Product Version3.0.4Product Build 
Target VersionFixed in Version3.3.1 
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 Revision42766.
FPCOldBugId
FPCTarget3.2.0
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

michal wallace

2019-08-20 23:06

reporter   ~0117753

Kevin's patch worked for me. I would argue this is not a minor issue... It's actually a severe problem for anyone who uses tmux and wants to read from the keyboard in pascal.
Apparently, there are at least two of us... (Note that this completely breaks the fp IDE, too...)

Michael Van Canneyt

2019-08-23 08:45

administrator   ~0117789

Checked & applied, many thanks for the patch !

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
2019-08-20 23:06 michal wallace Note Added: 0117753
2019-08-21 21:38 Michael Van Canneyt Assigned To => Michael Van Canneyt
2019-08-21 21:38 Michael Van Canneyt Status new => assigned
2019-08-23 08:45 Michael Van Canneyt Status assigned => resolved
2019-08-23 08:45 Michael Van Canneyt Resolution open => fixed
2019-08-23 08:45 Michael Van Canneyt Fixed in Version => 3.3.1
2019-08-23 08:45 Michael Van Canneyt Fixed in Revision => 42766.
2019-08-23 08:45 Michael Van Canneyt FPCTarget => 3.2.0
2019-08-23 08:45 Michael Van Canneyt Note Added: 0117789