С этой функцией у меня возникли проблемы , GUI приложения отказываются нормально работать (испытывал на mplayer ) возникают сбои ( mplayer выводит видео через fbdev). В тоже время консольные программы работают нормально
Код "пускателя"
- Код: Выделить всё
program applaunch;
{$mode objfpc}{$H+}
uses
{$IFDEF Linux}
cthreads,
{$ENDIF}
Classes,sysutils, uapplaunch;
var
path:string;
data:portb_env;
id:integer;
begin
path:=GetCurrentDirEx+PathDelim+'settings.ini';
writeln('path='+path);
if fileexists(path) then
begin
data:=ReadAppData(Path);
data.curpath:=GetCurrentDirEx;
writeln('data.curpath+PathDelim+data.namebin='+data.curpath+PathDelim+data.namebin);
writeln('data.curpath+PathDelim+data.libdir='+data.curpath+PathDelim+data.libdir);
writeln('data.curpath+PathDelim+data.homedir='+data.curpath+PathDelim+data.homedir);
id:=RunApp(
data.curpath+PathDelim+data.namebin,
data.curpath+PathDelim+data.libdir,
data.curpath+PathDelim+data.homedir,
data.locale)
end
else
begin
writeln('Settings file not found')
end;
while CheckRunApp(id)=true do
begin
Sleep(100);
end;
CloseAppDesc(id);
writeln('applaunch terminated');
end.
- Код: Выделить всё
unit uapplaunch;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,IniFiles,libc;
type
portb_env=record
homedir:string;
curpath:string;
libdir:string;
locale:string;
namebin:string;
end;
function CheckRunApp(id_process:integer): Boolean;
function CloseAppDesc(id_process:integer): Boolean;
function RunApp(PathToBin,PathToLib,HomeDir,LocaleStr:string):integer;
function ReadAppData(PathToDesctopFile: string):portb_env;
function OverWriteEnv(PathToLib,HomeDir,LocaleStr:string):PPchar;
function GetParams():PPChar;
function GetCurrentDirEx():string;
implementation
function CheckRunApp(id_process:integer): boolean;
begin
Result:=DirectoryExists('/proc/'+inttostr(id_process));
end;
function CloseAppDesc(id_process:integer): Boolean;
begin
Result:=True;
//0-running
//-1-not running
if waitpid(id_process, nil, WNOHANG) = -1 then
begin
Result := False;
end;
end;
function GetCurrentDirEx():string;
begin
Result:=ExtractFileDir(ParamStr(0));
end;
function RunApp(PathToBin, PathToLib, HomeDir, LocaleStr: string): integer;
var
ChildPid:integer;
begin
ChildPid:=libc.fork;
case ChildPid of
-1:
begin
writeln('error fork')
end;
0:
begin
execve(PChar(PathToBin),GetParams,OverWriteEnv(PathToLib,HomeDir,LocaleStr));
end;
end;
Result:=ChildPid;
end;
function ReadAppData(PathToDesctopFile: string):portb_env;
var
df:TIniFile;
begin
df:=TIniFile.Create(PathToDesctopFile);
Result.namebin:=df.ReadString('app','namebin','');
Result.libdir:=df.ReadString('app','libdir','');
Result.homedir:=df.ReadString('app','homedir','');
Result.locale:=df.ReadString('app','locale','');
Result.curpath:='';
df.Free;
end;
function OverWriteEnv(PathToLib, HomeDir, LocaleStr: string): PPchar;
var
i,ec:integer;
env_ar__: array of Pchar;
tmpstr:string;
begin
Result:=nil;
ec:=GetEnvironmentVariableCount;
SetLength(env_ar__,ec-1);
if ec=0 then begin exit end;
for i:=0 to ec-1 do
begin
tmpstr:=GetEnvironmentString(i);
if tmpstr='HOME' then begin tmpstr:=HomeDir end;
if tmpstr='LD_LIBRARY_PATH' then begin tmpstr:=PathToLib end;
if tmpstr='LANG' then begin tmpstr:=LocaleStr end;
env_ar__[i]:=Pchar(tmpstr);
end;
env_ar__[ec]:=nil;
GetMem(Result,ec*sizeOf(PChar));
Result:=@env_ar__[0];
end;
function GetParams(): PPChar;
var
ArgArray: array of PChar;
i: integer;
parc:integer;
begin
parc:=Paramcount;
writeln('Paramcount='+inttostr(Paramcount));
if parc > 0 then
begin
SetLength(argArray, parc + 2);
Getmem(Result,(parc+2)*SizeOf(Pchar));
argArray[0] := '';
for i := 1 to parc do
begin
argArray[i] :=Pchar(ParamStr(i));
end;
argArray[parc+1] := nil;
Result := @argArray[0];
end
else
begin
SetLength(argArray, 2);
argArray[0] := '';
argArray[1] := nil;
Getmem(Result,2*SizeOf(Pchar));
Result := @argArray[0];
end;
end;
end.
PS: Пишу аналог AppRun http://portablelinuxapps.org/
Добавлено спустя 14 часов 42 минуты 12 секунд:
Ошибка явно в функции OverWriteEnv. Неправильная работа с PPchar
Как правильно передать новые значения переменных окружения в execve?
Переделал так
- Код: Выделить всё
function OverWriteEnv(PathToLib, HomeDir, LocaleStr: string): PPchar;
var
i,ec:integer;
env_ar__: array of Pchar;
tmpstr:string;
OverWrite_LD_LIBRARY_PATH:Boolean;
begin
Result:=nil;
ec:=GetEnvironmentVariableCount;
SetLength(env_ar__,ec+1);
if ec=0 then begin exit end;
OverWrite_LD_LIBRARY_PATH:=False;
for i:=0 to ec-1 do
begin
tmpstr:=GetEnvironmentString(i);
if pos('HOME=',tmpstr)>0 then
begin
tmpstr:='HOME='+HomeDir;
end;
if pos('LD_LIBRARY_PATH=',tmpstr)>0 then
begin
OverWrite_LD_LIBRARY_PATH:=True;
tmpstr:='LD_LIBRARY_PATH='+PathToLib;
end;
if (pos('LANG=',tmpstr)>0) and (LocaleStr<>'') then
begin
tmpstr:='LANG='+LocaleStr;
end;
//writeln(tmpstr+' <> '+inttostr(i));
env_ar__[i]:=Pchar(tmpstr);
end;
if OverWrite_LD_LIBRARY_PATH=false then
begin
tmpstr:='LD_LIBRARY_PATH='+PathToLib;
env_ar__[ec]:=Pchar(tmpstr);
GetMem(Result,(ec+1)*sizeOf(PChar));
end else
begin
SetLength(env_ar__,ec);
//env_ar__[ec]:=#0; ???
GetMem(Result,ec*sizeOf(PChar));
end;
Result:=@env_ar__[0];
end;
Добавлено спустя 53 минуты 45 секунд:
Проблема была в том что нужно выделить память под каждый элемент
- Код: Выделить всё
function OverWriteEnv(PathToLib, HomeDir, LocaleStr: string): PPchar;
var
i,ec:integer;
env_ar__: array of Pchar;
tmpstr:string;
OverWrite_LD_LIBRARY_PATH:Boolean;
begin
Result:=nil;
ec:=GetEnvironmentVariableCount;
SetLength(env_ar__,ec+2);
if ec=0 then begin exit end;
OverWrite_LD_LIBRARY_PATH:=False;
for i:=0 to ec-1 do
begin
tmpstr:=GetEnvironmentString(i);
if pos('HOME=',tmpstr)>0 then
begin
tmpstr:='HOME='+HomeDir;
end;
if pos('LD_LIBRARY_PATH=',tmpstr)>0 then
begin
OverWrite_LD_LIBRARY_PATH:=True;
tmpstr:='LD_LIBRARY_PATH='+PathToLib;
end;
if (pos('LANG=',tmpstr)>0) and (LocaleStr<>'') then
begin
tmpstr:='LANG='+LocaleStr;
end;
getmem(env_ar__[i],length(tmpstr));
env_ar__[i]:=Pchar(tmpstr);
//writeln(string(env_ar__[i])+' <> '+inttostr(i));
end;
if OverWrite_LD_LIBRARY_PATH=false then
begin
tmpstr:='LD_LIBRARY_PATH='+PathToLib;
env_ar__[ec]:=Pchar(tmpstr);
env_ar__[ec+1]:=nil;
GetMem(Result,(ec+2)*sizeOf(PChar));
end else
begin
SetLength(env_ar__,ec+1);
env_ar__[ec]:=nil;
GetMem(Result,(ec+1)*sizeOf(PChar));
end;
Result:=@env_ar__[0];
end;
Но всё равно работает неправильно вот вывод env запущенного через applaunch
- Код: Выделить всё
ORBIT_SOCKETDIR=/tmp...
ORBIT_SOCKETDIR=/tmp...
USERNAME=...
USERNAME=...
USERNAME=...
XDG_SESSION_COOKIE=...
USERNAME=...
PWD=/home/...
GTK_MODULES=canberra-gtk-module
USERNAME=...
PWD=/home/...
DBUS_SESSION_BUS_ADDRESS=unix:abstract=/tmp/...
USERNAME=...
PWD=/home/...
PWD=/home/...
DBUS_SESSION_BUS_ADDRESS=unix:abstract=/tmp/...
DESKTOP_SESSION=gnome
PWD=/home/...
GNOME_KEYRING_PID=...
LANG=ru_RU.utf8
GNOME_KEYRING_PID=...
DISPLAY=:0.0
LD_LIBRARY_PATH=...
DISPLAY=:0.0
DISPLAY=:0.0
DISPLAY=:0.0
GNOME_DESKTOP_SESSION_ID=this-is-deprecated
GNOME_DESKTOP_SESSION_ID=this-is-deprecated
DISPLAY=:0.0
LD_LIBRARY_PATH=...
DBUS_SESSION_BUS_ADDRESS=unix:abstract=/tmp/....
DISPLAY=:0.0
LD_LIBRARY_PATH=/home/...
COLORTERM=gnome-terminal
LD_LIBRARY_PATH=/home/...
