This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perlapi: Remove per-thread section; move to real scns
[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
738ab09f
AB
15#include <stdio.h>
16
a83a2cd1
AB
17#include <exec/semaphores.h>
18#include <exec/exectags.h>
19#include <proto/exec.h>
20#include <proto/dos.h>
6de23f80 21#include <proto/utility.h>
a83a2cd1
AB
22#include <dos/dos.h>
23
47718690
AB
24extern struct SignalSemaphore popen_sema;
25extern unsigned int pipenum;
26
27extern int32 myruncommand(BPTR seglist, int stack, char *command, int length, char **envp);
28
a83a2cd1
AB
29void amigaos_stdio_get(pTHX_ StdioStore *store)
30{
6c47084d
JH
31 store->astdin =
32 amigaos_get_file(PerlIO_fileno(IoIFP(GvIO(PL_stdingv))));
33 store->astderr =
34 amigaos_get_file(PerlIO_fileno(IoIFP(GvIO(PL_stderrgv))));
35 store->astdout = amigaos_get_file(
36 PerlIO_fileno(IoIFP(GvIO(gv_fetchpv("STDOUT", TRUE, SVt_PVIO)))));
a83a2cd1
AB
37}
38
39void amigaos_stdio_save(pTHX_ StdioStore *store)
40{
6c47084d
JH
41 amigaos_stdio_get(aTHX_ store);
42 store->oldstdin = IDOS->SelectInput(store->astdin);
43 store->oldstderr = IDOS->SelectErrorOutput(store->astderr);
44 store->oldstdout = IDOS->SelectOutput(store->astdout);
a83a2cd1
AB
45}
46
47void amigaos_stdio_restore(pTHX_ const StdioStore *store)
48{
6c47084d
JH
49 IDOS->SelectInput(store->oldstdin);
50 IDOS->SelectErrorOutput(store->oldstderr);
51 IDOS->SelectOutput(store->oldstdout);
a83a2cd1
AB
52}
53
54void amigaos_post_exec(int fd, int do_report)
55{
6c47084d
JH
56 /* We *must* write something to our pipe or else
57 * the other end hangs */
58 if (do_report)
59 {
60 int e = errno;
61 PerlLIO_write(fd, (void *)&e, sizeof(e));
62 PerlLIO_close(fd);
63 }
a83a2cd1
AB
64}
65
47718690
AB
66
67struct popen_data
68{
69 struct Task *parent;
70 STRPTR command;
71};
72
73static int popen_result = 0;
74
75int popen_child()
76{
77 struct Task *thisTask = IExec->FindTask(0);
78 struct popen_data *pd = (struct popen_data *)thisTask->tc_UserData;
79 const char *argv[4];
80
81 argv[0] = "sh";
82 argv[1] = "-c";
83 argv[2] = pd->command ? pd->command : NULL;
84 argv[3] = NULL;
85
86 // adebug("%s %ld %s\n",__FUNCTION__,__LINE__,command?command:"NULL");
87
88 /* We need to give this to sh via execvp, execvp expects filename,
89 * argv[]
90 */
91 IExec->ObtainSemaphore(&popen_sema);
92
93 IExec->Signal(pd->parent,SIGBREAKF_CTRL_F);
94
95 popen_result = myexecvp(FALSE, argv[0], (char **)argv);
96 if (pd->command)
97 IExec->FreeVec(pd->command);
98 IExec->FreeVec(pd);
99
100 IExec->ReleaseSemaphore(&popen_sema);
101 IExec->Forbid();
102 return 0;
103}
104
105
a83a2cd1
AB
106PerlIO *Perl_my_popen(pTHX_ const char *cmd, const char *mode)
107{
47718690 108
6c47084d 109 PERL_FLUSHALL_FOR_CHILD;
47718690
AB
110 PerlIO *result = NULL;
111 char pipe_name[50];
112 char unix_pipe[50];
113 char ami_pipe[50];
114 BPTR input = 0;
115 BPTR output = 0;
116 struct Process *proc = NULL;
117 struct Task *thisTask = IExec->FindTask(0);
118 struct popen_data * pd = NULL;
119
120 /* First we need to check the mode
121 * We can only have unidirectional pipes
122 */
123 // adebug("%s %ld cmd %s mode %s \n",__FUNCTION__,__LINE__,cmd,
124 // mode);
125
126 switch (mode[0])
127 {
128 case 'r':
129 case 'w':
130 break;
131
132 default:
133
134 errno = EINVAL;
135 return result;
136 }
137
138 /* Make a unique pipe name
139 * we need a unix one and an amigaos version (of the same pipe!)
140 * as were linking with libunix.
141 */
142
143 sprintf(pipe_name, "%x%08lx/4096/0", pipenum++,
144 IUtility->GetUniqueID());
145 sprintf(unix_pipe, "/PIPE/%s", pipe_name);
146 sprintf(ami_pipe, "PIPE:%s", pipe_name);
147
148 /* Now we open the AmigaOs Filehandles That we wil pass to our
149 * Sub process
150 */
151
152 if (mode[0] == 'r')
153 {
154 /* A read mode pipe: Output from pipe input from Output() or NIL:*/
155 /* First attempt to DUP Output() */
156 input = IDOS->DupFileHandle(IDOS->Input());
157 if(input == 0)
158 {
159 input = IDOS->Open("NIL:", MODE_READWRITE);
160 }
161 if (input != 0)
162 {
163 output = IDOS->Open(ami_pipe, MODE_NEWFILE);
164 }
165 result = PerlIO_open(unix_pipe, mode);
166 }
167 else
168 {
169 /* Open the write end first! */
170
171 result = PerlIO_open(unix_pipe, mode);
172
173 input = IDOS->Open(ami_pipe, MODE_OLDFILE);
174 if (input != 0)
175 {
176 output = IDOS->DupFileHandle(IDOS->Output());
177 if(output == 0)
178 {
179 output = IDOS->Open("NIL:", MODE_READWRITE);
180 }
181 }
182 }
183 if ((input == 0) || (output == 0) || (result == NULL))
184 {
185 /* Ouch stream opening failed */
186 /* Close and bail */
187 if (input)
188 IDOS->Close(input);
189 if (output)
190 IDOS->Close(output);
191 if(result)
192 {
193 PerlIO_close(result);
194 result = NULL;
195 }
196 return result;
197 }
198
199 /* We have our streams now start our new process
200 * We're using a new process so that execve can modify the environment
201 * with messing things up for the shell that launched perl
202 * Copy cmd before we launch the subprocess as perl seems to waste
203 * no time in overwriting it! The subprocess will free the copy.
204 */
205
206 if((pd = (struct popen_data*)IExec->AllocVecTags(sizeof(struct popen_data),AVT_Type,MEMF_SHARED,TAG_DONE)))
207 {
208 pd->parent = thisTask;
209 if ((pd->command = mystrdup(cmd)))
210 {
211 // adebug("%s %ld
212 // %s\n",__FUNCTION__,__LINE__,cmd_copy?cmd_copy:"NULL");
213 proc = IDOS->CreateNewProcTags(
214 NP_Entry, popen_child, NP_Child, TRUE, NP_StackSize,
215 ((struct Process *)thisTask)->pr_StackSize, NP_Input, input,
216 NP_Output, output, NP_Error, IDOS->ErrorOutput(),
217 NP_CloseError, FALSE, NP_Cli, TRUE, NP_Name,
218 "Perl: popen process", NP_UserData, (int)pd,
219 TAG_DONE);
220 }
221 }
222 if(proc)
223 {
224 /* wait for the child be setup right */
225 IExec->Wait(SIGBREAKF_CTRL_F);
226 }
227 if (!proc)
228 {
229 /* New Process Failed to start
230 * Close and bail out
231 */
232 if(pd)
233 {
234 if(pd->command)
235 {
236 IExec->FreeVec(pd->command);
237 }
238 IExec->FreeVec(pd);
239 }
240 if (input)
241 IDOS->Close(input);
242 if (output)
243 IDOS->Close(output);
244 if(result)
245 {
246 PerlIO_close(result);
247 result = NULL;
248 }
249 }
250
251 /* Our new process is running and will close it streams etc
252 * once its done. All we need to is open the pipe via stdio
253 */
254
255 return result;
a83a2cd1
AB
256}
257
47718690
AB
258I32
259Perl_my_pclose(pTHX_ PerlIO *ptr)
6de23f80 260{
47718690
AB
261 int result = -1;
262 /* close the file before obtaining the semaphore else we might end up
263 hanging waiting for the child to read the last bit from the pipe */
264 PerlIO_close(ptr);
265 IExec->ObtainSemaphore(&popen_sema);
266 result = popen_result;
267 IExec->ReleaseSemaphore(&popen_sema);
6de23f80
AB
268 return result;
269}
270
47718690 271
a83a2cd1
AB
272#ifdef USE_ITHREADS
273
274/* An arbitrary number to start with, should work out what the real max should
275 * be */
276
277#ifndef MAX_THREADS
278# define MAX_THREADS 64
279#endif
280
281#define REAPED 0
282#define ACTIVE 1
283#define EXITED -1
284
285struct thread_info
286{
6c47084d
JH
287 pthread_t ti_pid;
288 int ti_children;
289 pthread_t ti_parent;
290 struct MsgPort *ti_port;
291 struct Process *ti_Process;
a83a2cd1
AB
292};
293
294static struct thread_info pseudo_children[MAX_THREADS];
295static int num_pseudo_children = 0;
296static struct SignalSemaphore fork_array_sema;
297
298void amigaos4_init_fork_array()
299{
6c47084d
JH
300 IExec->InitSemaphore(&fork_array_sema);
301 pseudo_children[0].ti_pid = (pthread_t)IExec->FindTask(0);
302 pseudo_children[0].ti_parent = -1;
303 pseudo_children[0].ti_port =
304 (struct MsgPort *)IExec->AllocSysObjectTags(ASOT_PORT, TAG_DONE);
a83a2cd1
AB
305}
306
307void amigaos4_dispose_fork_array()
308{
6c47084d
JH
309 while (pseudo_children[0].ti_children > 0)
310 {
311 void *msg;
312 IExec->WaitPort(pseudo_children[0].ti_port);
313 msg = IExec->GetMsg(pseudo_children[0].ti_port);
314 if (msg)
315 IExec->FreeSysObject(ASOT_MESSAGE, msg);
316 pseudo_children[0].ti_children--;
317 }
318 IExec->FreeSysObject(ASOT_PORT, pseudo_children[0].ti_port);
a83a2cd1
AB
319}
320
321struct thread_exit_message
322{
6c47084d
JH
323 struct Message tem_Message;
324 pthread_t tem_pid;
325 int tem_status;
a83a2cd1
AB
326};
327
328int getnextchild()
329{
6c47084d
JH
330 int i;
331 for (i = 0; i < MAX_THREADS; i++)
332 {
333 if (pseudo_children[i].ti_pid == 0)
334 return i;
335 }
336 return -1;
a83a2cd1
AB
337}
338
339int findparent(pthread_t pid)
340{
6c47084d
JH
341 int i;
342 for (i = 0; i < MAX_THREADS; i++)
343 {
344 if (pseudo_children[i].ti_pid == pid)
345 return i;
346 }
347 return -1;
a83a2cd1
AB
348}
349
350struct child_arg
351{
6c47084d
JH
352 struct Task *ca_parent_task;
353 pthread_t ca_parent;
354 PerlInterpreter *ca_interp;
a83a2cd1
AB
355};
356
ef2467ad
AB
357#undef kill
358
359/* FIXME: Is here's a chance, albeit it small of a clash between our pseudo pid */
360/* derived from the pthread API and the dos.library pid that newlib kill uses? */
361/* clib2 used the Process address so there was no issue */
362
363int amigaos_kill(Pid_t pid, int signal)
364{
365 int i;
e92b5416 366 BOOL thistask = FALSE;
ef2467ad
AB
367 Pid_t realpid = pid; // Perhaps we have a real pid from else where?
368 /* Look for our DOS pid */
369 IExec->ObtainSemaphore(&fork_array_sema);
370 for (i = 0; i < MAX_THREADS; i++)
371 {
372 if (pseudo_children[i].ti_pid == pid)
373 {
374 realpid = (Pid_t)IDOS->GetPID(pseudo_children[i].ti_Process,GPID_PROCESS);
47718690 375 if(pseudo_children[i].ti_Process == (struct Process *)IExec->FindTask(NULL))
e92b5416
AB
376 {
377 thistask = TRUE;
378 }
ef2467ad
AB
379 break;
380 }
381 }
382 IExec->ReleaseSemaphore(&fork_array_sema);
383 /* Allow the C library to work out which signals are realy valid */
e92b5416
AB
384 if(thistask)
385 {
386 /* A quirk in newlib kill handling means it's better to call raise() rather than kill on out own task. */
387 return raise(signal);
388 }
389 else
390 {
391 return kill(realpid,signal);
392 }
ef2467ad
AB
393}
394
a83a2cd1
AB
395static THREAD_RET_TYPE amigaos4_start_child(void *arg)
396{
397
6c47084d
JH
398 PerlInterpreter *my_perl =
399 (PerlInterpreter *)((struct child_arg *)arg)->ca_interp;
400 ;
a83a2cd1 401
6c47084d
JH
402 GV *tmpgv;
403 int status;
404 int parent;
405 int nextchild;
406 pthread_t pseudo_id = pthread_self();
a83a2cd1
AB
407
408#ifdef PERL_SYNC_FORK
6c47084d
JH
409 static long sync_fork_id = 0;
410 long id = ++sync_fork_id;
a83a2cd1
AB
411#endif
412
6c47084d
JH
413 /* before we do anything set up our process semaphore and add
414 a new entry to the pseudochildren */
415
416 /* get next available slot */
417 /* should not fail here! */
418
419 IExec->ObtainSemaphore(&fork_array_sema);
420
421 nextchild = getnextchild();
422
423 pseudo_children[nextchild].ti_pid = pseudo_id;
424 pseudo_children[nextchild].ti_Process = (struct Process *)IExec->FindTask(NULL);
425 pseudo_children[nextchild].ti_parent =
426 ((struct child_arg *)arg)->ca_parent;
427 pseudo_children[nextchild].ti_port =
428 (struct MsgPort *)IExec->AllocSysObjectTags(ASOT_PORT, TAG_DONE);
429
430 num_pseudo_children++;
431 IExec->ReleaseSemaphore(&fork_array_sema);
432
433 /* We're set up let the parent continue */
434
435 IExec->Signal(((struct child_arg *)arg)->ca_parent_task,
436 SIGBREAKF_CTRL_F);
437
438 PERL_SET_THX(my_perl);
439 if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
440 {
441 SV *sv = GvSV(tmpgv);
442 SvREADONLY_off(sv);
443 sv_setiv(sv, (IV)pseudo_id);
444 SvREADONLY_on(sv);
445 }
446 hv_clear(PL_pidstatus);
447
448 /* push a zero on the stack (we are the child) */
449 {
450 dSP;
451 dTARGET;
452 PUSHi(0);
453 PUTBACK;
454 }
455
456 /* continue from next op */
457 PL_op = PL_op->op_next;
458
459 {
460 dJMPENV;
461 volatile int oldscope = PL_scopestack_ix;
462
463restart:
464 JMPENV_PUSH(status);
465 switch (status)
466 {
467 case 0:
468 CALLRUNOPS(aTHX);
469 status = 0;
470 break;
471 case 2:
472 while (PL_scopestack_ix > oldscope)
473 {
474 LEAVE;
475 }
476 FREETMPS;
477 PL_curstash = PL_defstash;
478 if (PL_endav && !PL_minus_c)
479 call_list(oldscope, PL_endav);
480 status = STATUS_EXIT;
481 break;
482 case 3:
483 if (PL_restartop)
484 {
485 POPSTACK_TO(PL_mainstack);
486 PL_op = PL_restartop;
487 PL_restartop = (OP *)NULL;
488 ;
489 goto restart;
490 }
491 PerlIO_printf(Perl_error_log, "panic: restartop\n");
492 FREETMPS;
493 status = 1;
494 break;
495 }
496 JMPENV_POP;
497
498 /* XXX hack to avoid perl_destruct() freeing optree */
499 PL_main_root = (OP *)NULL;
500 }
501
502 {
503 do_close(PL_stdingv, FALSE);
504 do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO),
505 FALSE); /* PL_stdoutgv - ISAGN */
506 do_close(PL_stderrgv, FALSE);
507 }
508
509 /* destroy everything (waits for any pseudo-forked children) */
510
511 /* wait for any remaining children */
512
513 while (pseudo_children[nextchild].ti_children > 0)
514 {
515 if (IExec->WaitPort(pseudo_children[nextchild].ti_port))
516 {
517 void *msg =
518 IExec->GetMsg(pseudo_children[nextchild].ti_port);
519 IExec->FreeSysObject(ASOT_MESSAGE, msg);
520 pseudo_children[nextchild].ti_children--;
521 }
522 }
523 if (PL_scopestack_ix <= 1)
524 {
525 perl_destruct(my_perl);
526 }
527 perl_free(my_perl);
528
529 IExec->ObtainSemaphore(&fork_array_sema);
530 parent = findparent(pseudo_children[nextchild].ti_parent);
531 pseudo_children[nextchild].ti_pid = 0;
532 pseudo_children[nextchild].ti_parent = 0;
533 IExec->FreeSysObject(ASOT_PORT, pseudo_children[nextchild].ti_port);
534 pseudo_children[nextchild].ti_port = NULL;
535
536 IExec->ReleaseSemaphore(&fork_array_sema);
537
538 {
539 if (parent >= 0)
540 {
541 struct thread_exit_message *tem =
542 (struct thread_exit_message *)
543 IExec->AllocSysObjectTags(
544 ASOT_MESSAGE, ASOMSG_Size,
545 sizeof(struct thread_exit_message),
546 ASOMSG_Length,
547 sizeof(struct thread_exit_message));
548 if (tem)
549 {
550 tem->tem_pid = pseudo_id;
551 tem->tem_status = status;
552 IExec->PutMsg(pseudo_children[parent].ti_port,
553 (struct Message *)tem);
554 }
555 }
556 }
a83a2cd1 557#ifdef PERL_SYNC_FORK
6c47084d 558 return id;
a83a2cd1 559#else
6c47084d 560 return (void *)status;
a83a2cd1
AB
561#endif
562}
563
564#endif /* USE_ITHREADS */
565
566Pid_t amigaos_fork()
567{
6c47084d
JH
568 dTHX;
569 pthread_t id;
570 int handle;
571 struct child_arg arg;
572 if (num_pseudo_children >= MAX_THREADS)
573 {
574 errno = EAGAIN;
575 return -1;
576 }
577 arg.ca_interp = perl_clone((PerlInterpreter *)aTHX, CLONEf_COPY_STACKS);
578 arg.ca_parent_task = IExec->FindTask(NULL);
579 arg.ca_parent =
580 pthread_self() ? pthread_self() : (pthread_t)IExec->FindTask(0);
581
582 handle = pthread_create(&id, NULL, amigaos4_start_child, (void *)&arg);
583 pseudo_children[findparent(arg.ca_parent)].ti_children++;
584
585 IExec->Wait(SIGBREAKF_CTRL_F);
586
587 PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */
588 if (handle)
589 {
590 errno = EAGAIN;
591 return -1;
592 }
593 return id;
a83a2cd1
AB
594}
595
596Pid_t amigaos_waitpid(pTHX_ int optype, Pid_t pid, void *argflags)
597{
6c47084d
JH
598 int result;
599 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
600 {
47718690 601 result = pthread_join(pid, (void **)argflags);
6c47084d
JH
602 }
603 else
604 {
47718690 605 while ((result = pthread_join(pid, (void **)argflags)) == -1 &&
6c47084d
JH
606 errno == EINTR)
607 {
608 // PERL_ASYNC_CHECK();
609 }
610 }
611 return result;
a83a2cd1
AB
612}
613
614void amigaos_fork_set_userdata(
615 pTHX_ struct UserData *userdata, I32 did_pipes, int pp, SV **sp, SV **mark)
616{
6c47084d
JH
617 userdata->parent = IExec->FindTask(0);
618 userdata->did_pipes = did_pipes;
619 userdata->pp = pp;
620 userdata->sp = sp;
621 userdata->mark = mark;
622 userdata->my_perl = aTHX;
a83a2cd1
AB
623}
624
738ab09f
AB
625/* AmigaOS specific versions of #?exec#? solely for use in amigaos_system_child
626 */
627
628static void S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
629{
6c47084d 630 const int e = errno;
738ab09f 631// PERL_ARGS_ASSERT_EXEC_FAILED;
6c47084d
JH
632 if (e)
633 {
634 if (ckWARN(WARN_EXEC))
635 Perl_warner(aTHX_ packWARN(WARN_EXEC),
636 "Can't exec \"%s\": %s", cmd, Strerror(e));
637 }
638 if (do_report)
639 {
640 /* XXX silently ignore failures */
641 PERL_UNUSED_RESULT(PerlLIO_write(fd, (void *)&e, sizeof(int)));
642 PerlLIO_close(fd);
643 }
738ab09f
AB
644}
645
646static I32 S_do_amigaos_exec3(pTHX_ const char *incmd, int fd, int do_report)
647{
282fc0b3 648 const char **argv, **a;
6c47084d
JH
649 char *s;
650 char *buf;
651 char *cmd;
652 /* Make a copy so we can change it */
653 const Size_t cmdlen = strlen(incmd) + 1;
654 I32 result = -1;
655
656 PERL_ARGS_ASSERT_DO_EXEC3;
657
282fc0b3 658 ENTER;
6c47084d 659 Newx(buf, cmdlen, char);
282fc0b3 660 SAVEFREEPV(buf);
6c47084d
JH
661 cmd = buf;
662 memcpy(cmd, incmd, cmdlen);
663
664 while (*cmd && isSPACE(*cmd))
665 cmd++;
666
667 /* see if there are shell metacharacters in it */
668
669 if (*cmd == '.' && isSPACE(cmd[1]))
670 goto doshell;
671
c8b388b0 672 if (strBEGINs(cmd, "exec") && isSPACE(cmd[4]))
6c47084d
JH
673 goto doshell;
674
675 s = cmd;
676 while (isWORDCHAR(*s))
677 s++; /* catch VAR=val gizmo */
678 if (*s == '=')
679 goto doshell;
680
681 for (s = cmd; *s; s++)
682 {
683 if (*s != ' ' && !isALPHA(*s) &&
4aada8b9 684 memCHRs("$&*(){}[]'\";\\|?<>~`\n", *s))
6c47084d
JH
685 {
686 if (*s == '\n' && !s[1])
687 {
688 *s = '\0';
689 break;
690 }
691 /* handle the 2>&1 construct at the end */
692 if (*s == '>' && s[1] == '&' && s[2] == '1' &&
693 s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2]) &&
694 (!s[3] || isSPACE(s[3])))
695 {
696 const char *t = s + 3;
697
698 while (*t && isSPACE(*t))
699 ++t;
700 if (!*t && (PerlLIO_dup2(1, 2) != -1))
701 {
702 s[-2] = '\0';
703 break;
704 }
705 }
706doshell:
707 PERL_FPU_PRE_EXEC
708 result = myexecl(FALSE, PL_sh_path, "sh", "-c", cmd,
709 (char *)NULL);
710 PERL_FPU_POST_EXEC
711 S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
712 amigaos_post_exec(fd, do_report);
282fc0b3 713 goto leave;
6c47084d
JH
714 }
715 }
716
282fc0b3
Z
717 Newx(argv, (s - cmd) / 2 + 2, const char *);
718 SAVEFREEPV(argv);
719 cmd = savepvn(cmd, s - cmd);
720 SAVEFREEPV(cmd);
721 a = argv;
722 for (s = cmd; *s;)
6c47084d
JH
723 {
724 while (isSPACE(*s))
725 s++;
726 if (*s)
727 *(a++) = s;
728 while (*s && !isSPACE(*s))
729 s++;
730 if (*s)
731 *s++ = '\0';
732 }
733 *a = NULL;
282fc0b3 734 if (argv[0])
6c47084d
JH
735 {
736 PERL_FPU_PRE_EXEC
282fc0b3 737 result = myexecvp(FALSE, argv[0], EXEC_ARGV_CAST(argv));
6c47084d 738 PERL_FPU_POST_EXEC
282fc0b3 739 if (errno == ENOEXEC) /* for system V NIH syndrome */
6c47084d 740 goto doshell;
282fc0b3 741 S_exec_failed(aTHX_ argv[0], fd, do_report);
6c47084d
JH
742 amigaos_post_exec(fd, do_report);
743 }
282fc0b3
Z
744leave:
745 LEAVE;
6c47084d 746 return result;
738ab09f
AB
747}
748
749I32 S_do_amigaos_aexec5(
750 pTHX_ SV *really, SV **mark, SV **sp, int fd, int do_report)
751{
738ab09f
AB
752 I32 result = -1;
753 PERL_ARGS_ASSERT_DO_AEXEC5;
282fc0b3 754 ENTER;
738ab09f
AB
755 if (sp > mark)
756 {
282fc0b3 757 const char **argv, **a;
738ab09f 758 const char *tmps = NULL;
282fc0b3
Z
759 Newx(argv, sp - mark + 1, const char *);
760 SAVEFREEPV(argv);
761 a = argv;
738ab09f
AB
762
763 while (++mark <= sp)
764 {
282fc0b3
Z
765 if (*mark) {
766 char *arg = savepv(SvPV_nolen_const(*mark));
767 SAVEFREEPV(arg);
768 *a++ = arg;
769 } else
738ab09f
AB
770 *a++ = "";
771 }
772 *a = NULL;
282fc0b3
Z
773 if (really) {
774 tmps = savepv(SvPV_nolen_const(really));
775 SAVEFREEPV(tmps);
776 }
777 if ((!really && *argv[0] != '/') ||
738ab09f
AB
778 (really && *tmps != '/')) /* will execvp use PATH? */
779 TAINT_ENV(); /* testing IFS here is overkill, probably
780 */
6c47084d
JH
781 PERL_FPU_PRE_EXEC
782 if (really && *tmps)
783 {
282fc0b3 784 result = myexecvp(FALSE, tmps, EXEC_ARGV_CAST(argv));
6c47084d
JH
785 }
786 else
787 {
282fc0b3 788 result = myexecvp(FALSE, argv[0], EXEC_ARGV_CAST(argv));
6c47084d
JH
789 }
790 PERL_FPU_POST_EXEC
282fc0b3 791 S_exec_failed(aTHX_(really ? tmps : argv[0]), fd, do_report);
6c47084d
JH
792 }
793 amigaos_post_exec(fd, do_report);
282fc0b3 794 LEAVE;
6c47084d 795 return result;
738ab09f
AB
796}
797
a83a2cd1
AB
798void *amigaos_system_child(void *userdata)
799{
6c47084d
JH
800 struct Task *parent;
801 I32 did_pipes;
802 int pp;
803 I32 value;
804 STRLEN n_a;
805 /* these next are declared by macros else where but I may be
806 * passing modified values here so declare them explictly but
807 * still referred to by macro below */
808
809 register SV **sp;
810 register SV **mark;
811 register PerlInterpreter *my_perl;
812
813 StdioStore store;
814
815 struct UserData *ud = (struct UserData *)userdata;
816
817 did_pipes = ud->did_pipes;
818 parent = ud->parent;
819 pp = ud->pp;
820 SP = ud->sp;
821 MARK = ud->mark;
822 my_perl = ud->my_perl;
823 PERL_SET_THX(my_perl);
824
825 amigaos_stdio_save(aTHX_ & store);
826
827 if (did_pipes)
828 {
829 // PerlLIO_close(pp[0]);
830 }
831 if (PL_op->op_flags & OPf_STACKED)
832 {
833 SV *really = *++MARK;
834 value = (I32)S_do_amigaos_aexec5(aTHX_ really, MARK, SP, pp,
835 did_pipes);
836 }
837 else if (SP - MARK != 1)
838 {
839 value = (I32)S_do_amigaos_aexec5(aTHX_ NULL, MARK, SP, pp,
840 did_pipes);
841 }
842 else
843 {
844 value = (I32)S_do_amigaos_exec3(
845 aTHX_ SvPVx(sv_mortalcopy(*SP), n_a), pp, did_pipes);
846 }
847
848 // Forbid();
849 // Signal(parent, SIGBREAKF_CTRL_F);
850
851 amigaos_stdio_restore(aTHX_ & store);
852
47718690 853 return (void *)value;
a83a2cd1 854}
738ab09f
AB
855
856static BOOL contains_whitespace(char *string)
857{
858
6c47084d
JH
859 if (string)
860 {
861
862 if (strchr(string, ' '))
863 return TRUE;
864 if (strchr(string, '\t'))
865 return TRUE;
866 if (strchr(string, '\n'))
867 return TRUE;
868 if (strchr(string, 0xA0))
869 return TRUE;
870 if (strchr(string, '"'))
871 return TRUE;
872 }
873 return FALSE;
738ab09f
AB
874}
875
876static int no_of_escapes(char *string)
877{
6c47084d
JH
878 int cnt = 0;
879 char *p;
880 for (p = string; p < string + strlen(string); p++)
881 {
882 if (*p == '"')
883 cnt++;
884 if (*p == '*')
885 cnt++;
886 if (*p == '\n')
887 cnt++;
888 if (*p == '\t')
889 cnt++;
890 }
891 return cnt;
738ab09f
AB
892}
893
894struct command_data
895{
6c47084d
JH
896 STRPTR args;
897 BPTR seglist;
898 struct Task *parent;
738ab09f
AB
899};
900
901#undef fopen
902#undef fgetc
903#undef fgets
904#undef fclose
905
906#define __USE_RUNCOMMAND__
907
908int myexecve(bool isperlthread,
909 const char *filename,
910 char *argv[],
911 char *envp[])
912{
6c47084d
JH
913 FILE *fh;
914 char buffer[1000];
915 int size = 0;
916 char **cur;
917 char *interpreter = 0;
918 char *interpreter_args = 0;
919 char *full = 0;
920 char *filename_conv = 0;
921 char *interpreter_conv = 0;
922 // char *tmp = 0;
923 char *fname;
924 // int tmpint;
925 // struct Task *thisTask = IExec->FindTask(0);
926 int result = -1;
927
928 StdioStore store;
929
930 pTHX = NULL;
931
932 if (isperlthread)
933 {
934 aTHX = PERL_GET_THX;
935 /* Save away our stdio */
936 amigaos_stdio_save(aTHX_ & store);
937 }
938
939 // adebug("%s %ld %s\n",__FUNCTION__,__LINE__,filename?filename:"NULL");
940
941 /* Calculate the size of filename and all args, including spaces and
942 * quotes */
943 size = 0; // strlen(filename) + 1;
944 for (cur = (char **)argv /* +1 */; *cur; cur++)
945 {
946 size +=
947 strlen(*cur) + 1 +
948 (contains_whitespace(*cur) ? (2 + no_of_escapes(*cur)) : 0);
949 }
950 /* Check if it's a script file */
6de23f80 951 IExec->DebugPrintF("%s %ld %08lx %c %c\n",__FILE__,__LINE__,filename,filename[0],filename[1]);
6c47084d
JH
952 fh = fopen(filename, "r");
953 if (fh)
954 {
955 if (fgetc(fh) == '#' && fgetc(fh) == '!')
956 {
957 char *p;
958 char *q;
959 fgets(buffer, 999, fh);
960 p = buffer;
961 while (*p == ' ' || *p == '\t')
962 p++;
963 if (buffer[strlen(buffer) - 1] == '\n')
964 buffer[strlen(buffer) - 1] = '\0';
965 if ((q = strchr(p, ' ')))
966 {
967 *q++ = '\0';
968 if (*q != '\0')
969 {
970 interpreter_args = mystrdup(q);
971 }
972 }
973 else
974 interpreter_args = mystrdup("");
975
976 interpreter = mystrdup(p);
977 size += strlen(interpreter) + 1;
978 size += strlen(interpreter_args) + 1;
979 }
980
981 fclose(fh);
982 }
983 else
984 {
985 /* We couldn't open this why not? */
986 if (errno == ENOENT)
987 {
988 /* file didn't exist! */
989 goto out;
990 }
991 }
992
993 /* Allocate the command line */
994 filename_conv = convert_path_u2a(filename);
995
996 if (filename_conv)
997 size += strlen(filename_conv);
998 size += 1;
47718690 999 full = (char *)IExec->AllocVecTags(size + 10, AVT_ClearWithValue, 0 ,TAG_DONE);
6c47084d
JH
1000 if (full)
1001 {
1002 if (interpreter)
1003 {
1004 interpreter_conv = convert_path_u2a(interpreter);
738ab09f
AB
1005#if !defined(__USE_RUNCOMMAND__)
1006#warning(using system!)
6c47084d
JH
1007 sprintf(full, "%s %s %s ", interpreter_conv,
1008 interpreter_args, filename_conv);
738ab09f 1009#else
6c47084d
JH
1010 sprintf(full, "%s %s ", interpreter_args,
1011 filename_conv);
738ab09f 1012#endif
6c47084d
JH
1013 IExec->FreeVec(interpreter);
1014 IExec->FreeVec(interpreter_args);
1015
1016 if (filename_conv)
1017 IExec->FreeVec(filename_conv);
1018 fname = mystrdup(interpreter_conv);
1019
1020 if (interpreter_conv)
1021 IExec->FreeVec(interpreter_conv);
1022 }
1023 else
1024 {
738ab09f 1025#ifndef __USE_RUNCOMMAND__
6c47084d 1026 sprintf(full, "%s ", filename_conv);
738ab09f 1027#else
6c47084d 1028 sprintf(full, "");
738ab09f 1029#endif
6c47084d
JH
1030 fname = mystrdup(filename_conv);
1031 if (filename_conv)
1032 IExec->FreeVec(filename_conv);
1033 }
1034
1035 for (cur = (char **)(argv + 1); *cur != 0; cur++)
1036 {
1037 if (contains_whitespace(*cur))
1038 {
1039 int esc = no_of_escapes(*cur);
1040
1041 if (esc > 0)
1042 {
47718690 1043 char *buff = (char *)IExec->AllocVecTags(
6c47084d 1044 strlen(*cur) + 4 + esc,
47718690
AB
1045 AVT_ClearWithValue,0,
1046 TAG_DONE);
6c47084d
JH
1047 char *p = *cur;
1048 char *q = buff;
1049
1050 *q++ = '"';
1051 while (*p != '\0')
1052 {
1053
1054 if (*p == '\n')
1055 {
1056 *q++ = '*';
1057 *q++ = 'N';
1058 p++;
1059 continue;
1060 }
1061 else if (*p == '"')
1062 {
1063 *q++ = '*';
1064 *q++ = '"';
1065 p++;
1066 continue;
1067 }
1068 else if (*p == '*')
1069 {
1070 *q++ = '*';
1071 }
1072 *q++ = *p++;
1073 }
1074 *q++ = '"';
1075 *q++ = ' ';
1076 *q = '\0';
1077 strcat(full, buff);
1078 IExec->FreeVec(buff);
1079 }
1080 else
1081 {
1082 strcat(full, "\"");
1083 strcat(full, *cur);
1084 strcat(full, "\" ");
1085 }
1086 }
1087 else
1088 {
1089 strcat(full, *cur);
1090 strcat(full, " ");
1091 }
1092 }
1093 strcat(full, "\n");
738ab09f
AB
1094
1095// if(envp)
1096// createvars(envp);
1097
1098#ifndef __USE_RUNCOMMAND__
6c47084d
JH
1099 result = IDOS->SystemTags(
1100 full, SYS_UserShell, TRUE, NP_StackSize,
1101 ((struct Process *)thisTask)->pr_StackSize, SYS_Input,
1102 ((struct Process *)thisTask)->pr_CIS, SYS_Output,
1103 ((struct Process *)thisTask)->pr_COS, SYS_Error,
1104 ((struct Process *)thisTask)->pr_CES, TAG_DONE);
738ab09f
AB
1105#else
1106
6c47084d
JH
1107 if (fname)
1108 {
1109 BPTR seglist = IDOS->LoadSeg(fname);
1110 if (seglist)
1111 {
1112 /* check if we have an executable! */
1113 struct PseudoSegList *ps = NULL;
1114 if (!IDOS->GetSegListInfoTags(
1115 seglist, GSLI_Native, &ps, TAG_DONE))
1116 {
1117 IDOS->GetSegListInfoTags(
1118 seglist, GSLI_68KPS, &ps, TAG_DONE);
1119 }
1120 if (ps != NULL)
1121 {
1122 // adebug("%s %ld %s
1123 // %s\n",__FUNCTION__,__LINE__,fname,full);
1124 IDOS->SetCliProgramName(fname);
1125 // result=RunCommand(seglist,8*1024,full,strlen(full));
1126 // result=myruncommand(seglist,8*1024,full,strlen(full),envp);
1127 result = myruncommand(seglist, 8 * 1024,
1128 full, -1, envp);
1129 errno = 0;
1130 }
1131 else
1132 {
1133 errno = ENOEXEC;
1134 }
1135 IDOS->UnLoadSeg(seglist);
1136 }
1137 else
1138 {
1139 errno = ENOEXEC;
1140 }
1141 IExec->FreeVec(fname);
1142 }
738ab09f
AB
1143
1144#endif /* USE_RUNCOMMAND */
1145
6c47084d
JH
1146 IExec->FreeVec(full);
1147 if (errno == ENOEXEC)
1148 {
1149 result = -1;
1150 }
1151 goto out;
1152 }
738ab09f 1153
6c47084d
JH
1154 if (interpreter)
1155 IExec->FreeVec(interpreter);
1156 if (filename_conv)
1157 IExec->FreeVec(filename_conv);
738ab09f 1158
6c47084d 1159 errno = ENOMEM;
738ab09f
AB
1160
1161out:
6c47084d
JH
1162 if (isperlthread)
1163 {
1164 amigaos_stdio_restore(aTHX_ & store);
1165 STATUS_NATIVE_CHILD_SET(result);
1166 PL_exit_flags |= PERL_EXIT_EXPECTED;
1167 if (result != -1)
1168 my_exit(result);
1169 }
1170 return (result);
738ab09f 1171}