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 <stdio.h> |
16 |
|
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> |
22 |
#include <dos/dos.h> |
23 |
|
24 |
extern struct SignalSemaphore popen_sema; |
25 |
extern unsigned int pipenum; |
26 |
|
27 |
extern int32 myruncommand(BPTR seglist, int stack, char *command, int length, char **envp); |
28 |
|
29 |
void amigaos_stdio_get(pTHX_ StdioStore *store) |
30 |
{ |
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))))); |
37 |
} |
38 |
|
39 |
void amigaos_stdio_save(pTHX_ StdioStore *store) |
40 |
{ |
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); |
45 |
} |
46 |
|
47 |
void amigaos_stdio_restore(pTHX_ const StdioStore *store) |
48 |
{ |
49 |
IDOS->SelectInput(store->oldstdin); |
50 |
IDOS->SelectErrorOutput(store->oldstderr); |
51 |
IDOS->SelectOutput(store->oldstdout); |
52 |
} |
53 |
|
54 |
void amigaos_post_exec(int fd, int do_report) |
55 |
{ |
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 |
} |
64 |
} |
65 |
|
66 |
|
67 |
struct popen_data |
68 |
{ |
69 |
struct Task *parent; |
70 |
STRPTR command; |
71 |
}; |
72 |
|
73 |
static int popen_result = 0; |
74 |
|
75 |
int 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 |
|
106 |
PerlIO *Perl_my_popen(pTHX_ const char *cmd, const char *mode) |
107 |
{ |
108 |
|
109 |
PERL_FLUSHALL_FOR_CHILD; |
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; |
256 |
} |
257 |
|
258 |
I32 |
259 |
Perl_my_pclose(pTHX_ PerlIO *ptr) |
260 |
{ |
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); |
268 |
return result; |
269 |
} |
270 |
|
271 |
|
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 |
|
285 |
struct thread_info |
286 |
{ |
287 |
pthread_t ti_pid; |
288 |
int ti_children; |
289 |
pthread_t ti_parent; |
290 |
struct MsgPort *ti_port; |
291 |
struct Process *ti_Process; |
292 |
}; |
293 |
|
294 |
static struct thread_info pseudo_children[MAX_THREADS]; |
295 |
static int num_pseudo_children = 0; |
296 |
static struct SignalSemaphore fork_array_sema; |
297 |
|
298 |
void amigaos4_init_fork_array() |
299 |
{ |
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); |
305 |
} |
306 |
|
307 |
void amigaos4_dispose_fork_array() |
308 |
{ |
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); |
319 |
} |
320 |
|
321 |
struct thread_exit_message |
322 |
{ |
323 |
struct Message tem_Message; |
324 |
pthread_t tem_pid; |
325 |
int tem_status; |
326 |
}; |
327 |
|
328 |
int getnextchild() |
329 |
{ |
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; |
337 |
} |
338 |
|
339 |
int findparent(pthread_t pid) |
340 |
{ |
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; |
348 |
} |
349 |
|
350 |
struct child_arg |
351 |
{ |
352 |
struct Task *ca_parent_task; |
353 |
pthread_t ca_parent; |
354 |
PerlInterpreter *ca_interp; |
355 |
}; |
356 |
|
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 |
|
363 |
int amigaos_kill(Pid_t pid, int signal) |
364 |
{ |
365 |
int i; |
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++) |
371 |
{ |
372 |
if (pseudo_children[i].ti_pid == pid) |
373 |
{ |
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)) |
376 |
{ |
377 |
thistask = TRUE; |
378 |
} |
379 |
break; |
380 |
} |
381 |
} |
382 |
IExec->ReleaseSemaphore(&fork_array_sema); |
383 |
/* Allow the C library to work out which signals are realy valid */ |
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 |
} |
393 |
} |
394 |
|
395 |
static THREAD_RET_TYPE amigaos4_start_child(void *arg) |
396 |
{ |
397 |
|
398 |
PerlInterpreter *my_perl = |
399 |
(PerlInterpreter *)((struct child_arg *)arg)->ca_interp; |
400 |
; |
401 |
|
402 |
GV *tmpgv; |
403 |
int status; |
404 |
int parent; |
405 |
int nextchild; |
406 |
pthread_t pseudo_id = pthread_self(); |
407 |
|
408 |
#ifdef PERL_SYNC_FORK |
409 |
static long sync_fork_id = 0; |
410 |
long id = ++sync_fork_id; |
411 |
#endif |
412 |
|
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 |
|
463 |
restart: |
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 |
} |
557 |
#ifdef PERL_SYNC_FORK |
558 |
return id; |
559 |
#else |
560 |
return (void *)status; |
561 |
#endif |
562 |
} |
563 |
|
564 |
#endif /* USE_ITHREADS */ |
565 |
|
566 |
Pid_t amigaos_fork() |
567 |
{ |
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; |
594 |
} |
595 |
|
596 |
Pid_t amigaos_waitpid(pTHX_ int optype, Pid_t pid, void *argflags) |
597 |
{ |
598 |
int result; |
599 |
if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) |
600 |
{ |
601 |
result = pthread_join(pid, (void **)argflags); |
602 |
} |
603 |
else |
604 |
{ |
605 |
while ((result = pthread_join(pid, (void **)argflags)) == -1 && |
606 |
errno == EINTR) |
607 |
{ |
608 |
// PERL_ASYNC_CHECK(); |
609 |
} |
610 |
} |
611 |
return result; |
612 |
} |
613 |
|
614 |
void amigaos_fork_set_userdata( |
615 |
pTHX_ struct UserData *userdata, I32 did_pipes, int pp, SV **sp, SV **mark) |
616 |
{ |
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; |
623 |
} |
624 |
|
625 |
/* AmigaOS specific versions of #?exec#? solely for use in amigaos_system_child |
626 |
*/ |
627 |
|
628 |
static void S_exec_failed(pTHX_ const char *cmd, int fd, int do_report) |
629 |
{ |
630 |
const int e = errno; |
631 |
// PERL_ARGS_ASSERT_EXEC_FAILED; |
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 |
} |
644 |
} |
645 |
|
646 |
static I32 S_do_amigaos_exec3(pTHX_ const char *incmd, int fd, int do_report) |
647 |
{ |
648 |
dVAR; |
649 |
const char **argv, **a; |
650 |
char *s; |
651 |
char *buf; |
652 |
char *cmd; |
653 |
/* Make a copy so we can change it */ |
654 |
const Size_t cmdlen = strlen(incmd) + 1; |
655 |
I32 result = -1; |
656 |
|
657 |
PERL_ARGS_ASSERT_DO_EXEC3; |
658 |
|
659 |
ENTER; |
660 |
Newx(buf, cmdlen, char); |
661 |
SAVEFREEPV(buf); |
662 |
cmd = buf; |
663 |
memcpy(cmd, incmd, cmdlen); |
664 |
|
665 |
while (*cmd && isSPACE(*cmd)) |
666 |
cmd++; |
667 |
|
668 |
/* see if there are shell metacharacters in it */ |
669 |
|
670 |
if (*cmd == '.' && isSPACE(cmd[1])) |
671 |
goto doshell; |
672 |
|
673 |
if (strBEGINs(cmd, "exec") && isSPACE(cmd[4])) |
674 |
goto doshell; |
675 |
|
676 |
s = cmd; |
677 |
while (isWORDCHAR(*s)) |
678 |
s++; /* catch VAR=val gizmo */ |
679 |
if (*s == '=') |
680 |
goto doshell; |
681 |
|
682 |
for (s = cmd; *s; s++) |
683 |
{ |
684 |
if (*s != ' ' && !isALPHA(*s) && |
685 |
strchr("$&*(){}[]'\";\\|?<>~`\n", *s)) |
686 |
{ |
687 |
if (*s == '\n' && !s[1]) |
688 |
{ |
689 |
*s = '\0'; |
690 |
break; |
691 |
} |
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]))) |
696 |
{ |
697 |
const char *t = s + 3; |
698 |
|
699 |
while (*t && isSPACE(*t)) |
700 |
++t; |
701 |
if (!*t && (PerlLIO_dup2(1, 2) != -1)) |
702 |
{ |
703 |
s[-2] = '\0'; |
704 |
break; |
705 |
} |
706 |
} |
707 |
doshell: |
708 |
PERL_FPU_PRE_EXEC |
709 |
result = myexecl(FALSE, PL_sh_path, "sh", "-c", cmd, |
710 |
(char *)NULL); |
711 |
PERL_FPU_POST_EXEC |
712 |
S_exec_failed(aTHX_ PL_sh_path, fd, do_report); |
713 |
amigaos_post_exec(fd, do_report); |
714 |
goto leave; |
715 |
} |
716 |
} |
717 |
|
718 |
Newx(argv, (s - cmd) / 2 + 2, const char *); |
719 |
SAVEFREEPV(argv); |
720 |
cmd = savepvn(cmd, s - cmd); |
721 |
SAVEFREEPV(cmd); |
722 |
a = argv; |
723 |
for (s = cmd; *s;) |
724 |
{ |
725 |
while (isSPACE(*s)) |
726 |
s++; |
727 |
if (*s) |
728 |
*(a++) = s; |
729 |
while (*s && !isSPACE(*s)) |
730 |
s++; |
731 |
if (*s) |
732 |
*s++ = '\0'; |
733 |
} |
734 |
*a = NULL; |
735 |
if (argv[0]) |
736 |
{ |
737 |
PERL_FPU_PRE_EXEC |
738 |
result = myexecvp(FALSE, argv[0], EXEC_ARGV_CAST(argv)); |
739 |
PERL_FPU_POST_EXEC |
740 |
if (errno == ENOEXEC) /* for system V NIH syndrome */ |
741 |
goto doshell; |
742 |
S_exec_failed(aTHX_ argv[0], fd, do_report); |
743 |
amigaos_post_exec(fd, do_report); |
744 |
} |
745 |
leave: |
746 |
LEAVE; |
747 |
return result; |
748 |
} |
749 |
|
750 |
I32 S_do_amigaos_aexec5( |
751 |
pTHX_ SV *really, SV **mark, SV **sp, int fd, int do_report) |
752 |
{ |
753 |
dVAR; |
754 |
I32 result = -1; |
755 |
PERL_ARGS_ASSERT_DO_AEXEC5; |
756 |
ENTER; |
757 |
if (sp > mark) |
758 |
{ |
759 |
const char **argv, **a; |
760 |
const char *tmps = NULL; |
761 |
Newx(argv, sp - mark + 1, const char *); |
762 |
SAVEFREEPV(argv); |
763 |
a = argv; |
764 |
|
765 |
while (++mark <= sp) |
766 |
{ |
767 |
if (*mark) { |
768 |
char *arg = savepv(SvPV_nolen_const(*mark)); |
769 |
SAVEFREEPV(arg); |
770 |
*a++ = arg; |
771 |
} else |
772 |
*a++ = ""; |
773 |
} |
774 |
*a = NULL; |
775 |
if (really) { |
776 |
tmps = savepv(SvPV_nolen_const(really)); |
777 |
SAVEFREEPV(tmps); |
778 |
} |
779 |
if ((!really && *argv[0] != '/') || |
780 |
(really && *tmps != '/')) /* will execvp use PATH? */ |
781 |
TAINT_ENV(); /* testing IFS here is overkill, probably |
782 |
*/ |
783 |
PERL_FPU_PRE_EXEC |
784 |
if (really && *tmps) |
785 |
{ |
786 |
result = myexecvp(FALSE, tmps, EXEC_ARGV_CAST(argv)); |
787 |
} |
788 |
else |
789 |
{ |
790 |
result = myexecvp(FALSE, argv[0], EXEC_ARGV_CAST(argv)); |
791 |
} |
792 |
PERL_FPU_POST_EXEC |
793 |
S_exec_failed(aTHX_(really ? tmps : argv[0]), fd, do_report); |
794 |
} |
795 |
amigaos_post_exec(fd, do_report); |
796 |
LEAVE; |
797 |
return result; |
798 |
} |
799 |
|
800 |
void *amigaos_system_child(void *userdata) |
801 |
{ |
802 |
struct Task *parent; |
803 |
I32 did_pipes; |
804 |
int pp; |
805 |
I32 value; |
806 |
STRLEN n_a; |
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 */ |
810 |
|
811 |
register SV **sp; |
812 |
register SV **mark; |
813 |
register PerlInterpreter *my_perl; |
814 |
|
815 |
StdioStore store; |
816 |
|
817 |
struct UserData *ud = (struct UserData *)userdata; |
818 |
|
819 |
did_pipes = ud->did_pipes; |
820 |
parent = ud->parent; |
821 |
pp = ud->pp; |
822 |
SP = ud->sp; |
823 |
MARK = ud->mark; |
824 |
my_perl = ud->my_perl; |
825 |
PERL_SET_THX(my_perl); |
826 |
|
827 |
amigaos_stdio_save(aTHX_ & store); |
828 |
|
829 |
if (did_pipes) |
830 |
{ |
831 |
// PerlLIO_close(pp[0]); |
832 |
} |
833 |
if (PL_op->op_flags & OPf_STACKED) |
834 |
{ |
835 |
SV *really = *++MARK; |
836 |
value = (I32)S_do_amigaos_aexec5(aTHX_ really, MARK, SP, pp, |
837 |
did_pipes); |
838 |
} |
839 |
else if (SP - MARK != 1) |
840 |
{ |
841 |
value = (I32)S_do_amigaos_aexec5(aTHX_ NULL, MARK, SP, pp, |
842 |
did_pipes); |
843 |
} |
844 |
else |
845 |
{ |
846 |
value = (I32)S_do_amigaos_exec3( |
847 |
aTHX_ SvPVx(sv_mortalcopy(*SP), n_a), pp, did_pipes); |
848 |
} |
849 |
|
850 |
// Forbid(); |
851 |
// Signal(parent, SIGBREAKF_CTRL_F); |
852 |
|
853 |
amigaos_stdio_restore(aTHX_ & store); |
854 |
|
855 |
return (void *)value; |
856 |
} |
857 |
|
858 |
static BOOL contains_whitespace(char *string) |
859 |
{ |
860 |
|
861 |
if (string) |
862 |
{ |
863 |
|
864 |
if (strchr(string, ' ')) |
865 |
return TRUE; |
866 |
if (strchr(string, '\t')) |
867 |
return TRUE; |
868 |
if (strchr(string, '\n')) |
869 |
return TRUE; |
870 |
if (strchr(string, 0xA0)) |
871 |
return TRUE; |
872 |
if (strchr(string, '"')) |
873 |
return TRUE; |
874 |
} |
875 |
return FALSE; |
876 |
} |
877 |
|
878 |
static int no_of_escapes(char *string) |
879 |
{ |
880 |
int cnt = 0; |
881 |
char *p; |
882 |
for (p = string; p < string + strlen(string); p++) |
883 |
{ |
884 |
if (*p == '"') |
885 |
cnt++; |
886 |
if (*p == '*') |
887 |
cnt++; |
888 |
if (*p == '\n') |
889 |
cnt++; |
890 |
if (*p == '\t') |
891 |
cnt++; |
892 |
} |
893 |
return cnt; |
894 |
} |
895 |
|
896 |
struct command_data |
897 |
{ |
898 |
STRPTR args; |
899 |
BPTR seglist; |
900 |
struct Task *parent; |
901 |
}; |
902 |
|
903 |
#undef fopen |
904 |
#undef fgetc |
905 |
#undef fgets |
906 |
#undef fclose |
907 |
|
908 |
#define __USE_RUNCOMMAND__ |
909 |
|
910 |
int myexecve(bool isperlthread, |
911 |
const char *filename, |
912 |
char *argv[], |
913 |
char *envp[]) |
914 |
{ |
915 |
FILE *fh; |
916 |
char buffer[1000]; |
917 |
int size = 0; |
918 |
char **cur; |
919 |
char *interpreter = 0; |
920 |
char *interpreter_args = 0; |
921 |
char *full = 0; |
922 |
char *filename_conv = 0; |
923 |
char *interpreter_conv = 0; |
924 |
// char *tmp = 0; |
925 |
char *fname; |
926 |
// int tmpint; |
927 |
// struct Task *thisTask = IExec->FindTask(0); |
928 |
int result = -1; |
929 |
|
930 |
StdioStore store; |
931 |
|
932 |
pTHX = NULL; |
933 |
|
934 |
if (isperlthread) |
935 |
{ |
936 |
aTHX = PERL_GET_THX; |
937 |
/* Save away our stdio */ |
938 |
amigaos_stdio_save(aTHX_ & store); |
939 |
} |
940 |
|
941 |
// adebug("%s %ld %s\n",__FUNCTION__,__LINE__,filename?filename:"NULL"); |
942 |
|
943 |
/* Calculate the size of filename and all args, including spaces and |
944 |
* quotes */ |
945 |
size = 0; // strlen(filename) + 1; |
946 |
for (cur = (char **)argv /* +1 */; *cur; cur++) |
947 |
{ |
948 |
size += |
949 |
strlen(*cur) + 1 + |
950 |
(contains_whitespace(*cur) ? (2 + no_of_escapes(*cur)) : 0); |
951 |
} |
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"); |
955 |
if (fh) |
956 |
{ |
957 |
if (fgetc(fh) == '#' && fgetc(fh) == '!') |
958 |
{ |
959 |
char *p; |
960 |
char *q; |
961 |
fgets(buffer, 999, fh); |
962 |
p = buffer; |
963 |
while (*p == ' ' || *p == '\t') |
964 |
p++; |
965 |
if (buffer[strlen(buffer) - 1] == '\n') |
966 |
buffer[strlen(buffer) - 1] = '\0'; |
967 |
if ((q = strchr(p, ' '))) |
968 |
{ |
969 |
*q++ = '\0'; |
970 |
if (*q != '\0') |
971 |
{ |
972 |
interpreter_args = mystrdup(q); |
973 |
} |
974 |
} |
975 |
else |
976 |
interpreter_args = mystrdup(""); |
977 |
|
978 |
interpreter = mystrdup(p); |
979 |
size += strlen(interpreter) + 1; |
980 |
size += strlen(interpreter_args) + 1; |
981 |
} |
982 |
|
983 |
fclose(fh); |
984 |
} |
985 |
else |
986 |
{ |
987 |
/* We couldn't open this why not? */ |
988 |
if (errno == ENOENT) |
989 |
{ |
990 |
/* file didn't exist! */ |
991 |
goto out; |
992 |
} |
993 |
} |
994 |
|
995 |
/* Allocate the command line */ |
996 |
filename_conv = convert_path_u2a(filename); |
997 |
|
998 |
if (filename_conv) |
999 |
size += strlen(filename_conv); |
1000 |
size += 1; |
1001 |
full = (char *)IExec->AllocVecTags(size + 10, AVT_ClearWithValue, 0 ,TAG_DONE); |
1002 |
if (full) |
1003 |
{ |
1004 |
if (interpreter) |
1005 |
{ |
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); |
1011 |
#else |
1012 |
sprintf(full, "%s %s ", interpreter_args, |
1013 |
filename_conv); |
1014 |
#endif |
1015 |
IExec->FreeVec(interpreter); |
1016 |
IExec->FreeVec(interpreter_args); |
1017 |
|
1018 |
if (filename_conv) |
1019 |
IExec->FreeVec(filename_conv); |
1020 |
fname = mystrdup(interpreter_conv); |
1021 |
|
1022 |
if (interpreter_conv) |
1023 |
IExec->FreeVec(interpreter_conv); |
1024 |
} |
1025 |
else |
1026 |
{ |
1027 |
#ifndef __USE_RUNCOMMAND__ |
1028 |
sprintf(full, "%s ", filename_conv); |
1029 |
#else |
1030 |
sprintf(full, ""); |
1031 |
#endif |
1032 |
fname = mystrdup(filename_conv); |
1033 |
if (filename_conv) |
1034 |
IExec->FreeVec(filename_conv); |
1035 |
} |
1036 |
|
1037 |
for (cur = (char **)(argv + 1); *cur != 0; cur++) |
1038 |
{ |
1039 |
if (contains_whitespace(*cur)) |
1040 |
{ |
1041 |
int esc = no_of_escapes(*cur); |
1042 |
|
1043 |
if (esc > 0) |
1044 |
{ |
1045 |
char *buff = (char *)IExec->AllocVecTags( |
1046 |
strlen(*cur) + 4 + esc, |
1047 |
AVT_ClearWithValue,0, |
1048 |
TAG_DONE); |
1049 |
char *p = *cur; |
1050 |
char *q = buff; |
1051 |
|
1052 |
*q++ = '"'; |
1053 |
while (*p != '\0') |
1054 |
{ |
1055 |
|
1056 |
if (*p == '\n') |
1057 |
{ |
1058 |
*q++ = '*'; |
1059 |
*q++ = 'N'; |
1060 |
p++; |
1061 |
continue; |
1062 |
} |
1063 |
else if (*p == '"') |
1064 |
{ |
1065 |
*q++ = '*'; |
1066 |
*q++ = '"'; |
1067 |
p++; |
1068 |
continue; |
1069 |
} |
1070 |
else if (*p == '*') |
1071 |
{ |
1072 |
*q++ = '*'; |
1073 |
} |
1074 |
*q++ = *p++; |
1075 |
} |
1076 |
*q++ = '"'; |
1077 |
*q++ = ' '; |
1078 |
*q = '\0'; |
1079 |
strcat(full, buff); |
1080 |
IExec->FreeVec(buff); |
1081 |
} |
1082 |
else |
1083 |
{ |
1084 |
strcat(full, "\""); |
1085 |
strcat(full, *cur); |
1086 |
strcat(full, "\" "); |
1087 |
} |
1088 |
} |
1089 |
else |
1090 |
{ |
1091 |
strcat(full, *cur); |
1092 |
strcat(full, " "); |
1093 |
} |
1094 |
} |
1095 |
strcat(full, "\n"); |
1096 |
|
1097 |
// if(envp) |
1098 |
// createvars(envp); |
1099 |
|
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); |
1107 |
#else |
1108 |
|
1109 |
if (fname) |
1110 |
{ |
1111 |
BPTR seglist = IDOS->LoadSeg(fname); |
1112 |
if (seglist) |
1113 |
{ |
1114 |
/* check if we have an executable! */ |
1115 |
struct PseudoSegList *ps = NULL; |
1116 |
if (!IDOS->GetSegListInfoTags( |
1117 |
seglist, GSLI_Native, &ps, TAG_DONE)) |
1118 |
{ |
1119 |
IDOS->GetSegListInfoTags( |
1120 |
seglist, GSLI_68KPS, &ps, TAG_DONE); |
1121 |
} |
1122 |
if (ps != NULL) |
1123 |
{ |
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, |
1130 |
full, -1, envp); |
1131 |
errno = 0; |
1132 |
} |
1133 |
else |
1134 |
{ |
1135 |
errno = ENOEXEC; |
1136 |
} |
1137 |
IDOS->UnLoadSeg(seglist); |
1138 |
} |
1139 |
else |
1140 |
{ |
1141 |
errno = ENOEXEC; |
1142 |
} |
1143 |
IExec->FreeVec(fname); |
1144 |
} |
1145 |
|
1146 |
#endif /* USE_RUNCOMMAND */ |
1147 |
|
1148 |
IExec->FreeVec(full); |
1149 |
if (errno == ENOEXEC) |
1150 |
{ |
1151 |
result = -1; |
1152 |
} |
1153 |
goto out; |
1154 |
} |
1155 |
|
1156 |
if (interpreter) |
1157 |
IExec->FreeVec(interpreter); |
1158 |
if (filename_conv) |
1159 |
IExec->FreeVec(filename_conv); |
1160 |
|
1161 |
errno = ENOMEM; |
1162 |
|
1163 |
out: |
1164 |
if (isperlthread) |
1165 |
{ |
1166 |
amigaos_stdio_restore(aTHX_ & store); |
1167 |
STATUS_NATIVE_CHILD_SET(result); |
1168 |
PL_exit_flags |= PERL_EXIT_EXPECTED; |
1169 |
if (result != -1) |
1170 |
my_exit(result); |
1171 |
} |
1172 |
return (result); |
1173 |
} |