调用外部程序并重定向输入输出（Linux, Free Pascal）：
unit uRun;
{$mode objFPC}{$H+}
interface
uses
BaseUnix, Unix, Errors;
type
TStringArray = array of String;
// 功能：执行程序，并重定向 标准输入、标准输出、标准错误（会在 PATH 中搜索程序）
// 参数：
// Cmd ：要执行的程序及其参数列表。
// FIn ：要代替子进程 标准输入 的文件，小于 0 则创建管道，并通过 FIn 返回。
// FOut ：要代替子进程 标准输出 的文件，小于 0 则创建管道，并通过 FOut 返回。
// FErr ：要代替子进程 标准错误 的文件，小于 0 则创建管道，并通过 FErr 返回。
// 如果不想重定向，可以传入 StdInputHandle、StdOutputHandle、StdErrorHandle
// Wait ：是否等待子进程运行完毕。
// 如果 Wait = True ，则成功时返回子进程退出码，失败时返回 -1。
// 如果 Wait = False，则成功时返回子进程的 pid，失败时返回 -1。
// Env ：传递给子进程的新环境变量列表（不包含父进程原有的环境变量）。
// CopyEnv：是否则将父进程的环境变量合并到 Env 中
function Run(
Cmd : TStringArray;
var FIn : CInt;
var FOut : CInt;
var FErr : CInt;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
// 功能：执行程序，不重定向 标准输入、标准输出、标准错误
function Run(
Cmd : TStringArray;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
// 功能：执行程序，使用字符串读写 标准输入、标准输出、标准错误
// 参数：
// Cmd ：要执行的程序及其参数列表
// SIn ：要代替子进程 标准输入 的字符串，NoIn 为 True 则不重定向 标准输入。
// SOut ：要代替子进程 标准输出 的字符串，非空则不重定向 标准输出。
// SErr ：要代替子进程 标准错误 的字符串，非空则不重定向 标准错误。
// Wait ：是否等待子进程运行完毕。
// 如果 Wait = True ，则成功时返回子进程退出码，失败时返回 -1。
// 如果 Wait = False，则成功时返回子进程的 pid，失败时返回 -1。
// Env ：传递给子进程的新环境变量列表（不包含父进程原有的环境变量）。
// CopyEnv：是否则将父进程的环境变量合并到 Env 中
function Run(
Cmd : TStringArray;
SIn : String;
var SOut : String;
var SErr : String;
NoIn : Boolean = False;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
// 使用字符串重定向 标准输入
function RunIn(
Cmd : TStringArray;
SIn : String;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
// 使用字符串重定向 标准输出
function RunOut(
Cmd : TStringArray;
var SOut : String;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
// 使用字符串重定向 标准错误
function RunErr(
Cmd : TStringArray;
var SErr : String;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
// 使用字符串重定向 标准输入 和 标准输出
function RunInOut(
Cmd : TStringArray;
SIn : String;
var SOut : String;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
// 使用字符串重定向 标准输入 和 标准错误
function RunInErr(
Cmd : TStringArray;
SIn : String;
var SErr : String;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
// 使用字符串重定向 标准输出 和 标准错误
function RunOutErr(
Cmd : TStringArray;
var SOut : String;
var SErr : String;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
// 执行程序，将 标准输出 重定向到 /dev/null
function RunNoOut(
Cmd : TStringArray;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
// 执行程序，将 标准错误 重定向到 /dev/null
function RunNoErr(
Cmd : TStringArray;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
// 执行程序，将 标准输出 和 标准错误 重定向到 /dev/null
function RunNoOutErr(
Cmd : TStringArray;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
implementation
procedure ErrMsg(Msg: String; Err: Integer); forward;
procedure ErrHalt(Msg: String; Err: Integer; ExitCode: LongInt); forward;
function ReadFile(Fd: CInt; Quiet: Boolean = False): String; forward;
function WriteFile(Fd: CInt; Data: String; Quiet: Boolean = False): Boolean; forward;
function Run(
Cmd : TStringArray;
var FIn : CInt;
var FOut : CInt;
var FErr : CInt;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
var
SubIn : CInt; // 要代替子进程 标准输入 的文件（FIn 可能用于管道返回值）
SubOut : CInt; // 要代替子进程 标准输出 的文件（FOut 可能用于管道返回值）
SubErr : CInt; // 要代替子进程 标准错误 的文件（FErr 可能用于管道返回值）
PIn : Boolean; // 记录是否创建了相应的管道
POut : Boolean; // 记录是否创建了相应的管道
PErr : Boolean; // 记录是否创建了相应的管道
Pid : CInt; // 子进程 ID
Status : CInt; // 子进程退出状态码
Len : Integer; // 环境变量列表的元素个数
I : Integer; // 临时变量
S : String; // 临时变量
Err : CInt; // 用于存储 Errno 的值
begin
SubIn := -1;
SubOut := -1;
SubErr := -1;
PIn := False;
POut := False;
PErr := False;
Pid := -1; // 后面要根据 Pid 是否小于 0 来进行收尾工作
try
// 如果传入了 标准输入 的 文件描述符，则使用
if FIn >= 0 then
SubIn := FIn
else
// 否则创建管道，AssignPipe 的第 1 个参数是管道的出口，第 2 个参数是管道的入口
if AssignPipe(SubIn, FIn) = 0 then
PIn := True
else
Exit(-1);
if FOut >= 0 then
SubOut := FOut
else
if AssignPipe(FOut, SubOut) = 0 then
POut := True
else
Exit(-1);
if FErr >= 0 then
SubErr := FErr
else
if AssignPipe(FErr, SubErr) = 0 then
PErr := True
else
Exit(-1);
// 创建子进程，子进程会复制父进程所创建的管道
Pid := FpFork();
// 如果子进程创建失败，则返回 -1
if Pid < 0 then
Exit(-1);
// 子进程要执行的代码
if Pid = 0 then
begin
// 关闭父进程所需的管道端口，只保留子进程所需的管道端口
// 如果 FpClose 的参数无效，则只会返回错误代码，而不会抛出异常
if FIn <> SubIn then FpClose(FIn );
if FOut <> SubOut then FpClose(FOut);
if FErr <> SubErr then FpClose(FErr);
// 这里是 Linux 中关于 文件描述符 以及 dup 和 dup2 函数的说明：
// 文件描述符是一个整数值，每个文件描述符都关联一个打开的文件，
// 每个进程都有一个文件描述符表来存储这种关联关系。
// 可以使用 dup 和 dup2 来复制文件描述符。
// int dup(int oldfd);
// int dup2(int oldfd, int newfd);
// dup 会创建一个新的描述符，这个新描述符指向 oldfd 所关联的文件。
// dup2 会将 newfd 指向 oldfd 所关联的文件，如果 newfd 已经打开，则会先将其关闭。
// 如果 newfd 等于 oldfd，则 dup2 返回 newfd, 而不关闭它。
// 如果 SubIn 不是标准输入，则将 SubIn 的文件信息复制给标准输入，
// 这样读写标准输入就相当于读写 SubIn 了
if (SubIn >= 0) and (SubIn <> StdInputHandle) then
begin
// 执行 FpDup2 后，相当于两个文件描述符同时打开了同一个文件
if FpDup2(SubIn, StdInputHandle) = -1 then
ErrHalt('FpDup2(subIn, StdInputHandle)', Errno, 127);
// 关闭 SubIn，以便其它代码可以重复使用该描述符
FpClose(SubIn);
end;
if (SubOut >= 0) and (SubOut <> StdOutputHandle) then
begin
if FpDup2(SubOut, StdOutputHandle) = -1 then
ErrHalt('FpDup2(subOut, StdOutputHandle)', Errno, 127);
FpClose(SubOut);
end;
if (SubErr >= 0) and (SubErr <> StdErrorHandle) then
begin
if FpDup2(SubErr, StdErrorHandle) = -1 then
ErrHalt('FpDup2(subErr, StdErrorHandle)', Errno, 127);
FpClose(SubErr);
end;
Len := Length(Env);
I := 0;
if CopyEnv then
while Envp[I] <> nil do
I += 1;
// 环境变量列表必须以 #0 结尾，所以预留一个 #0 位置。
// 不会影响到调用者的 Env 参数的长度，除非使用 var 修饰符传入。
SetLength(Env, Len + I + 1);
if CopyEnv then
begin
// 将 Envp 最后的 #0 也写入 Env 中
for I := 0 to I do
Env[Len + I] := Envp[I];
end
else
// 写入最后的 #0
PPChar(Env[High(Env)]) := nil;
// 子进程要执行的程序
// FpExec 函数族命名规律：
// l (list) 使用命令行参数列表，在 Free Pascal 中是数组
// v (vector) 使用命令行参数数组，在 Free Pascal 中是 PPChar
// p (path) 从环境变量 PATH 中搜索程序
// e (environment) 传入自定义环境变量，环境变量通过 PPChar 类型传入
FpExeclpe(PChar(Cmd[0]), Cmd[1..High(Cmd)], PPChar(Env));
// 如果 FpExeclp 函数出错，比如 Cmd 不存在，则代码会执行到这里，
// 这里需要结束子进程，不能使用 Exit 或 Result 返回，
// 否则会回到调用者代码中继续执行父进程的代码。
Halt(127);
end
else
// 父进程要执行的代码
if Pid > 0 then
begin
// 关闭子进程所需的管道端口，只保留父进程所需的管道端口
// 如果 FpClose 的参数无效，则只会返回错误代码，而不会抛出异常
if FIn <> SubIn then FpClose(SubIn );
if FOut <> SubOut then FpClose(SubOut);
if FErr <> SubErr then FpClose(SubErr);
// 是否等待子进程结束
// 正常情况下，如果不等待子进程结束，则当父进程结束后，子进程应该会继续运行，
// 但是如果在 Lazarus 中启动程序，则当父进程退出时，会杀死子进程，
// 如果把程序编译完成后，在 Shell 中执行，或双击执行，则不会出现这个问题。
if Wait then
begin
// FpWaitPid 参数说明
// 参数 Pid 指定要等待的进程：
// Pid < -1：等待进程组号为 Pid 绝对值的任何子进程。
// Pid = -1：等待任何子进程，相当于 Wait() 函数。
// Pid = 0 ：等待进程组号与当前进程相同的任何子进程。
// Pid > 0 ：等待进程号为 Pid 的子进程。
// 参数 Status 用于获取子进程的状态信息，Linux 提供了一些宏来解析这个状态信息：
// WIFEXITED(Status) 如果子进程正常结束，则返回 True；否则返回 False。
// WEXITSTATUS(Status) 如果 WIFEXITED(Status) 为 True，则可用该宏取得子进程的退出码。
// WIFSIGNALED(Status) 如果子进程因为一个未捕获的信号而终止，则返回 True；否则返回 False。
// WTERMSIG(Status) 如果 WIFSIGNALED(Status) 为 True，则可用该宏获得导致子进程终止的信号码。
// WIFSTOPPED(Status) 如果当前子进程被暂停，则返回 True；否则返回 False。
// WSTOPSIG(Status) 如果 WIFSTOPPED(Status) 为 True，则可用该宏获得导致子进程暂停的信号码。
// 最后一个参数 Options 控制 FpWaitPid() 的行为。如果不想控制，则设为 0。
// WNOHANG 如果子进程没有结束，则 FpWaitPid() 函数不等待，立即返回 0；
// 如果结束，则返回子进程的进程号。
// WUNTRACED 如果子进程处于暂停状态，则马上返回。
// 如果 FpWaitPid() 执行成功，则返回子进程的进程号，
// 如果出错，则返回 -1，并将出错原因写入 Errno 中。
Status := 0;
if FpWaitPid(Pid, Status, 0) < 0 then
begin
// WriteStr 或多个字符串相加会修改 Errno 的值，所以要提前保存
Err := Errno;
WriteStr(S, 'FpWaitPid(', Pid, ', ', Status, ', 0)');
ErrMsg(S, Err);
Exit(-1);
end;
// 如果子进程成功退出，则返回退出码，否则返回 -1
if WIFEXITED(Status) then
Result := WEXITSTATUS(Status)
else
Result := -1;
end
else
// 如果不等待，则直接返回子进程的 Pid
Result := Pid;
end;
finally
// 如果 子进程 或 管道 创建失败，则关闭所有管道
if Pid < 0 then
begin
if PIn then
begin
FpClose(FIn);
FpClose(SubIn);
FIn := -1;
end;
if POut then
begin
FpClose(FOut);
FpClose(SubOut);
FOut := -1;
end;
if PErr then
begin
FpClose(FErr);
FpClose(SubErr);
FErr := -1;
end;
end;
end;
end;
function Run(
Cmd : TStringArray;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
var
FIn : CInt;
FOut : CInt;
FErr : CInt;
begin
FIn := StdInputHandle;
FOut := StdOutputHandle;
FErr := StdErrorHandle;
Result := Run(Cmd, FIn, FOut, FErr, Wait, Env, CopyEnv);
end;
function Run(
Cmd : TStringArray;
SIn : String;
var SOut : String;
var SErr : String;
NoIn : Boolean = False;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
var
FIn : CInt;
FOut : CInt;
FErr : CInt;
Status : CInt;
Err : CInt;
S : String;
begin
// -1 表示创建管道（允许输入空字符串，#0 表示使用标准输入）
if not NoIn then FIn := -1 else FIn := StdInputHandle;
if SOut = '' then FOut := -1 else FOut := StdOutputHandle;
if SErr = '' then FErr := -1 else FErr := StdErrorHandle;
// 如果要输入数据，则不能等待程序执行完毕，否则会被阻塞
// 此时 Result 是子进程的 PID
Result := Run(Cmd, FIn, FOut, FErr, False, Env, CopyEnv);
// 如果 Result < 0，则表示子进程创建失败，此时 FIn、FOut、FErr 都会被设置为 -1，
// 所以这里不必判断 Result < 0 的情况
if (not NoIn) and (FIn >= 0) then
begin
// 输入数据
WriteFile(FIn, SIn);
// 输入完数据后，需要关闭输入端，否则子进程会被阻塞
if not (FIn in [StdInputHandle, StdOutputHandle, StdErrorHandle]) then
FpClose(FIn);
end;
if (SOut = '') and (FOut >= 0) then
begin
// 读取数据，直到子程序关闭管道输入端
SOut := ReadFile(FOut);
// 读取完毕后，关闭输出端，以便释放文件描述符
if not (FOut in [StdInputHandle, StdOutputHandle, StdErrorHandle]) then
FpClose(FOut);
end;
if (SErr = '') and (FErr >= 0) then
begin
// 读取数据，直到子程序关闭管道输入端
SErr := ReadFile(FErr);
// 读取完毕后，关闭输出端，以便释放文件描述符
if not (FErr in [StdInputHandle, StdOutputHandle, StdErrorHandle]) then
FpClose(FErr);
end;
// 是否等待子程序执行完毕（子程序在关闭管道后不一定就会退出）
if Wait then
begin
Status := 0;
if FpWaitPid(Result, Status, 0) < 0 then
begin
// WriteStr 或多个字符串相加会修改 Errno 的值，所以要提前保存
Err := Errno;
WriteStr(S, 'FpWaitPid(', Result, ', ', Status, ', 0)');
ErrMsg(S, Err);
Exit(-1);
end;
if WIFEXITED(Status) then
Result := WEXITSTATUS(Status)
else
Result := -1;
end;
end;
function RunIn(
Cmd : TStringArray;
SIn : String;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
var
SOut : String;
SErr : String;
begin
SOut := '-';
SErr := '-';
Result := Run(Cmd, SIn, SOut, SErr, False, Wait, Env, CopyEnv);
end;
function RunOut(
Cmd : TStringArray;
var SOut : String;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
var
SIn : String;
SErr: String;
begin
SIn := '';
SOut := '';
SErr := '-';
Result := Run(Cmd, SIn, SOut, SErr, True, Wait, Env, CopyEnv);
end;
function RunErr(
Cmd : TStringArray;
var SErr : String;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
var
SIn : String;
SOut: String;
begin
SIn := '';
SOut := '-';
SErr := '';
Result := Run(Cmd, SIn, SOut, SErr, True, Wait, Env, CopyEnv);
end;
function RunInOut(
Cmd : TStringArray;
SIn : String;
var SOut : String;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
var
SErr: String;
begin
SOut := '';
SErr := '-';
Result := Run(Cmd, SIn, SOut, SErr, False, Wait, Env, CopyEnv);
end;
function RunInErr(
Cmd : TStringArray;
SIn : String;
var SErr : String;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
var
SOut: String;
begin
SOut := '-';
SErr := '';
Result := Run(Cmd, SIn, SOut, SErr, False, Wait, Env, CopyEnv);
end;
function RunOutErr(
Cmd : TStringArray;
var SOut : String;
var SErr : String;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
var
SIn : String;
begin
SIn := '';
SOut := '';
SErr := '';
Result := Run(Cmd, SIn, SOut, SErr, True, Wait, Env, CopyEnv);
end;
function RunNoOut(
Cmd : TStringArray;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
var
SIn : String;
SOut: String;
SErr: String;
begin
SIn := '';
SOut := '';
SErr := '-';
Result := Run(Cmd, SIn, SOut, SErr, True, Wait, Env, CopyEnv);
end;
function RunNoErr(
Cmd : TStringArray;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
var
SIn : String;
SOut: String;
SErr: String;
begin
SIn := '';
SOut := '-';
SErr := '';
Result := Run(Cmd, SIn, SOut, SErr, True, Wait, Env, CopyEnv);
end;
function RunNoOutErr(
Cmd : TStringArray;
Wait : Boolean = True;
Env : TStringArray = nil;
CopyEnv : Boolean = True
): CInt;
var
SIn : String;
SOut: String;
SErr: String;
begin
SIn := '';
SOut := '';
SErr := '';
Result := Run(Cmd, SIn, SOut, SErr, True, Wait, Env, CopyEnv);
end;
// 输出错误消息，显示 Errno 的字符串解释
procedure ErrMsg(Msg: String; Err: CInt);
begin
WriteLn(StdErr, 'Error: ' + Msg + ': ' + StrError(Err));
end;
// 输出错误消息，显示 Errno 的字符串解释，并终止程序
procedure ErrHalt(Msg: String; Err: CInt; ExitCode: LongInt);
begin
WriteLn(StdErr, 'Error: ' + Msg + ': ' + StrError(Err));
Halt(ExitCode);
end;
// 读取文件内容到字符串中（FD 为文件描述符）
// 由于使用了缓存，必须在关闭文件后，才能读取所写入的文件内容
function ReadFile(Fd: CInt; Quiet: Boolean = False): String;
var
Res: String;
Len: TSsize; // 已读出的数据总长度
Ret: TSsize; // 当前读出的数据长度
Err: CInt;
const
BUFSIZE = 64 * 1024;
begin
Res := '';
Len := 0;
repeat
// 自动扩容
if Len + BUFSIZE > Length(Res) then
begin
// 不大于 16MB，翻倍预留，大于 16M 预留 16M，避免反复申请内存
if Len <= 16 * 1024 * 1024 then
SetLength(Res, Len * 2 + BUFSIZE) // 保证最小不小于 BUFSIZE
else
SetLength(Res, Len + 16 * 1024 * 1024 + BUFSIZE);
end;
Ret := FpRead(Fd, PChar(Res)[Len], BUFSIZE);
Err := Errno;
Len += Ret;
until Ret <= 0;
if (Ret < 0) and (not Quiet) then
begin
Err := Errno;
ErrMsg('FpRead()', Err);
end;
SetLength(Res, Len);
Result := Res;
end;
// 将字符串写入文件（Fd 为文件描述符）
function WriteFile(Fd: CInt; Data: String; Quiet: Boolean = False): Boolean;
var
Len: TSsize; // 已写入的数据总长度
Ret: TSsize; // 当前写入的数据长度
Err: CInt;
begin
Len := 0;
Ret := 1;
while (Ret > 0) and (Len < Length(Data)) do
begin
Ret := FpWrite(Fd, PChar(Data)[Len], Length(Data) - Len);
Len += Ret;
end;
if (Ret < 0) and (not Quiet) then
begin
Err := Errno;
ErrMsg('FpWrite()', Err);
end;
Result := Len = Length(Data);
end;
end.
856
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
