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