amigaos4/amigaio.c

   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 }