/* amigaio.c mixes amigaos and perl APIs, * as opposed to amigaos.c which is pure amigaos */ #include "EXTERN.h" #include "perl.h" #include "amigaos4/amigaio.h" #include "amigaos.h" #ifdef WORD # undef WORD # define WORD int16 #endif #include #include #include #include #include #include void amigaos_stdio_get(pTHX_ StdioStore *store) { store->astdin = amigaos_get_file(PerlIO_fileno(IoIFP(GvIO(PL_stdingv)))); store->astderr = amigaos_get_file(PerlIO_fileno(IoIFP(GvIO(PL_stderrgv)))); store->astdout = amigaos_get_file( PerlIO_fileno(IoIFP(GvIO(gv_fetchpv("STDOUT", TRUE, SVt_PVIO))))); } void amigaos_stdio_save(pTHX_ StdioStore *store) { amigaos_stdio_get(aTHX_ store); store->oldstdin = IDOS->SelectInput(store->astdin); store->oldstderr = IDOS->SelectErrorOutput(store->astderr); store->oldstdout = IDOS->SelectOutput(store->astdout); } void amigaos_stdio_restore(pTHX_ const StdioStore *store) { IDOS->SelectInput(store->oldstdin); IDOS->SelectErrorOutput(store->oldstderr); IDOS->SelectOutput(store->oldstdout); } void amigaos_post_exec(int fd, int do_report) { /* We *must* write something to our pipe or else * the other end hangs */ if (do_report) { int e = errno; PerlLIO_write(fd, (void *)&e, sizeof(e)); PerlLIO_close(fd); } } PerlIO *Perl_my_popen(pTHX_ const char *cmd, const char *mode) { PERL_FLUSHALL_FOR_CHILD; /* Call system's popen() to get a FILE *, then import it. * used 0 for 2nd parameter to PerlIO_importFILE; * apparently not used */ // FILE *f=amigaos_popen(cmd,mode); // fprintf(stderr,"popen returned %d\n",f); return PerlIO_importFILE(amigaos_popen(cmd, mode), 0); // return PerlIO_importFILE(f, 0); } #ifdef USE_ITHREADS /* An arbitrary number to start with, should work out what the real max should * be */ #ifndef MAX_THREADS # define MAX_THREADS 64 #endif #define REAPED 0 #define ACTIVE 1 #define EXITED -1 struct thread_info { pthread_t ti_pid; int ti_children; pthread_t ti_parent; struct MsgPort *ti_port; struct Process *ti_Process; }; static struct thread_info pseudo_children[MAX_THREADS]; static int num_pseudo_children = 0; static struct SignalSemaphore fork_array_sema; void amigaos4_init_fork_array() { IExec->InitSemaphore(&fork_array_sema); pseudo_children[0].ti_pid = (pthread_t)IExec->FindTask(0); pseudo_children[0].ti_parent = -1; pseudo_children[0].ti_port = (struct MsgPort *)IExec->AllocSysObjectTags(ASOT_PORT, TAG_DONE); } void amigaos4_dispose_fork_array() { while (pseudo_children[0].ti_children > 0) { void *msg; IExec->WaitPort(pseudo_children[0].ti_port); msg = IExec->GetMsg(pseudo_children[0].ti_port); if (msg) IExec->FreeSysObject(ASOT_MESSAGE, msg); pseudo_children[0].ti_children--; } IExec->FreeSysObject(ASOT_PORT, pseudo_children[0].ti_port); } struct thread_exit_message { struct Message tem_Message; pthread_t tem_pid; int tem_status; }; int getnextchild() { int i; for (i = 0; i < MAX_THREADS; i++) { if (pseudo_children[i].ti_pid == 0) return i; } return -1; } int findparent(pthread_t pid) { int i; for (i = 0; i < MAX_THREADS; i++) { if (pseudo_children[i].ti_pid == pid) return i; } return -1; } struct child_arg { struct Task *ca_parent_task; pthread_t ca_parent; PerlInterpreter *ca_interp; }; #undef kill /* FIXME: Is here's a chance, albeit it small of a clash between our pseudo pid */ /* derived from the pthread API and the dos.library pid that newlib kill uses? */ /* clib2 used the Process address so there was no issue */ int amigaos_kill(Pid_t pid, int signal) { int i; Pid_t realpid = pid; // Perhaps we have a real pid from else where? /* Look for our DOS pid */ IExec->ObtainSemaphore(&fork_array_sema); for (i = 0; i < MAX_THREADS; i++) { if (pseudo_children[i].ti_pid == pid) { realpid = (Pid_t)IDOS->GetPID(pseudo_children[i].ti_Process,GPID_PROCESS); break; } } IExec->ReleaseSemaphore(&fork_array_sema); /* Allow the C library to work out which signals are realy valid */ return kill(realpid,signal); } static THREAD_RET_TYPE amigaos4_start_child(void *arg) { PerlInterpreter *my_perl = (PerlInterpreter *)((struct child_arg *)arg)->ca_interp; ; GV *tmpgv; int status; int parent; int nextchild; pthread_t pseudo_id = pthread_self(); #ifdef PERL_SYNC_FORK static long sync_fork_id = 0; long id = ++sync_fork_id; #endif /* before we do anything set up our process semaphore and add a new entry to the pseudochildren */ /* get next available slot */ /* should not fail here! */ IExec->ObtainSemaphore(&fork_array_sema); nextchild = getnextchild(); pseudo_children[nextchild].ti_pid = pseudo_id; pseudo_children[nextchild].ti_Process = (struct Process *)IExec->FindTask(NULL); pseudo_children[nextchild].ti_parent = ((struct child_arg *)arg)->ca_parent; pseudo_children[nextchild].ti_port = (struct MsgPort *)IExec->AllocSysObjectTags(ASOT_PORT, TAG_DONE); num_pseudo_children++; IExec->ReleaseSemaphore(&fork_array_sema); /* We're set up let the parent continue */ IExec->Signal(((struct child_arg *)arg)->ca_parent_task, SIGBREAKF_CTRL_F); PERL_SET_THX(my_perl); if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) { SV *sv = GvSV(tmpgv); SvREADONLY_off(sv); sv_setiv(sv, (IV)pseudo_id); SvREADONLY_on(sv); } hv_clear(PL_pidstatus); /* push a zero on the stack (we are the child) */ { dSP; dTARGET; PUSHi(0); PUTBACK; } /* continue from next op */ PL_op = PL_op->op_next; { dJMPENV; volatile int oldscope = PL_scopestack_ix; restart: JMPENV_PUSH(status); switch (status) { case 0: CALLRUNOPS(aTHX); status = 0; break; case 2: while (PL_scopestack_ix > oldscope) { LEAVE; } FREETMPS; PL_curstash = PL_defstash; if (PL_endav && !PL_minus_c) call_list(oldscope, PL_endav); status = STATUS_EXIT; break; case 3: if (PL_restartop) { POPSTACK_TO(PL_mainstack); PL_op = PL_restartop; PL_restartop = (OP *)NULL; ; goto restart; } PerlIO_printf(Perl_error_log, "panic: restartop\n"); FREETMPS; status = 1; break; } JMPENV_POP; /* XXX hack to avoid perl_destruct() freeing optree */ PL_main_root = (OP *)NULL; } { do_close(PL_stdingv, FALSE); do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO), FALSE); /* PL_stdoutgv - ISAGN */ do_close(PL_stderrgv, FALSE); } /* destroy everything (waits for any pseudo-forked children) */ /* wait for any remaining children */ while (pseudo_children[nextchild].ti_children > 0) { if (IExec->WaitPort(pseudo_children[nextchild].ti_port)) { void *msg = IExec->GetMsg(pseudo_children[nextchild].ti_port); IExec->FreeSysObject(ASOT_MESSAGE, msg); pseudo_children[nextchild].ti_children--; } } if (PL_scopestack_ix <= 1) { perl_destruct(my_perl); } perl_free(my_perl); IExec->ObtainSemaphore(&fork_array_sema); parent = findparent(pseudo_children[nextchild].ti_parent); pseudo_children[nextchild].ti_pid = 0; pseudo_children[nextchild].ti_parent = 0; IExec->FreeSysObject(ASOT_PORT, pseudo_children[nextchild].ti_port); pseudo_children[nextchild].ti_port = NULL; IExec->ReleaseSemaphore(&fork_array_sema); { if (parent >= 0) { struct thread_exit_message *tem = (struct thread_exit_message *) IExec->AllocSysObjectTags( ASOT_MESSAGE, ASOMSG_Size, sizeof(struct thread_exit_message), ASOMSG_Length, sizeof(struct thread_exit_message)); if (tem) { tem->tem_pid = pseudo_id; tem->tem_status = status; IExec->PutMsg(pseudo_children[parent].ti_port, (struct Message *)tem); } } } #ifdef PERL_SYNC_FORK return id; #else return (void *)status; #endif } #endif /* USE_ITHREADS */ Pid_t amigaos_fork() { dTHX; pthread_t id; int handle; struct child_arg arg; if (num_pseudo_children >= MAX_THREADS) { errno = EAGAIN; return -1; } arg.ca_interp = perl_clone((PerlInterpreter *)aTHX, CLONEf_COPY_STACKS); arg.ca_parent_task = IExec->FindTask(NULL); arg.ca_parent = pthread_self() ? pthread_self() : (pthread_t)IExec->FindTask(0); handle = pthread_create(&id, NULL, amigaos4_start_child, (void *)&arg); pseudo_children[findparent(arg.ca_parent)].ti_children++; IExec->Wait(SIGBREAKF_CTRL_F); PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */ if (handle) { errno = EAGAIN; return -1; } return id; } Pid_t amigaos_waitpid(pTHX_ int optype, Pid_t pid, void *argflags) { int result; if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { result = pthread_join(pid, argflags); } else { while ((result = pthread_join(pid, argflags)) == -1 && errno == EINTR) { // PERL_ASYNC_CHECK(); } } return result; } void amigaos_fork_set_userdata( pTHX_ struct UserData *userdata, I32 did_pipes, int pp, SV **sp, SV **mark) { userdata->parent = IExec->FindTask(0); userdata->did_pipes = did_pipes; userdata->pp = pp; userdata->sp = sp; userdata->mark = mark; userdata->my_perl = aTHX; } /* AmigaOS specific versions of #?exec#? solely for use in amigaos_system_child */ static void S_exec_failed(pTHX_ const char *cmd, int fd, int do_report) { const int e = errno; // PERL_ARGS_ASSERT_EXEC_FAILED; if (e) { if (ckWARN(WARN_EXEC)) Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s", cmd, Strerror(e)); } if (do_report) { /* XXX silently ignore failures */ PERL_UNUSED_RESULT(PerlLIO_write(fd, (void *)&e, sizeof(int))); PerlLIO_close(fd); } } static I32 S_do_amigaos_exec3(pTHX_ const char *incmd, int fd, int do_report) { dVAR; const char **a; char *s; char *buf; char *cmd; /* Make a copy so we can change it */ const Size_t cmdlen = strlen(incmd) + 1; I32 result = -1; PERL_ARGS_ASSERT_DO_EXEC3; Newx(buf, cmdlen, char); cmd = buf; memcpy(cmd, incmd, cmdlen); while (*cmd && isSPACE(*cmd)) cmd++; /* see if there are shell metacharacters in it */ if (*cmd == '.' && isSPACE(cmd[1])) goto doshell; if (strnEQ(cmd, "exec", 4) && isSPACE(cmd[4])) goto doshell; s = cmd; while (isWORDCHAR(*s)) s++; /* catch VAR=val gizmo */ if (*s == '=') goto doshell; for (s = cmd; *s; s++) { if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n", *s)) { if (*s == '\n' && !s[1]) { *s = '\0'; break; } /* handle the 2>&1 construct at the end */ if (*s == '>' && s[1] == '&' && s[2] == '1' && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2]) && (!s[3] || isSPACE(s[3]))) { const char *t = s + 3; while (*t && isSPACE(*t)) ++t; if (!*t && (PerlLIO_dup2(1, 2) != -1)) { s[-2] = '\0'; break; } } doshell: PERL_FPU_PRE_EXEC result = myexecl(FALSE, PL_sh_path, "sh", "-c", cmd, (char *)NULL); PERL_FPU_POST_EXEC S_exec_failed(aTHX_ PL_sh_path, fd, do_report); amigaos_post_exec(fd, do_report); Safefree(buf); return result; } } Newx(PL_Argv, (s - cmd) / 2 + 2, const char *); PL_Cmd = savepvn(cmd, s - cmd); a = PL_Argv; for (s = PL_Cmd; *s;) { while (isSPACE(*s)) s++; if (*s) *(a++) = s; while (*s && !isSPACE(*s)) s++; if (*s) *s++ = '\0'; } *a = NULL; if (PL_Argv[0]) { PERL_FPU_PRE_EXEC result = myexecvp(FALSE, PL_Argv[0], EXEC_ARGV_CAST(PL_Argv)); PERL_FPU_POST_EXEC if (errno == ENOEXEC) { /* for system V NIH syndrome */ do_execfree(); goto doshell; } S_exec_failed(aTHX_ PL_Argv[0], fd, do_report); amigaos_post_exec(fd, do_report); } do_execfree(); Safefree(buf); return result; } I32 S_do_amigaos_aexec5( pTHX_ SV *really, SV **mark, SV **sp, int fd, int do_report) { dVAR; I32 result = -1; PERL_ARGS_ASSERT_DO_AEXEC5; if (sp > mark) { const char **a; const char *tmps = NULL; Newx(PL_Argv, sp - mark + 1, const char *); a = PL_Argv; while (++mark <= sp) { if (*mark) *a++ = SvPV_nolen_const(*mark); else *a++ = ""; } *a = NULL; if (really) tmps = SvPV_nolen_const(really); if ((!really && *PL_Argv[0] != '/') || (really && *tmps != '/')) /* will execvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ PERL_FPU_PRE_EXEC if (really && *tmps) { result = myexecvp(FALSE, tmps, EXEC_ARGV_CAST(PL_Argv)); } else { result = myexecvp(FALSE, PL_Argv[0], EXEC_ARGV_CAST(PL_Argv)); } PERL_FPU_POST_EXEC S_exec_failed(aTHX_(really ? tmps : PL_Argv[0]), fd, do_report); } amigaos_post_exec(fd, do_report); do_execfree(); return result; } void *amigaos_system_child(void *userdata) { struct Task *parent; I32 did_pipes; int pp; I32 value; STRLEN n_a; /* these next are declared by macros else where but I may be * passing modified values here so declare them explictly but * still referred to by macro below */ register SV **sp; register SV **mark; register PerlInterpreter *my_perl; StdioStore store; struct UserData *ud = (struct UserData *)userdata; did_pipes = ud->did_pipes; parent = ud->parent; pp = ud->pp; SP = ud->sp; MARK = ud->mark; my_perl = ud->my_perl; PERL_SET_THX(my_perl); amigaos_stdio_save(aTHX_ & store); if (did_pipes) { // PerlLIO_close(pp[0]); } if (PL_op->op_flags & OPf_STACKED) { SV *really = *++MARK; value = (I32)S_do_amigaos_aexec5(aTHX_ really, MARK, SP, pp, did_pipes); } else if (SP - MARK != 1) { value = (I32)S_do_amigaos_aexec5(aTHX_ NULL, MARK, SP, pp, did_pipes); } else { value = (I32)S_do_amigaos_exec3( aTHX_ SvPVx(sv_mortalcopy(*SP), n_a), pp, did_pipes); } // Forbid(); // Signal(parent, SIGBREAKF_CTRL_F); amigaos_stdio_restore(aTHX_ & store); return value; } static BOOL contains_whitespace(char *string) { if (string) { if (strchr(string, ' ')) return TRUE; if (strchr(string, '\t')) return TRUE; if (strchr(string, '\n')) return TRUE; if (strchr(string, 0xA0)) return TRUE; if (strchr(string, '"')) return TRUE; } return FALSE; } static int no_of_escapes(char *string) { int cnt = 0; char *p; for (p = string; p < string + strlen(string); p++) { if (*p == '"') cnt++; if (*p == '*') cnt++; if (*p == '\n') cnt++; if (*p == '\t') cnt++; } return cnt; } struct command_data { STRPTR args; BPTR seglist; struct Task *parent; }; #undef fopen #undef fgetc #undef fgets #undef fclose #define __USE_RUNCOMMAND__ int myexecve(bool isperlthread, const char *filename, char *argv[], char *envp[]) { FILE *fh; char buffer[1000]; int size = 0; char **cur; char *interpreter = 0; char *interpreter_args = 0; char *full = 0; char *filename_conv = 0; char *interpreter_conv = 0; // char *tmp = 0; char *fname; // int tmpint; // struct Task *thisTask = IExec->FindTask(0); int result = -1; StdioStore store; pTHX = NULL; if (isperlthread) { aTHX = PERL_GET_THX; /* Save away our stdio */ amigaos_stdio_save(aTHX_ & store); } // adebug("%s %ld %s\n",__FUNCTION__,__LINE__,filename?filename:"NULL"); /* Calculate the size of filename and all args, including spaces and * quotes */ size = 0; // strlen(filename) + 1; for (cur = (char **)argv /* +1 */; *cur; cur++) { size += strlen(*cur) + 1 + (contains_whitespace(*cur) ? (2 + no_of_escapes(*cur)) : 0); } /* Check if it's a script file */ fh = fopen(filename, "r"); if (fh) { if (fgetc(fh) == '#' && fgetc(fh) == '!') { char *p; char *q; fgets(buffer, 999, fh); p = buffer; while (*p == ' ' || *p == '\t') p++; if (buffer[strlen(buffer) - 1] == '\n') buffer[strlen(buffer) - 1] = '\0'; if ((q = strchr(p, ' '))) { *q++ = '\0'; if (*q != '\0') { interpreter_args = mystrdup(q); } } else interpreter_args = mystrdup(""); interpreter = mystrdup(p); size += strlen(interpreter) + 1; size += strlen(interpreter_args) + 1; } fclose(fh); } else { /* We couldn't open this why not? */ if (errno == ENOENT) { /* file didn't exist! */ goto out; } } /* Allocate the command line */ filename_conv = convert_path_u2a(filename); if (filename_conv) size += strlen(filename_conv); size += 1; full = (char *)IExec->AllocVec(size + 10, MEMF_ANY | MEMF_CLEAR); if (full) { if (interpreter) { interpreter_conv = convert_path_u2a(interpreter); #if !defined(__USE_RUNCOMMAND__) #warning(using system!) sprintf(full, "%s %s %s ", interpreter_conv, interpreter_args, filename_conv); #else sprintf(full, "%s %s ", interpreter_args, filename_conv); #endif IExec->FreeVec(interpreter); IExec->FreeVec(interpreter_args); if (filename_conv) IExec->FreeVec(filename_conv); fname = mystrdup(interpreter_conv); if (interpreter_conv) IExec->FreeVec(interpreter_conv); } else { #ifndef __USE_RUNCOMMAND__ sprintf(full, "%s ", filename_conv); #else sprintf(full, ""); #endif fname = mystrdup(filename_conv); if (filename_conv) IExec->FreeVec(filename_conv); } for (cur = (char **)(argv + 1); *cur != 0; cur++) { if (contains_whitespace(*cur)) { int esc = no_of_escapes(*cur); if (esc > 0) { char *buff = IExec->AllocVec( strlen(*cur) + 4 + esc, MEMF_ANY | MEMF_CLEAR); char *p = *cur; char *q = buff; *q++ = '"'; while (*p != '\0') { if (*p == '\n') { *q++ = '*'; *q++ = 'N'; p++; continue; } else if (*p == '"') { *q++ = '*'; *q++ = '"'; p++; continue; } else if (*p == '*') { *q++ = '*'; } *q++ = *p++; } *q++ = '"'; *q++ = ' '; *q = '\0'; strcat(full, buff); IExec->FreeVec(buff); } else { strcat(full, "\""); strcat(full, *cur); strcat(full, "\" "); } } else { strcat(full, *cur); strcat(full, " "); } } strcat(full, "\n"); // if(envp) // createvars(envp); #ifndef __USE_RUNCOMMAND__ result = IDOS->SystemTags( full, SYS_UserShell, TRUE, NP_StackSize, ((struct Process *)thisTask)->pr_StackSize, SYS_Input, ((struct Process *)thisTask)->pr_CIS, SYS_Output, ((struct Process *)thisTask)->pr_COS, SYS_Error, ((struct Process *)thisTask)->pr_CES, TAG_DONE); #else if (fname) { BPTR seglist = IDOS->LoadSeg(fname); if (seglist) { /* check if we have an executable! */ struct PseudoSegList *ps = NULL; if (!IDOS->GetSegListInfoTags( seglist, GSLI_Native, &ps, TAG_DONE)) { IDOS->GetSegListInfoTags( seglist, GSLI_68KPS, &ps, TAG_DONE); } if (ps != NULL) { // adebug("%s %ld %s // %s\n",__FUNCTION__,__LINE__,fname,full); IDOS->SetCliProgramName(fname); // result=RunCommand(seglist,8*1024,full,strlen(full)); // result=myruncommand(seglist,8*1024,full,strlen(full),envp); result = myruncommand(seglist, 8 * 1024, full, -1, envp); errno = 0; } else { errno = ENOEXEC; } IDOS->UnLoadSeg(seglist); } else { errno = ENOEXEC; } IExec->FreeVec(fname); } #endif /* USE_RUNCOMMAND */ IExec->FreeVec(full); if (errno == ENOEXEC) { result = -1; } goto out; } if (interpreter) IExec->FreeVec(interpreter); if (filename_conv) IExec->FreeVec(filename_conv); errno = ENOMEM; out: if (isperlthread) { amigaos_stdio_restore(aTHX_ & store); STATUS_NATIVE_CHILD_SET(result); PL_exit_flags |= PERL_EXIT_EXPECTED; if (result != -1) my_exit(result); } return (result); }