This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
amigaos4: add amigaos the glue code
[perl5.git] / amigaos4 / amigaio.c
CommitLineData
a83a2cd1
AB
1/* amigaio.c mixes amigaos and perl APIs,
2 * as opposed to amigaos.c which is pure amigaos */
3
4#include "EXTERN.h"
5#include "perl.h"
6
7#include "amigaos4/amigaio.h"
8#include "amigaos.h"
9
10#ifdef WORD
11# undef WORD
12# define WORD int16
13#endif
14
15#include <exec/semaphores.h>
16#include <exec/exectags.h>
17#include <proto/exec.h>
18#include <proto/dos.h>
19#include <dos/dos.h>
20
21void amigaos_stdio_get(pTHX_ StdioStore *store)
22{
23 store->astdin =
24 amigaos_get_file(PerlIO_fileno(IoIFP(GvIO(PL_stdingv))));
25 store->astderr =
26 amigaos_get_file(PerlIO_fileno(IoIFP(GvIO(PL_stderrgv))));
27 store->astdout = amigaos_get_file(
28 PerlIO_fileno(IoIFP(GvIO(gv_fetchpv("STDOUT", TRUE, SVt_PVIO)))));
29}
30
31void amigaos_stdio_save(pTHX_ StdioStore *store)
32{
33 amigaos_stdio_get(aTHX_ store);
34 store->oldstdin = IDOS->SelectInput(store->astdin);
35 store->oldstderr = IDOS->SelectErrorOutput(store->astderr);
36 store->oldstdout = IDOS->SelectOutput(store->astdout);
37}
38
39void amigaos_stdio_restore(pTHX_ const StdioStore *store)
40{
41 IDOS->SelectInput(store->oldstdin);
42 IDOS->SelectErrorOutput(store->oldstderr);
43 IDOS->SelectOutput(store->oldstdout);
44}
45
46void amigaos_post_exec(int fd, int do_report)
47{
48 /* We *must* write something to our pipe or else
49 * the other end hangs */
50 if (do_report)
51 {
52 int e = errno;
53 PerlLIO_write(fd, (void *)&e, sizeof(e));
54 PerlLIO_close(fd);
55 }
56}
57
58PerlIO *Perl_my_popen(pTHX_ const char *cmd, const char *mode)
59{
60 PERL_FLUSHALL_FOR_CHILD;
61 /* Call system's popen() to get a FILE *, then import it.
62 * used 0 for 2nd parameter to PerlIO_importFILE;
63 * apparently not used
64 */
65 // FILE *f=amigaos_popen(cmd,mode);
66 // fprintf(stderr,"popen returned %d\n",f);
67 return PerlIO_importFILE(amigaos_popen(cmd, mode), 0);
68 // return PerlIO_importFILE(f, 0);
69}
70
71#ifdef USE_ITHREADS
72
73/* An arbitrary number to start with, should work out what the real max should
74 * be */
75
76#ifndef MAX_THREADS
77# define MAX_THREADS 64
78#endif
79
80#define REAPED 0
81#define ACTIVE 1
82#define EXITED -1
83
84struct thread_info
85{
86 pthread_t ti_pid;
87 int ti_children;
88 pthread_t ti_parent;
89 struct MsgPort *ti_port;
90};
91
92static struct thread_info pseudo_children[MAX_THREADS];
93static int num_pseudo_children = 0;
94static struct SignalSemaphore fork_array_sema;
95
96void amigaos4_init_fork_array()
97{
98 IExec->InitSemaphore(&fork_array_sema);
99 pseudo_children[0].ti_pid = (pthread_t)IExec->FindTask(0);
100 pseudo_children[0].ti_parent = -1;
101 pseudo_children[0].ti_port =
102 (struct MsgPort *)IExec->AllocSysObjectTags(ASOT_PORT, TAG_DONE);
103}
104
105void amigaos4_dispose_fork_array()
106{
107 while (pseudo_children[0].ti_children > 0)
108 {
109 void *msg;
110 IExec->WaitPort(pseudo_children[0].ti_port);
111 msg = IExec->GetMsg(pseudo_children[0].ti_port);
112 if (msg)
113 IExec->FreeSysObject(ASOT_MESSAGE, msg);
114 pseudo_children[0].ti_children--;
115 }
116 IExec->FreeSysObject(ASOT_PORT, pseudo_children[0].ti_port);
117}
118
119struct thread_exit_message
120{
121 struct Message tem_Message;
122 pthread_t tem_pid;
123 int tem_status;
124};
125
126int getnextchild()
127{
128 int i;
129 for (i = 0; i < MAX_THREADS; i++)
130 {
131 if (pseudo_children[i].ti_pid == 0)
132 return i;
133 }
134 return -1;
135}
136
137int findparent(pthread_t pid)
138{
139 int i;
140 for (i = 0; i < MAX_THREADS; i++)
141 {
142 if (pseudo_children[i].ti_pid == pid)
143 return i;
144 }
145 return -1;
146}
147
148struct child_arg
149{
150 struct Task *ca_parent_task;
151 pthread_t ca_parent;
152 PerlInterpreter *ca_interp;
153};
154
155static THREAD_RET_TYPE amigaos4_start_child(void *arg)
156{
157
158 PerlInterpreter *my_perl =
159 (PerlInterpreter *)((struct child_arg *)arg)->ca_interp;
160 ;
161
162 GV *tmpgv;
163 int status;
164 int parent;
165 int nextchild;
166 pthread_t pseudo_id = pthread_self();
167
168#ifdef PERL_SYNC_FORK
169 static long sync_fork_id = 0;
170 long id = ++sync_fork_id;
171#endif
172
173 /* before we do anything set up our process semaphore and add
174 a new entry to the pseudochildren */
175
176 /* get next available slot */
177 /* should not fail here! */
178
179 IExec->ObtainSemaphore(&fork_array_sema);
180
181 nextchild = getnextchild();
182
183 pseudo_children[nextchild].ti_pid = pseudo_id;
184 pseudo_children[nextchild].ti_parent =
185 ((struct child_arg *)arg)->ca_parent;
186 pseudo_children[nextchild].ti_port =
187 (struct MsgPort *)IExec->AllocSysObjectTags(ASOT_PORT, TAG_DONE);
188
189 num_pseudo_children++;
190 IExec->ReleaseSemaphore(&fork_array_sema);
191
192 /* We're set up let the parent continue */
193
194 IExec->Signal(((struct child_arg *)arg)->ca_parent_task,
195 SIGBREAKF_CTRL_F);
196
197 PERL_SET_THX(my_perl);
198 if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
199 {
200 SV *sv = GvSV(tmpgv);
201 SvREADONLY_off(sv);
202 sv_setiv(sv, (IV)pseudo_id);
203 SvREADONLY_on(sv);
204 }
205 hv_clear(PL_pidstatus);
206
207 /* push a zero on the stack (we are the child) */
208 {
209 dSP;
210 dTARGET;
211 PUSHi(0);
212 PUTBACK;
213 }
214
215 /* continue from next op */
216 PL_op = PL_op->op_next;
217
218 {
219 dJMPENV;
220 volatile int oldscope = PL_scopestack_ix;
221
222 restart:
223 JMPENV_PUSH(status);
224 switch (status)
225 {
226 case 0:
227 CALLRUNOPS(aTHX);
228 status = 0;
229 break;
230 case 2:
231 while (PL_scopestack_ix > oldscope)
232 {
233 LEAVE;
234 }
235 FREETMPS;
236 PL_curstash = PL_defstash;
237 if (PL_endav && !PL_minus_c)
238 call_list(oldscope, PL_endav);
239 status = STATUS_EXIT;
240 break;
241 case 3:
242 if (PL_restartop)
243 {
244 POPSTACK_TO(PL_mainstack);
245 PL_op = PL_restartop;
246 PL_restartop = (OP *)NULL;
247 ;
248 goto restart;
249 }
250 PerlIO_printf(Perl_error_log, "panic: restartop\n");
251 FREETMPS;
252 status = 1;
253 break;
254 }
255 JMPENV_POP;
256
257 /* XXX hack to avoid perl_destruct() freeing optree */
258 PL_main_root = (OP *)NULL;
259 }
260
261 {
262 do_close(PL_stdingv, FALSE);
263 do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO),
264 FALSE); /* PL_stdoutgv - ISAGN */
265 do_close(PL_stderrgv, FALSE);
266 }
267
268 /* destroy everything (waits for any pseudo-forked children) */
269
270 /* wait for any remaining children */
271
272 while (pseudo_children[nextchild].ti_children > 0)
273 {
274 if (IExec->WaitPort(pseudo_children[nextchild].ti_port))
275 {
276 void *msg =
277 IExec->GetMsg(pseudo_children[nextchild].ti_port);
278 IExec->FreeSysObject(ASOT_MESSAGE, msg);
279 pseudo_children[nextchild].ti_children--;
280 }
281 }
282 if (PL_scopestack_ix <= 1)
283 {
284 perl_destruct(my_perl);
285 }
286 perl_free(my_perl);
287
288 IExec->ObtainSemaphore(&fork_array_sema);
289 parent = findparent(pseudo_children[nextchild].ti_parent);
290 pseudo_children[nextchild].ti_pid = 0;
291 pseudo_children[nextchild].ti_parent = 0;
292 IExec->FreeSysObject(ASOT_PORT, pseudo_children[nextchild].ti_port);
293 pseudo_children[nextchild].ti_port = NULL;
294
295 IExec->ReleaseSemaphore(&fork_array_sema);
296
297 {
298 if (parent >= 0)
299 {
300 struct thread_exit_message *tem =
301 (struct thread_exit_message *)
302 IExec->AllocSysObjectTags(
303 ASOT_MESSAGE, ASOMSG_Size,
304 sizeof(struct thread_exit_message),
305 ASOMSG_Length,
306 sizeof(struct thread_exit_message));
307 if (tem)
308 {
309 tem->tem_pid = pseudo_id;
310 tem->tem_status = status;
311 IExec->PutMsg(pseudo_children[parent].ti_port,
312 (struct Message *)tem);
313 }
314 }
315 }
316#ifdef PERL_SYNC_FORK
317 return id;
318#else
319 return (void *)status;
320#endif
321}
322
323#endif /* USE_ITHREADS */
324
325Pid_t amigaos_fork()
326{
327 dTHX;
328 pthread_t id;
329 int handle;
330 struct child_arg arg;
331 if (num_pseudo_children >= MAX_THREADS)
332 {
333 errno = EAGAIN;
334 return -1;
335 }
336 arg.ca_interp = perl_clone((PerlInterpreter *)aTHX, CLONEf_COPY_STACKS);
337 arg.ca_parent_task = IExec->FindTask(NULL);
338 arg.ca_parent =
339 pthread_self() ? pthread_self() : (pthread_t)IExec->FindTask(0);
340
341 handle = pthread_create(&id, NULL, amigaos4_start_child, (void *)&arg);
342 pseudo_children[findparent(arg.ca_parent)].ti_children++;
343
344 IExec->Wait(SIGBREAKF_CTRL_F);
345
346 PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */
347 if (handle)
348 {
349 errno = EAGAIN;
350 return -1;
351 }
352 return id;
353}
354
355Pid_t amigaos_waitpid(pTHX_ int optype, Pid_t pid, void *argflags)
356{
357 int result;
358 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
359 {
360 result = pthread_join(pid, argflags);
361 }
362 else
363 {
364 while ((result = pthread_join(pid, argflags)) == -1 &&
365 errno == EINTR)
366 {
367 // PERL_ASYNC_CHECK();
368 }
369 }
370 return result;
371}
372
373void amigaos_fork_set_userdata(
374 pTHX_ struct UserData *userdata, I32 did_pipes, int pp, SV **sp, SV **mark)
375{
376 userdata->parent = IExec->FindTask(0);
377 userdata->did_pipes = did_pipes;
378 userdata->pp = pp;
379 userdata->sp = sp;
380 userdata->mark = mark;
381 userdata->my_perl = aTHX;
382}
383
384void *amigaos_system_child(void *userdata)
385{
386 struct Task *parent;
387 I32 did_pipes;
388 int pp;
389 I32 value;
390 STRLEN n_a;
391 /* these next are declared by macros else where but I may be
392 * passing modified values here so declare them explictly but
393 * still referred to by macro below */
394
395 register SV **sp;
396 register SV **mark;
397 register PerlInterpreter *my_perl;
398
399 StdioStore store;
400
401 struct UserData *ud = (struct UserData *)userdata;
402
403 did_pipes = ud->did_pipes;
404 parent = ud->parent;
405 pp = ud->pp;
406 SP = ud->sp;
407 MARK = ud->mark;
408 my_perl = ud->my_perl;
409 PERL_SET_THX(my_perl);
410
411 amigaos_stdio_save(aTHX_ & store);
412
413 if (did_pipes)
414 {
415 // PerlLIO_close(pp[0]);
416 }
417 if (PL_op->op_flags & OPf_STACKED)
418 {
419 SV *really = *++MARK;
420 value = (I32)do_aexec5(really, MARK, SP, pp, did_pipes);
421 }
422 else if (SP - MARK != 1)
423 {
424 value = (I32)do_aexec5(NULL, MARK, SP, pp, did_pipes);
425 }
426 else
427 {
428 value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp,
429 did_pipes);
430 }
431
432 // Forbid();
433 // Signal(parent, SIGBREAKF_CTRL_F);
434
435 amigaos_stdio_restore(aTHX_ & store);
436
437 return value;
438}