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
|
program TestC{lone};
{$ifdef Linux}
// close is very Linux specific. 1.9.x threading is done via pthreads.
uses
Linux, Errors, crt;
const
Ready : Boolean = false;
aChar : Char = 'a';
function CloneProc( Arg: Pointer ): LongInt; Cdecl;
begin
WriteLn('Hello from the clone ',PChar(Arg));
repeat
Write(aChar);
Select(0,0,0,0,600);
until Ready;
WriteLn( 'Clone finished.');
CloneProc := 1;
end;
var
PID : LongInt;
procedure MainProc;
begin
WriteLn('cloned process PID: ', PID );
WriteLn('Press <ESC> to kill ... ' );
repeat
Write('.');
Select(0,0,0,0,300);
if KeyPressed then
case ReadKey of
#27: Ready := true;
'a': aChar := 'A';
'A': aChar := 'a';
'b': aChar := 'b';
'B': aChar := 'B';
end;
until Ready;
WriteLn('Ready.');
end;
const
StackSze = 16384;
theFlags = CLONE_VM+CLONE_FS+CLONE_FILES+CLONE_SIGHAND;
aMsg : PChar = 'Oops !';
var
theStack : Pointer;
ExitStat : LongInt;
begin
GetMem(theStack,StackSze);
PID := Clone(@CloneProc,
Pointer( LongInt(theStack)+StackSze),
theFlags,
aMsg);
if PID < 0 then
WriteLn('Error : ', LinuxError, ' when cloning.')
else
begin
MainProc;
case WaitPID(0,@ExitStat,Wait_Untraced or wait_clone) of
-1: WriteLn('error:',LinuxError,'; ',StrError(LinuxError));
0: WriteLn('error:',LinuxError,'; ',StrError(LinuxError));
else
WriteLn('Clone exited with: ',ExitStat shr 8);
end;
end;
FreeMem( theStack, StackSze );
{$else}
begin
{$endif}
end.
|
