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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
|
{
Spawning and messaging another DOS process
Free Pascal for MorphOS example
(dirty, but actually does work... sometimes... :)
Copyright (C) 2004 by Karoly Balogh
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{ * Thanks fly to Sigbjorn 'CISC' Skjaeret for hints and * }
{ * Michal 'kiero' Wozniak for example code. * }
{ * 2004.12.10 * }
{$MODE FPC}
program process;
uses exec, utility, doslib;
type
pMyMsg = ^tMyMsg;
tMyMsg = Record
mm_MsgNode : tMessage;
mm_Command : DWord;
end;
var
ThMsg : tMyMsg;
ThStartupMsg: tMyMsg;
ThChildPort : pMsgPort;
ThPort : pMsgPort;
ThReplyPort : pMsgPort;
ThProc : pProcess;
const
SUBPROCESS_NAME : PChar = 'FPC subprocess';
const
TCMD_HELLO = 1;
TCMD_WORLD = 2;
TCMD_SPACE = 3;
TCMD_EXCL = 4;
TCMD_NEWL = 5;
TCMD_QUIT = $FF;
procedure ShutDown(Err: String);
begin
if assigned(ThReplyPort) then DeleteMsgPort(ThReplyPort);
if assigned(ThPort) then DeleteMsgPort(ThPort);
if Err<>'' then begin
writeln(Err);
halt(1);
end else
halt(0);
end;
{ * This is our subtask procedure * }
{ * Our subtask do exists until this procedure exits. * }
procedure MyProcess;
var
thisThread: pProcess;
startupMsg: pMyMsg;
mainMsg : pMyMsg;
mainPort : pMsgPort;
finish : Boolean;
begin
{ * Getting startupmsg * }
NewGetTaskAttrs(NIL,@startupMsg,sizeof(startupMsg^),
TASKINFOTYPE_STARTUPMSG,[TAG_DONE]);
startupMsg^.mm_Command:=0;
{ * Getting taskport * }
NewGetTaskAttrs(NIL,@mainPort,sizeof(mainPort^),
TASKINFOTYPE_TASKMSGPORT,[TAG_DONE]);
finish:=False;
repeat
mainMsg:=pMyMsg(GetMsg(mainPort));
if mainMsg<>NIL then begin
{ * Using write in such an example is not really elegant * }
{ * since write is not reentrant yet, so if more tasks * }
{ * use it in the same time, it will make troubles. * }
{ * but it does what we want now. * }
Case mainMsg^.mm_Command Of
TCMD_HELLO: write('Hello');
TCMD_WORLD: write('World');
TCMD_SPACE: write(' ');
TCMD_EXCL : write('!');
TCMD_NEWL : writeln;
TCMD_QUIT : finish:=True;
end;
Inc(startupMsg^.mm_Command);
ReplyMsg(pMessage(mainMsg));
end;
{ * Polling for messages... * }
{ * It's possible to use WaitPort() of course, but * }
{ * you probably want to do some stuff in the background * }
{ * so it's more useful to poll then. Replace Delay() * }
{ * with your code, or more, add your code after it. * }
Delay(1);
until finish;
{ * We MUST NOT reply StartupMsg! * }
{ * It will be replied by exec internally. * }
end;
{ * This is a helper proc, makes sending * }
{ * of command messages more easy. * }
procedure SendMsg(msgID : DWord);
begin
with ThMsg do begin
with mm_MsgNode do begin
mn_Node.ln_Type:=NT_MESSAGE;
mn_Length:=SizeOf(tMyMsg);
mn_ReplyPort:=ThPort;
end;
mm_Command:=msgID;
end;
PutMsg(ThChildPort,pMessage(@ThMsg));
end;
begin
ThReplyPort:=CreateMsgPort;
ThPort:=CreateMsgPort;
if (ThReplyPort=NIL) or (ThPort=NIL) then
ShutDown('Can''t create message ports.');
{ * Setting up StartupMsg * }
with ThStartupMsg do begin
with mm_MsgNode do begin
mn_Node.ln_Type:=NT_MESSAGE;
mn_Length:=SizeOf(tMyMsg);
mn_ReplyPort:=ThReplyPort;
end;
end;
ThProc:=CreateNewProcTags([NP_CodeType , CODETYPE_PPC,
NP_Entry , DWord(@MyProcess),
NP_Name , DWord(SUBPROCESS_NAME),
NP_StartupMsg , DWord(@ThStartupMsg),
NP_TaskMsgPort , DWord(@ThChildPort),
{ * such stacksize is overkill for our current * }
{ * subtask, but more complex things may actually * }
{ * require even more... * }
NP_PPCStackSize, 32768,
TAG_DONE]);
if ThProc=NIL then ShutDown('Can''t create subprocess!');
SendMsg(TCMD_HELLO);
WaitPort(ThPort); GetMsg(ThPort);
SendMsg(TCMD_SPACE);
WaitPort(ThPort); GetMsg(ThPort);
SendMsg(TCMD_WORLD);
WaitPort(ThPort); GetMsg(ThPort);
SendMsg(TCMD_EXCL);
WaitPort(ThPort); GetMsg(ThPort);
SendMsg(TCMD_NEWL);
WaitPort(ThPort); GetMsg(ThPort);
SendMsg(TCMD_QUIT);
WaitPort(ThPort); GetMsg(ThPort);
{ * Wait our subprocess to exit... * }
WaitPort(ThReplyPort); GetMsg(ThReplyPort);
writeln('Subtask got ',ThStartupMsg.mm_Command,' message(s).');
ShutDown('');
end.
|
