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 memCHRs("$&*(){}[]'\";\\|?<>~`\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 } 1174