1 /* amigaio.c mixes amigaos and perl APIs,
2 * as opposed to amigaos.c which is pure amigaos */
7 #include "amigaos4/amigaio.h"
17 #include <exec/semaphores.h>
18 #include <exec/exectags.h>
19 #include <proto/exec.h>
20 #include <proto/dos.h>
21 #include <proto/utility.h>
24 extern struct SignalSemaphore popen_sema;
25 extern unsigned int pipenum;
27 extern int32 myruncommand(BPTR seglist, int stack, char *command, int length, char **envp);
29 void amigaos_stdio_get(pTHX_ StdioStore *store)
32 amigaos_get_file(PerlIO_fileno(IoIFP(GvIO(PL_stdingv))));
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)))));
39 void amigaos_stdio_save(pTHX_ StdioStore *store)
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);
47 void amigaos_stdio_restore(pTHX_ const StdioStore *store)
49 IDOS->SelectInput(store->oldstdin);
50 IDOS->SelectErrorOutput(store->oldstderr);
51 IDOS->SelectOutput(store->oldstdout);
54 void amigaos_post_exec(int fd, int do_report)
56 /* We *must* write something to our pipe or else
57 * the other end hangs */
61 PerlLIO_write(fd, (void *)&e, sizeof(e));
73 static int popen_result = 0;
77 struct Task *thisTask = IExec->FindTask(0);
78 struct popen_data *pd = (struct popen_data *)thisTask->tc_UserData;
83 argv[2] = pd->command ? pd->command : NULL;
86 // adebug("%s %ld %s\n",__FUNCTION__,__LINE__,command?command:"NULL");
88 /* We need to give this to sh via execvp, execvp expects filename,
91 IExec->ObtainSemaphore(&popen_sema);
93 IExec->Signal(pd->parent,SIGBREAKF_CTRL_F);
95 popen_result = myexecvp(FALSE, argv[0], (char **)argv);
97 IExec->FreeVec(pd->command);
100 IExec->ReleaseSemaphore(&popen_sema);
106 PerlIO *Perl_my_popen(pTHX_ const char *cmd, const char *mode)
109 PERL_FLUSHALL_FOR_CHILD;
110 PerlIO *result = NULL;
116 struct Process *proc = NULL;
117 struct Task *thisTask = IExec->FindTask(0);
118 struct popen_data * pd = NULL;
120 /* First we need to check the mode
121 * We can only have unidirectional pipes
123 // adebug("%s %ld cmd %s mode %s \n",__FUNCTION__,__LINE__,cmd,
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.
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);
148 /* Now we open the AmigaOs Filehandles That we wil pass to our
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());
159 input = IDOS->Open("NIL:", MODE_READWRITE);
163 output = IDOS->Open(ami_pipe, MODE_NEWFILE);
165 result = PerlIO_open(unix_pipe, mode);
169 /* Open the write end first! */
171 result = PerlIO_open(unix_pipe, mode);
173 input = IDOS->Open(ami_pipe, MODE_OLDFILE);
176 output = IDOS->DupFileHandle(IDOS->Output());
179 output = IDOS->Open("NIL:", MODE_READWRITE);
183 if ((input == 0) || (output == 0) || (result == NULL))
185 /* Ouch stream opening failed */
193 PerlIO_close(result);
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.
206 if((pd = (struct popen_data*)IExec->AllocVecTags(sizeof(struct popen_data),AVT_Type,MEMF_SHARED,TAG_DONE)))
208 pd->parent = thisTask;
209 if ((pd->command = mystrdup(cmd)))
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,
224 /* wait for the child be setup right */
225 IExec->Wait(SIGBREAKF_CTRL_F);
229 /* New Process Failed to start
236 IExec->FreeVec(pd->command);
246 PerlIO_close(result);
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
259 Perl_my_pclose(pTHX_ PerlIO *ptr)
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 */
265 IExec->ObtainSemaphore(&popen_sema);
266 result = popen_result;
267 IExec->ReleaseSemaphore(&popen_sema);
274 /* An arbitrary number to start with, should work out what the real max should
278 # define MAX_THREADS 64
290 struct MsgPort *ti_port;
291 struct Process *ti_Process;
294 static struct thread_info pseudo_children[MAX_THREADS];
295 static int num_pseudo_children = 0;
296 static struct SignalSemaphore fork_array_sema;
298 void amigaos4_init_fork_array()
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);
307 void amigaos4_dispose_fork_array()
309 while (pseudo_children[0].ti_children > 0)
312 IExec->WaitPort(pseudo_children[0].ti_port);
313 msg = IExec->GetMsg(pseudo_children[0].ti_port);
315 IExec->FreeSysObject(ASOT_MESSAGE, msg);
316 pseudo_children[0].ti_children--;
318 IExec->FreeSysObject(ASOT_PORT, pseudo_children[0].ti_port);
321 struct thread_exit_message
323 struct Message tem_Message;
331 for (i = 0; i < MAX_THREADS; i++)
333 if (pseudo_children[i].ti_pid == 0)
339 int findparent(pthread_t pid)
342 for (i = 0; i < MAX_THREADS; i++)
344 if (pseudo_children[i].ti_pid == pid)
352 struct Task *ca_parent_task;
354 PerlInterpreter *ca_interp;
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 */
363 int amigaos_kill(Pid_t pid, int signal)
366 BOOL thistask = FALSE;
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++)
372 if (pseudo_children[i].ti_pid == pid)
374 realpid = (Pid_t)IDOS->GetPID(pseudo_children[i].ti_Process,GPID_PROCESS);
375 if(pseudo_children[i].ti_Process == (struct Process *)IExec->FindTask(NULL))
382 IExec->ReleaseSemaphore(&fork_array_sema);
383 /* Allow the C library to work out which signals are realy valid */
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);
391 return kill(realpid,signal);
395 static THREAD_RET_TYPE amigaos4_start_child(void *arg)
398 PerlInterpreter *my_perl =
399 (PerlInterpreter *)((struct child_arg *)arg)->ca_interp;
406 pthread_t pseudo_id = pthread_self();
408 #ifdef PERL_SYNC_FORK
409 static long sync_fork_id = 0;
410 long id = ++sync_fork_id;
413 /* before we do anything set up our process semaphore and add
414 a new entry to the pseudochildren */
416 /* get next available slot */
417 /* should not fail here! */
419 IExec->ObtainSemaphore(&fork_array_sema);
421 nextchild = getnextchild();
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);
430 num_pseudo_children++;
431 IExec->ReleaseSemaphore(&fork_array_sema);
433 /* We're set up let the parent continue */
435 IExec->Signal(((struct child_arg *)arg)->ca_parent_task,
438 PERL_SET_THX(my_perl);
439 if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
441 SV *sv = GvSV(tmpgv);
443 sv_setiv(sv, (IV)pseudo_id);
446 hv_clear(PL_pidstatus);
448 /* push a zero on the stack (we are the child) */
456 /* continue from next op */
457 PL_op = PL_op->op_next;
461 volatile int oldscope = PL_scopestack_ix;
472 while (PL_scopestack_ix > oldscope)
477 PL_curstash = PL_defstash;
478 if (PL_endav && !PL_minus_c)
479 call_list(oldscope, PL_endav);
480 status = STATUS_EXIT;
485 POPSTACK_TO(PL_mainstack);
486 PL_op = PL_restartop;
487 PL_restartop = (OP *)NULL;
491 PerlIO_printf(Perl_error_log, "panic: restartop\n");
498 /* XXX hack to avoid perl_destruct() freeing optree */
499 PL_main_root = (OP *)NULL;
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);
509 /* destroy everything (waits for any pseudo-forked children) */
511 /* wait for any remaining children */
513 while (pseudo_children[nextchild].ti_children > 0)
515 if (IExec->WaitPort(pseudo_children[nextchild].ti_port))
518 IExec->GetMsg(pseudo_children[nextchild].ti_port);
519 IExec->FreeSysObject(ASOT_MESSAGE, msg);
520 pseudo_children[nextchild].ti_children--;
523 if (PL_scopestack_ix <= 1)
525 perl_destruct(my_perl);
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;
536 IExec->ReleaseSemaphore(&fork_array_sema);
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),
547 sizeof(struct thread_exit_message));
550 tem->tem_pid = pseudo_id;
551 tem->tem_status = status;
552 IExec->PutMsg(pseudo_children[parent].ti_port,
553 (struct Message *)tem);
557 #ifdef PERL_SYNC_FORK
560 return (void *)status;
564 #endif /* USE_ITHREADS */
571 struct child_arg arg;
572 if (num_pseudo_children >= MAX_THREADS)
577 arg.ca_interp = perl_clone((PerlInterpreter *)aTHX, CLONEf_COPY_STACKS);
578 arg.ca_parent_task = IExec->FindTask(NULL);
580 pthread_self() ? pthread_self() : (pthread_t)IExec->FindTask(0);
582 handle = pthread_create(&id, NULL, amigaos4_start_child, (void *)&arg);
583 pseudo_children[findparent(arg.ca_parent)].ti_children++;
585 IExec->Wait(SIGBREAKF_CTRL_F);
587 PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */
596 Pid_t amigaos_waitpid(pTHX_ int optype, Pid_t pid, void *argflags)
599 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
601 result = pthread_join(pid, (void **)argflags);
605 while ((result = pthread_join(pid, (void **)argflags)) == -1 &&
608 // PERL_ASYNC_CHECK();
614 void amigaos_fork_set_userdata(
615 pTHX_ struct UserData *userdata, I32 did_pipes, int pp, SV **sp, SV **mark)
617 userdata->parent = IExec->FindTask(0);
618 userdata->did_pipes = did_pipes;
621 userdata->mark = mark;
622 userdata->my_perl = aTHX;
625 /* AmigaOS specific versions of #?exec#? solely for use in amigaos_system_child
628 static void S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
631 // PERL_ARGS_ASSERT_EXEC_FAILED;
634 if (ckWARN(WARN_EXEC))
635 Perl_warner(aTHX_ packWARN(WARN_EXEC),
636 "Can't exec \"%s\": %s", cmd, Strerror(e));
640 /* XXX silently ignore failures */
641 PERL_UNUSED_RESULT(PerlLIO_write(fd, (void *)&e, sizeof(int)));
646 static I32 S_do_amigaos_exec3(pTHX_ const char *incmd, int fd, int do_report)
649 const char **argv, **a;
653 /* Make a copy so we can change it */
654 const Size_t cmdlen = strlen(incmd) + 1;
657 PERL_ARGS_ASSERT_DO_EXEC3;
660 Newx(buf, cmdlen, char);
663 memcpy(cmd, incmd, cmdlen);
665 while (*cmd && isSPACE(*cmd))
668 /* see if there are shell metacharacters in it */
670 if (*cmd == '.' && isSPACE(cmd[1]))
673 if (strBEGINs(cmd, "exec") && isSPACE(cmd[4]))
677 while (isWORDCHAR(*s))
678 s++; /* catch VAR=val gizmo */
682 for (s = cmd; *s; s++)
684 if (*s != ' ' && !isALPHA(*s) &&
685 strchr("$&*(){}[]'\";\\|?<>~`\n", *s))
687 if (*s == '\n' && !s[1])
692 /* handle the 2>&1 construct at the end */
693 if (*s == '>' && s[1] == '&' && s[2] == '1' &&
694 s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2]) &&
695 (!s[3] || isSPACE(s[3])))
697 const char *t = s + 3;
699 while (*t && isSPACE(*t))
701 if (!*t && (PerlLIO_dup2(1, 2) != -1))
709 result = myexecl(FALSE, PL_sh_path, "sh", "-c", cmd,
712 S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
713 amigaos_post_exec(fd, do_report);
718 Newx(argv, (s - cmd) / 2 + 2, const char *);
720 cmd = savepvn(cmd, s - cmd);
729 while (*s && !isSPACE(*s))
738 result = myexecvp(FALSE, argv[0], EXEC_ARGV_CAST(argv));
740 if (errno == ENOEXEC) /* for system V NIH syndrome */
742 S_exec_failed(aTHX_ argv[0], fd, do_report);
743 amigaos_post_exec(fd, do_report);
750 I32 S_do_amigaos_aexec5(
751 pTHX_ SV *really, SV **mark, SV **sp, int fd, int do_report)
755 PERL_ARGS_ASSERT_DO_AEXEC5;
759 const char **argv, **a;
760 const char *tmps = NULL;
761 Newx(argv, sp - mark + 1, const char *);
768 char *arg = savepv(SvPV_nolen_const(*mark));
776 tmps = savepv(SvPV_nolen_const(really));
779 if ((!really && *argv[0] != '/') ||
780 (really && *tmps != '/')) /* will execvp use PATH? */
781 TAINT_ENV(); /* testing IFS here is overkill, probably
786 result = myexecvp(FALSE, tmps, EXEC_ARGV_CAST(argv));
790 result = myexecvp(FALSE, argv[0], EXEC_ARGV_CAST(argv));
793 S_exec_failed(aTHX_(really ? tmps : argv[0]), fd, do_report);
795 amigaos_post_exec(fd, do_report);
800 void *amigaos_system_child(void *userdata)
807 /* these next are declared by macros else where but I may be
808 * passing modified values here so declare them explictly but
809 * still referred to by macro below */
813 register PerlInterpreter *my_perl;
817 struct UserData *ud = (struct UserData *)userdata;
819 did_pipes = ud->did_pipes;
824 my_perl = ud->my_perl;
825 PERL_SET_THX(my_perl);
827 amigaos_stdio_save(aTHX_ & store);
831 // PerlLIO_close(pp[0]);
833 if (PL_op->op_flags & OPf_STACKED)
835 SV *really = *++MARK;
836 value = (I32)S_do_amigaos_aexec5(aTHX_ really, MARK, SP, pp,
839 else if (SP - MARK != 1)
841 value = (I32)S_do_amigaos_aexec5(aTHX_ NULL, MARK, SP, pp,
846 value = (I32)S_do_amigaos_exec3(
847 aTHX_ SvPVx(sv_mortalcopy(*SP), n_a), pp, did_pipes);
851 // Signal(parent, SIGBREAKF_CTRL_F);
853 amigaos_stdio_restore(aTHX_ & store);
855 return (void *)value;
858 static BOOL contains_whitespace(char *string)
864 if (strchr(string, ' '))
866 if (strchr(string, '\t'))
868 if (strchr(string, '\n'))
870 if (strchr(string, 0xA0))
872 if (strchr(string, '"'))
878 static int no_of_escapes(char *string)
882 for (p = string; p < string + strlen(string); p++)
908 #define __USE_RUNCOMMAND__
910 int myexecve(bool isperlthread,
911 const char *filename,
919 char *interpreter = 0;
920 char *interpreter_args = 0;
922 char *filename_conv = 0;
923 char *interpreter_conv = 0;
927 // struct Task *thisTask = IExec->FindTask(0);
937 /* Save away our stdio */
938 amigaos_stdio_save(aTHX_ & store);
941 // adebug("%s %ld %s\n",__FUNCTION__,__LINE__,filename?filename:"NULL");
943 /* Calculate the size of filename and all args, including spaces and
945 size = 0; // strlen(filename) + 1;
946 for (cur = (char **)argv /* +1 */; *cur; cur++)
950 (contains_whitespace(*cur) ? (2 + no_of_escapes(*cur)) : 0);
952 /* Check if it's a script file */
953 IExec->DebugPrintF("%s %ld %08lx %c %c\n",__FILE__,__LINE__,filename,filename[0],filename[1]);
954 fh = fopen(filename, "r");
957 if (fgetc(fh) == '#' && fgetc(fh) == '!')
961 fgets(buffer, 999, fh);
963 while (*p == ' ' || *p == '\t')
965 if (buffer[strlen(buffer) - 1] == '\n')
966 buffer[strlen(buffer) - 1] = '\0';
967 if ((q = strchr(p, ' ')))
972 interpreter_args = mystrdup(q);
976 interpreter_args = mystrdup("");
978 interpreter = mystrdup(p);
979 size += strlen(interpreter) + 1;
980 size += strlen(interpreter_args) + 1;
987 /* We couldn't open this why not? */
990 /* file didn't exist! */
995 /* Allocate the command line */
996 filename_conv = convert_path_u2a(filename);
999 size += strlen(filename_conv);
1001 full = (char *)IExec->AllocVecTags(size + 10, AVT_ClearWithValue, 0 ,TAG_DONE);
1006 interpreter_conv = convert_path_u2a(interpreter);
1007 #if !defined(__USE_RUNCOMMAND__)
1008 #warning(using system!)
1009 sprintf(full, "%s %s %s ", interpreter_conv,
1010 interpreter_args, filename_conv);
1012 sprintf(full, "%s %s ", interpreter_args,
1015 IExec->FreeVec(interpreter);
1016 IExec->FreeVec(interpreter_args);
1019 IExec->FreeVec(filename_conv);
1020 fname = mystrdup(interpreter_conv);
1022 if (interpreter_conv)
1023 IExec->FreeVec(interpreter_conv);
1027 #ifndef __USE_RUNCOMMAND__
1028 sprintf(full, "%s ", filename_conv);
1032 fname = mystrdup(filename_conv);
1034 IExec->FreeVec(filename_conv);
1037 for (cur = (char **)(argv + 1); *cur != 0; cur++)
1039 if (contains_whitespace(*cur))
1041 int esc = no_of_escapes(*cur);
1045 char *buff = (char *)IExec->AllocVecTags(
1046 strlen(*cur) + 4 + esc,
1047 AVT_ClearWithValue,0,
1080 IExec->FreeVec(buff);
1086 strcat(full, "\" ");
1098 // createvars(envp);
1100 #ifndef __USE_RUNCOMMAND__
1101 result = IDOS->SystemTags(
1102 full, SYS_UserShell, TRUE, NP_StackSize,
1103 ((struct Process *)thisTask)->pr_StackSize, SYS_Input,
1104 ((struct Process *)thisTask)->pr_CIS, SYS_Output,
1105 ((struct Process *)thisTask)->pr_COS, SYS_Error,
1106 ((struct Process *)thisTask)->pr_CES, TAG_DONE);
1111 BPTR seglist = IDOS->LoadSeg(fname);
1114 /* check if we have an executable! */
1115 struct PseudoSegList *ps = NULL;
1116 if (!IDOS->GetSegListInfoTags(
1117 seglist, GSLI_Native, &ps, TAG_DONE))
1119 IDOS->GetSegListInfoTags(
1120 seglist, GSLI_68KPS, &ps, TAG_DONE);
1124 // adebug("%s %ld %s
1125 // %s\n",__FUNCTION__,__LINE__,fname,full);
1126 IDOS->SetCliProgramName(fname);
1127 // result=RunCommand(seglist,8*1024,full,strlen(full));
1128 // result=myruncommand(seglist,8*1024,full,strlen(full),envp);
1129 result = myruncommand(seglist, 8 * 1024,
1137 IDOS->UnLoadSeg(seglist);
1143 IExec->FreeVec(fname);
1146 #endif /* USE_RUNCOMMAND */
1148 IExec->FreeVec(full);
1149 if (errno == ENOEXEC)
1157 IExec->FreeVec(interpreter);
1159 IExec->FreeVec(filename_conv);
1166 amigaos_stdio_restore(aTHX_ & store);
1167 STATUS_NATIVE_CHILD_SET(result);
1168 PL_exit_flags |= PERL_EXIT_EXPECTED;