с реализаций B4rr4cuda я более и меннее разабоался. И даже перерхватил вывод от top
осталось отфильтровать вывод на предмет спец симлов
только нашел новые "грабли", не могу корректо завершить приложение; испытывал на top
вот код слегка переделаного эмулятора терминала
- Код: Выделить всё
unit emlinuxterm;
{$ifdef FPC}{$mode objfpc}{$h+}{$endif}
interface
uses
libc,sysutils;
//type
var
Fpty:LongInt;
id_term:LongInt;
function _Fork_pty_(const rows, cols: integer; const cmd:UTF8string; const params:UTF8string=''): System.THandle;
function _Read_Pty_(var str:UTF8String; timeout:timeval):longint;
function SendBreak_pty(): boolean;
function SendSignal_pty(Sig: integer): boolean;
{$L libutil.a} // under Linux forkpty is situated in libutil.a library
function forkpty(__amaster:Plongint; __name:Pchar; __termp:Ptermios; __winp:Pwinsize):longint;cdecl;external clib name 'forkpty';
function setenv(__name:Pchar; __value:Pchar; __replace:longint):longint;cdecl;external clib name 'setenv';
function execl(__path:Pchar; __arg:Pchar):longint;cdecl;varargs;external clib name 'execl';
const
terminal_x=132;
terminal_y=43;
max_xy_terminal=terminal_x*terminal_y;
const
{c_cc characters}
CDISABLE = 255;
//key // xterm default bindings
CINTR = 003; // ^C
CQUIT = 034; // ^
CERASE = 177; // ^?
CKILL = 025; // ^U
CEOF = 004; // ^D
CSTART = 021; // ^Q
CSTOP = 023; // ^S
CSUSP = 032; // ^Z
CREPRINT = 022; // ^R
CWERASE = 027; // ^W
CLNEXT = 026; // ^V
CDISCARD = 017; // ^O
//disabled
CTIME = 0;
CMIN = 1;
CSWTC = CDISABLE;
CEOL = CDISABLE;
CEOL2 = CDISABLE;
implementation
//uses
//;
function _Fork_pty_(const rows, cols: integer; const cmd:UTF8string; const params:UTF8string=''): System.THandle;
var ws:TWinSize;
ChildPid:THandle;
begin
ws.ws_row:=rows;
ws.ws_col:=cols;
ws.ws_xpixel:=0;
ws.ws_ypixel:=0;
ChildPid:=forkpty(@Fpty,nil,nil,@ws);
if ChildPid<0 then
begin
Result:=-1;
Exit;
end;
if ChildPid=0 then
begin
//Child
setenv('TERM', 'linux', 1);
execl(pchar(cmd), pchar(params), nil);
//execvp (PChar(Args[0]), @Args[0]);
//если execl не сработал и новый процесс не подменил форкнутый, то ошибка
WriteLn(pchar('execl() failed. Command: '+ cmd),length('execl() failed. Command: '+ cmd));
//exit(127); // error exec'ing
end;
id_term:=ChildPid;
Result:=ChildPid;
end;
function _Read_Pty_(var str:UTF8String; timeout:timeval):longint;
var ifs:TFdSet;
BytesRead:longint;
buf:array [0..max_xy_terminal-1] of char;
begin
Result:=0;
if Fpty<0 then exit;
//check if pty has new info for us
FD_ZERO(ifs);
FD_SET(Fpty,ifs);
if Select(fpty+1,@ifs,nil,nil,timeout)<=0 then exit;
bytesread := __read(fpty, buf, max_xy_terminal);
result:=bytesread;
str:='';
if bytesread <= 0 then exit;
str:=copy(buf,0,BytesRead);
end;
function SendSignal_pty(Sig: integer): boolean;
var BytesWritten:int64;
begin
BytesWritten:=__write(Fpty,Sig,sizeof(sig));
Result := (BytesWritten>0);
end;
function SendBreak_pty(): boolean;
begin
result:=SendSignal_pty(CINTR);
end;
end.
Использую так
- Код: Выделить всё
unit main;
{$ifdef FPC}{$mode objfpc}{$h+}{$endif}
interface
uses
mseglob,mseguiglob,mseguiintf,mseapplication,msestat,msemenus,msegui,
msegraphics,msegraphutils,mseevent,mseclasses,mseforms,msesimplewidgets,
msewidgets,msedataedits,mseedit,msestrings,msetypes,msegraphedits,msetimer;
type
tmainfo = class(tmainform)
mini_term: tlabel;
tgroupbox1: tgroupbox;
b_run: tbutton;
tlabel1: tlabel;
tlabel2: tlabel;
e_command: tstringedit;
e_parametr: tstringedit;
timer1: ttimer;
b_kill: tbutton;
l_debug: tlabel;
tbutton1: tbutton;
procedure read_pty(const sender: TObject);
procedure run_sh(const sender: TObject);
procedure kill_sh(const sender: TObject);
procedure init_pr(const sender: TObject);
end;
var
mainfo: tmainfo;
implementation
uses
main_mfm,emlinuxterm,libc,sysutils;
//таймер
procedure tmainfo.read_pty(const sender: TObject);
var
str:utf8string;
t:timeval;
begin
t.tv_sec:=0;
t.tv_usec:=10;
if _Read_Pty_(str,t)>0 then mini_term.caption:=str;
end;
//запуск
procedure tmainfo.run_sh(const sender: TObject);
begin
id_term:=_Fork_pty_(terminal_x,terminal_y,e_command.value,e_parametr.value);
b_run.enabled:=false;
timer1.enabled:=true;
b_kill.enabled:=true;
l_debug.caption:='tId'+inttostr(id_term)+' ptyId'+inttostr(Fpty);
end;
//уничтожение процесса
procedure tmainfo.kill_sh(const sender: TObject);
begin
timer1.enabled:=false;
//SendBreak_pty();
//if Fpty>0 then __close(fpty);
if id_term>0 then kill(id_term,SIGKILL);
b_kill.enabled:=false;
b_run.enabled:=true;
mini_term.caption:='_';
end;
procedure tmainfo.init_pr(const sender: TObject);
begin
b_kill.enabled:=false;
end;
end.
Нажимаю килл (tmainfo.kill_sh) получаю зомби
Естественно после закрытия приложения PID освобождаеться.
Где "грабли"?
PS:
может нужно инициалтзировать теримнал функцией tcsetattr.
пробовал , програмаа "вылетает"
- Код: Выделить всё
procedure initterm;
var tio:termios;
begin
tcgetattr(Fpty,tio);
tio.c_iflag:=BRKINT or IGNPAR or ICRNL or IXON;
tio.c_oflag:=OPOST or ONLCR;
tio.c_cflag:=CS8 or CREAD;
tio.c_lflag:=ISIG or ICANON or IEXTEN or ECHO or ECHOE or ECHOK or ECHOKE or ECHOCTL;
tio.c_cc[VINTR]:=char(CINTR);
tio.c_cc[VQUIT]:=char(CQUIT);
tio.c_cc[VERASE]:=char(CERASE);
tio.c_cc[VKILL]:=char(CKILL);
tio.c_cc[VSTART]:=char(CSTART);
tio.c_cc[VSTOP]:=char(CSTOP);
tio.c_cc[VSUSP]:=char(CSUSP);
tio.c_cc[VREPRINT]:=char(CREPRINT);
tio.c_cc[VDISCARD]:=char(CDISCARD);
tio.c_cc[VWERASE]:=char(CWERASE);
tio.c_cc[VLNEXT]:=char(CLNEXT);
tio.c_cc[VEOF]:=char(CEOF);
tio.c_cc[VEOL]:=char(CEOL);
tio.c_cc[VEOL2]:=char(CEOL2);
tio.c_cc[VMIN]:=char(CMIN);
tio.c_cc[VTIME]:=char(CTIME);
tcsetattr(Fpty,TCSANOW,tio);
end;
******
ChildPid:=forkpty(@Fpty,nil,nil,@ws);
initterm;
if ChildPid<0 then
******
Добавлено спустя 3 часа 42 минуты 7 секунд:разабрался оказвыеться все просто
- Код: Выделить всё
if id_term>0 then kill(id_term,SIGKILL);
waitpid(id_term,status_,WNOHANG);
b_kill.enabled:=false;
и зомби исчезают
У вас нет необходимых прав для просмотра вложений в этом сообщении.
. Кажеться нехватает вызова openpty 
http://www.opennet.ru/man.shtml?topic=openpty&category=3&russian=0
)
