← Back to branch summary

~ubuntu-branches/ubuntu/feisty/fpc/feisty

« back to all changes in this revision

Viewing changes to rtl/linux/linuxvcs.pp

  • Committer: Bazaar Package Importer
  • Author(s): Torsten Werner
  • Date: 2007-01-27 20:08:50 UTC
  • mfrom: (1.2.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20070127200850-9mrptaqqjsx9nwa7
Tags: 2.0.4-5
* Fixed Build-Depends.
* Add myself to Uploaders in debian/control.
* Make sure that the sources are really patched before building them.
* Build unit 'libc' on powerpc too.

Show diffs side-by-side

added added

removed removed

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