1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
unit linuxvcs;
{*****************************************************************************}
interface
{*****************************************************************************}
const vcs_device:shortint=-1;
function try_grab_vcsa:boolean;
{*****************************************************************************}
implementation
{*****************************************************************************}
uses baseunix,strings;
function try_grab_vcsa_in_path(path:Pchar;len:cardinal):boolean;
const grab_vcsa='/grab_vcsa';
grab_vcsa_s:array[1..length(grab_vcsa)] of char=grab_vcsa;
var p:Pchar;
child:Tpid;
status:cint;
pstat:stat;
begin
getmem(p,len+length(grab_vcsa)+1);
move(path^,p^,len);
move(grab_vcsa_s,(p+len)^,length(grab_vcsa));
(p+len+length(grab_vcsa))^:=#0;
{Check if file exists.}
if fpstat(p,pstat)<>0 then
begin
try_grab_vcsa_in_path:=false;
exit;
end;
child:=fpfork;
if child=0 then
begin
fpexecve(p,nil,nil);
halt(255); {fpexec must have failed...}
end;
fpwaitpid(child,status,0);
try_grab_vcsa_in_path:=status=0; {Return true if success.}
freemem(p);
end;
function try_grab_vcsa:boolean;
{If we cannot open /dev/vcsa0-31 it usually because we do not have
permission. At login the owner of the tty you login is set to yourself.
This is not done for vcsa, which is kinda strange as vcsa is revoke from
you when you log out. We try to call a setuid root helper which chowns
the vcsa device so we can get access to the screen buffer...}
var path,p:Pchar;
begin
try_grab_vcsa:=false;
path:=fpgetenv('PATH');
if path=nil then
exit;
p:=strscan(path,':');
while p<>nil do
begin
if try_grab_vcsa_in_path(path,p-path) then
begin
try_grab_vcsa:=true;
exit;
end;
path:=p+1;
p:=strscan(path,':');
end;
if try_grab_vcsa_in_path(path,strlen(path)) then
exit;
end;
procedure detect_linuxvcs;
var f:text;
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;
repeat
str(pid,s);
assign(f, '/proc/'+s+'/stat');
{$I-}
reset(f);
{$I+}
if ioresult<>0 then
break;
readln(f, statln);
close(f);
magnitude := 1;
fieldct := 0;
fields[fieldct] := 0;
for i := high(statln) downto low(statln) do
begin
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 (fields[fieldct - 4]=0) {Not attached to a terminal, i.e. an xterm.}
or (pid=-1)
or (ppid=pid);
end;
begin
{Put in procedure because there are quite a bit of variables which are made
temporary this way.}
detect_linuxvcs;
end.
|
