1 #define INCL_DOS 2 #define INCL_NOPM 3 #define INCL_DOSFILEMGR 4 #define INCL_DOSMEMMGR 5 #define INCL_DOSERRORS 6 #include <os2.h> 7 8 #include <sys/uflags.h> 9 10 /* 11 * Various Unix compatibility functions for OS/2 12 */ 13 14 #include <stdio.h> 15 #include <errno.h> 16 #include <limits.h> 17 #include <process.h> 18 #include <fcntl.h> 19 20 #include "EXTERN.h" 21 #include "perl.h" 22 23 #ifdef USE_THREADS 24 25 typedef void (*emx_startroutine)(void *); 26 typedef void* (*pthreads_startroutine)(void *); 27 28 enum pthreads_state { 29 pthreads_st_none = 0, 30 pthreads_st_run, 31 pthreads_st_exited, 32 pthreads_st_detached, 33 pthreads_st_waited, 34 }; 35 const char *pthreads_states[] = { 36 "uninit", 37 "running", 38 "exited", 39 "detached", 40 "waited for", 41 }; 42 43 typedef struct { 44 void *status; 45 perl_cond cond; 46 enum pthreads_state state; 47 } thread_join_t; 48 49 thread_join_t *thread_join_data; 50 int thread_join_count; 51 perl_mutex start_thread_mutex; 52 53 int 54 pthread_join(perl_os_thread tid, void **status) 55 { 56 MUTEX_LOCK(&start_thread_mutex); 57 switch (thread_join_data[tid].state) { 58 case pthreads_st_exited: 59 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */ 60 MUTEX_UNLOCK(&start_thread_mutex); 61 *status = thread_join_data[tid].status; 62 break; 63 case pthreads_st_waited: 64 MUTEX_UNLOCK(&start_thread_mutex); 65 croak("join with a thread with a waiter"); 66 break; 67 case pthreads_st_run: 68 thread_join_data[tid].state = pthreads_st_waited; 69 COND_INIT(&thread_join_data[tid].cond); 70 MUTEX_UNLOCK(&start_thread_mutex); 71 COND_WAIT(&thread_join_data[tid].cond, NULL); 72 COND_DESTROY(&thread_join_data[tid].cond); 73 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */ 74 *status = thread_join_data[tid].status; 75 break; 76 default: 77 MUTEX_UNLOCK(&start_thread_mutex); 78 croak("join: unknown thread state: '%s'", 79 pthreads_states[thread_join_data[tid].state]); 80 break; 81 } 82 return 0; 83 } 84 85 void 86 pthread_startit(void *arg) 87 { 88 /* Thread is already started, we need to transfer control only */ 89 pthreads_startroutine start_routine = *((pthreads_startroutine*)arg); 90 int tid = pthread_self(); 91 void *retval; 92 93 arg = ((void**)arg)[1]; 94 if (tid >= thread_join_count) { 95 int oc = thread_join_count; 96 97 thread_join_count = tid + 5 + tid/5; 98 if (thread_join_data) { 99 Renew(thread_join_data, thread_join_count, thread_join_t); 100 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t); 101 } else { 102 Newz(1323, thread_join_data, thread_join_count, thread_join_t); 103 } 104 } 105 if (thread_join_data[tid].state != pthreads_st_none) 106 croak("attempt to reuse thread id %i", tid); 107 thread_join_data[tid].state = pthreads_st_run; 108 /* Now that we copied/updated the guys, we may release the caller... */ 109 MUTEX_UNLOCK(&start_thread_mutex); 110 thread_join_data[tid].status = (*start_routine)(arg); 111 switch (thread_join_data[tid].state) { 112 case pthreads_st_waited: 113 COND_SIGNAL(&thread_join_data[tid].cond); 114 break; 115 default: 116 thread_join_data[tid].state = pthreads_st_exited; 117 break; 118 } 119 } 120 121 int 122 pthread_create(perl_os_thread *tid, const pthread_attr_t *attr, 123 void *(*start_routine)(void*), void *arg) 124 { 125 void *args[2]; 126 127 args[0] = (void*)start_routine; 128 args[1] = arg; 129 130 MUTEX_LOCK(&start_thread_mutex); 131 *tid = _beginthread(pthread_startit, /*stack*/ NULL, 132 /*stacksize*/ 10*1024*1024, (void*)args); 133 MUTEX_LOCK(&start_thread_mutex); 134 MUTEX_UNLOCK(&start_thread_mutex); 135 return *tid ? 0 : EINVAL; 136 } 137 138 int 139 pthread_detach(perl_os_thread tid) 140 { 141 MUTEX_LOCK(&start_thread_mutex); 142 switch (thread_join_data[tid].state) { 143 case pthreads_st_waited: 144 MUTEX_UNLOCK(&start_thread_mutex); 145 croak("detach on a thread with a waiter"); 146 break; 147 case pthreads_st_run: 148 thread_join_data[tid].state = pthreads_st_detached; 149 MUTEX_UNLOCK(&start_thread_mutex); 150 break; 151 default: 152 MUTEX_UNLOCK(&start_thread_mutex); 153 croak("detach: unknown thread state: '%s'", 154 pthreads_states[thread_join_data[tid].state]); 155 break; 156 } 157 return 0; 158 } 159 160 /* This is a very bastardized version: */ 161 int 162 os2_cond_wait(perl_cond *c, perl_mutex *m) 163 { 164 int rc; 165 STRLEN n_a; 166 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET)) 167 croak("panic: COND_WAIT-reset: rc=%i", rc); 168 if (m) MUTEX_UNLOCK(m); 169 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT)) 170 && (rc != ERROR_INTERRUPT)) 171 croak("panic: COND_WAIT: rc=%i", rc); 172 if (rc == ERROR_INTERRUPT) 173 errno = EINTR; 174 if (m) MUTEX_LOCK(m); 175 } 176 #endif 177 178 /*****************************************************************************/ 179 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */ 180 static PFN ExtFCN[2]; /* Labeled by ord below. */ 181 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */ 182 #define ORD_QUERY_ELP 0 183 #define ORD_SET_ELP 1 184 185 APIRET 186 loadByOrd(ULONG ord) 187 { 188 if (ExtFCN[ord] == NULL) { 189 static HMODULE hdosc = 0; 190 BYTE buf[20]; 191 PFN fcn; 192 APIRET rc; 193 194 if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf, 195 "doscalls", &hdosc))) 196 || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn))) 197 die("This version of OS/2 does not support doscalls.%i", 198 loadOrd[ord]); 199 ExtFCN[ord] = fcn; 200 } 201 if ((long)ExtFCN[ord] == -1) die("panic queryaddr"); 202 } 203 204 /* priorities */ 205 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, 206 self inverse. */ 207 #define QSS_INI_BUFFER 1024 208 209 PQTOPLEVEL 210 get_sysinfo(ULONG pid, ULONG flags) 211 { 212 char *pbuffer; 213 ULONG rc, buf_len = QSS_INI_BUFFER; 214 215 New(1322, pbuffer, buf_len, char); 216 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */ 217 rc = QuerySysState(flags, pid, pbuffer, buf_len); 218 while (rc == ERROR_BUFFER_OVERFLOW) { 219 Renew(pbuffer, buf_len *= 2, char); 220 rc = QuerySysState(flags, pid, pbuffer, buf_len); 221 } 222 if (rc) { 223 FillOSError(rc); 224 Safefree(pbuffer); 225 return 0; 226 } 227 return (PQTOPLEVEL)pbuffer; 228 } 229 230 #define PRIO_ERR 0x1111 231 232 static ULONG 233 sys_prio(pid) 234 { 235 ULONG prio; 236 PQTOPLEVEL psi; 237 238 psi = get_sysinfo(pid, QSS_PROCESS); 239 if (!psi) { 240 return PRIO_ERR; 241 } 242 if (pid != psi->procdata->pid) { 243 Safefree(psi); 244 croak("panic: wrong pid in sysinfo"); 245 } 246 prio = psi->procdata->threads->priority; 247 Safefree(psi); 248 return prio; 249 } 250 251 int 252 setpriority(int which, int pid, int val) 253 { 254 ULONG rc, prio; 255 PQTOPLEVEL psi; 256 257 prio = sys_prio(pid); 258 259 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ 260 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) { 261 /* Do not change class. */ 262 return CheckOSError(DosSetPriority((pid < 0) 263 ? PRTYS_PROCESSTREE : PRTYS_PROCESS, 264 0, 265 (32 - val) % 32 - (prio & 0xFF), 266 abs(pid))) 267 ? -1 : 0; 268 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ { 269 /* Documentation claims one can change both class and basevalue, 270 * but I find it wrong. */ 271 /* Change class, but since delta == 0 denotes absolute 0, correct. */ 272 if (CheckOSError(DosSetPriority((pid < 0) 273 ? PRTYS_PROCESSTREE : PRTYS_PROCESS, 274 priors[(32 - val) >> 5] + 1, 275 0, 276 abs(pid)))) 277 return -1; 278 if ( ((32 - val) % 32) == 0 ) return 0; 279 return CheckOSError(DosSetPriority((pid < 0) 280 ? PRTYS_PROCESSTREE : PRTYS_PROCESS, 281 0, 282 (32 - val) % 32, 283 abs(pid))) 284 ? -1 : 0; 285 } 286 /* else return CheckOSError(DosSetPriority((pid < 0) */ 287 /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */ 288 /* priors[(32 - val) >> 5] + 1, */ 289 /* (32 - val) % 32 - (prio & 0xFF), */ 290 /* abs(pid))) */ 291 /* ? -1 : 0; */ 292 } 293 294 int 295 getpriority(int which /* ignored */, int pid) 296 { 297 TIB *tib; 298 PIB *pib; 299 ULONG rc, ret; 300 301 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ 302 /* DosGetInfoBlocks has old priority! */ 303 /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */ 304 /* if (pid != pib->pib_ulpid) { */ 305 ret = sys_prio(pid); 306 if (ret == PRIO_ERR) { 307 return -1; 308 } 309 /* } else */ 310 /* ret = tib->tib_ptib2->tib2_ulpri; */ 311 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF); 312 } 313 314 /*****************************************************************************/ 315 /* spawn */ 316 317 /* There is no big sense to make it thread-specific, since signals 318 are delivered to thread 1 only. XXXX Maybe make it into an array? */ 319 static int spawn_pid; 320 static int spawn_killed; 321 322 static Signal_t 323 spawn_sighandler(int sig) 324 { 325 /* Some programs do not arrange for the keyboard signals to be 326 delivered to them. We need to deliver the signal manually. */ 327 /* We may get a signal only if 328 a) kid does not receive keyboard signal: deliver it; 329 b) kid already died, and we get a signal. We may only hope 330 that the pid number was not reused. 331 */ 332 333 if (spawn_killed) 334 sig = SIGKILL; /* Try harder. */ 335 kill(spawn_pid, sig); 336 spawn_killed = 1; 337 } 338 339 static int 340 result(int flag, int pid) 341 { 342 int r, status; 343 Signal_t (*ihand)(); /* place to save signal during system() */ 344 Signal_t (*qhand)(); /* place to save signal during system() */ 345 #ifndef __EMX__ 346 RESULTCODES res; 347 int rpid; 348 #endif 349 350 if (pid < 0 || flag != 0) 351 return pid; 352 353 #ifdef __EMX__ 354 spawn_pid = pid; 355 spawn_killed = 0; 356 ihand = rsignal(SIGINT, &spawn_sighandler); 357 qhand = rsignal(SIGQUIT, &spawn_sighandler); 358 do { 359 r = wait4pid(pid, &status, 0); 360 } while (r == -1 && errno == EINTR); 361 rsignal(SIGINT, ihand); 362 rsignal(SIGQUIT, qhand); 363 364 PL_statusvalue = (U16)status; 365 if (r < 0) 366 return -1; 367 return status & 0xFFFF; 368 #else 369 ihand = rsignal(SIGINT, SIG_IGN); 370 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid); 371 rsignal(SIGINT, ihand); 372 PL_statusvalue = res.codeResult << 8 | res.codeTerminate; 373 if (r) 374 return -1; 375 return PL_statusvalue; 376 #endif 377 } 378 379 #define EXECF_SPAWN 0 380 #define EXECF_EXEC 1 381 #define EXECF_TRUEEXEC 2 382 #define EXECF_SPAWN_NOWAIT 3 383 384 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */ 385 386 static int 387 my_type() 388 { 389 int rc; 390 TIB *tib; 391 PIB *pib; 392 393 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */ 394 if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) 395 return -1; 396 397 return (pib->pib_ultype); 398 } 399 400 static ULONG 401 file_type(char *path) 402 { 403 int rc; 404 ULONG apptype; 405 406 if (!(_emx_env & 0x200)) 407 croak("file_type not implemented on DOS"); /* not OS/2. */ 408 if (CheckOSError(DosQueryAppType(path, &apptype))) { 409 switch (rc) { 410 case ERROR_FILE_NOT_FOUND: 411 case ERROR_PATH_NOT_FOUND: 412 return -1; 413 case ERROR_ACCESS_DENIED: /* Directory with this name found? */ 414 return -3; 415 default: /* Found, but not an 416 executable, or some other 417 read error. */ 418 return -2; 419 } 420 } 421 return apptype; 422 } 423 424 static ULONG os2_mytype; 425 426 /* Spawn/exec a program, revert to shell if needed. */ 427 /* global PL_Argv[] contains arguments. */ 428 429 int 430 do_spawn_ve(really, flag, execf, inicmd) 431 SV *really; 432 U32 flag; 433 U32 execf; 434 char *inicmd; 435 { 436 dTHR; 437 int trueflag = flag; 438 int rc, pass = 1; 439 char *tmps; 440 char buf[256], *s = 0, scrbuf[280]; 441 char *args[4]; 442 static char * fargs[4] 443 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", }; 444 char **argsp = fargs; 445 char nargs = 4; 446 int force_shell; 447 STRLEN n_a; 448 449 if (flag == P_WAIT) 450 flag = P_NOWAIT; 451 452 retry: 453 if (strEQ(PL_Argv[0],"/bin/sh")) 454 PL_Argv[0] = PL_sh_path; 455 456 if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\' 457 && !(PL_Argv[0][0] && PL_Argv[0][1] == ':' 458 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\')) 459 ) /* will spawnvp use PATH? */ 460 TAINT_ENV(); /* testing IFS here is overkill, probably */ 461 /* We should check PERL_SH* and PERLLIB_* as well? */ 462 if (!really || !*(tmps = SvPV(really, n_a))) 463 tmps = PL_Argv[0]; 464 465 reread: 466 force_shell = 0; 467 if (_emx_env & 0x200) { /* OS/2. */ 468 int type = file_type(tmps); 469 type_again: 470 if (type == -1) { /* Not found */ 471 errno = ENOENT; 472 rc = -1; 473 goto do_script; 474 } 475 else if (type == -2) { /* Not an EXE */ 476 errno = ENOEXEC; 477 rc = -1; 478 goto do_script; 479 } 480 else if (type == -3) { /* Is a directory? */ 481 /* Special-case this */ 482 char tbuf[512]; 483 int l = strlen(tmps); 484 485 if (l + 5 <= sizeof tbuf) { 486 strcpy(tbuf, tmps); 487 strcpy(tbuf + l, ".exe"); 488 type = file_type(tbuf); 489 if (type >= -3) 490 goto type_again; 491 } 492 493 errno = ENOEXEC; 494 rc = -1; 495 goto do_script; 496 } 497 switch (type & 7) { 498 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */ 499 case FAPPTYP_WINDOWAPI: 500 { 501 if (os2_mytype != 3) { /* not PM */ 502 if (flag == P_NOWAIT) 503 flag = P_PM; 504 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION) 505 warn("Starting PM process with flag=%d, mytype=%d", 506 flag, os2_mytype); 507 } 508 } 509 break; 510 case FAPPTYP_NOTWINDOWCOMPAT: 511 { 512 if (os2_mytype != 0) { /* not full screen */ 513 if (flag == P_NOWAIT) 514 flag = P_SESSION; 515 else if ((flag & 7) != P_SESSION) 516 warn("Starting Full Screen process with flag=%d, mytype=%d", 517 flag, os2_mytype); 518 } 519 } 520 break; 521 case FAPPTYP_NOTSPEC: 522 /* Let the shell handle this... */ 523 force_shell = 1; 524 goto doshell_args; 525 break; 526 } 527 } 528 529 #if 0 530 rc = result(trueflag, spawnvp(flag,tmps,PL_Argv)); 531 #else 532 if (execf == EXECF_TRUEEXEC) 533 rc = execvp(tmps,PL_Argv); 534 else if (execf == EXECF_EXEC) 535 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv); 536 else if (execf == EXECF_SPAWN_NOWAIT) 537 rc = spawnvp(flag,tmps,PL_Argv); 538 else /* EXECF_SPAWN */ 539 rc = result(trueflag, 540 spawnvp(flag,tmps,PL_Argv)); 541 #endif 542 if (rc < 0 && pass == 1 543 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */ 544 do_script: 545 { 546 int err = errno; 547 548 if (err == ENOENT || err == ENOEXEC) { 549 /* No such file, or is a script. */ 550 /* Try adding script extensions to the file name, and 551 search on PATH. */ 552 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0); 553 554 if (scr) { 555 FILE *file; 556 char *s = 0, *s1; 557 int l; 558 559 l = strlen(scr); 560 561 if (l >= sizeof scrbuf) { 562 Safefree(scr); 563 longbuf: 564 croak("Size of scriptname too big: %d", l); 565 } 566 strcpy(scrbuf, scr); 567 Safefree(scr); 568 scr = scrbuf; 569 570 file = fopen(scr, "r"); 571 PL_Argv[0] = scr; 572 if (!file) 573 goto panic_file; 574 if (!fgets(buf, sizeof buf, file)) { /* Empty... */ 575 576 buf[0] = 0; 577 fclose(file); 578 /* Special case: maybe from -Zexe build, so 579 there is an executable around (contrary to 580 documentation, DosQueryAppType sometimes (?) 581 does not append ".exe", so we could have 582 reached this place). */ 583 if (l + 5 < sizeof scrbuf) { 584 strcpy(scrbuf + l, ".exe"); 585 if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0 586 && !S_ISDIR(PL_statbuf.st_mode)) { 587 /* Found */ 588 tmps = scr; 589 pass++; 590 goto reread; 591 } else 592 scrbuf[l] = 0; 593 } else 594 goto longbuf; 595 } 596 if (fclose(file) != 0) { /* Failure */ 597 panic_file: 598 warn("Error reading \"%s\": %s", 599 scr, Strerror(errno)); 600 buf[0] = 0; /* Not #! */ 601 goto doshell_args; 602 } 603 if (buf[0] == '#') { 604 if (buf[1] == '!') 605 s = buf + 2; 606 } else if (buf[0] == 'e') { 607 if (strnEQ(buf, "extproc", 7) 608 && isSPACE(buf[7])) 609 s = buf + 8; 610 } else if (buf[0] == 'E') { 611 if (strnEQ(buf, "EXTPROC", 7) 612 && isSPACE(buf[7])) 613 s = buf + 8; 614 } 615 if (!s) { 616 buf[0] = 0; /* Not #! */ 617 goto doshell_args; 618 } 619 620 s1 = s; 621 nargs = 0; 622 argsp = args; 623 while (1) { 624 /* Do better than pdksh: allow a few args, 625 strip trailing whitespace. */ 626 while (isSPACE(*s)) 627 s++; 628 if (*s == 0) 629 break; 630 if (nargs == 4) { 631 nargs = -1; 632 break; 633 } 634 args[nargs++] = s; 635 while (*s && !isSPACE(*s)) 636 s++; 637 if (*s == 0) 638 break; 639 *s++ = 0; 640 } 641 if (nargs == -1) { 642 warn("Too many args on %.*s line of \"%s\"", 643 s1 - buf, buf, scr); 644 nargs = 4; 645 argsp = fargs; 646 } 647 doshell_args: 648 { 649 char **a = PL_Argv; 650 char *exec_args[2]; 651 652 if (force_shell 653 || (!buf[0] && file)) { /* File without magic */ 654 /* In fact we tried all what pdksh would 655 try. There is no point in calling 656 pdksh, we may just emulate its logic. */ 657 char *shell = getenv("EXECSHELL"); 658 char *shell_opt = NULL; 659 660 if (!shell) { 661 char *s; 662 663 shell_opt = "/c"; 664 shell = getenv("OS2_SHELL"); 665 if (inicmd) { /* No spaces at start! */ 666 s = inicmd; 667 while (*s && !isSPACE(*s)) { 668 if (*s++ = '/') { 669 inicmd = NULL; /* Cannot use */ 670 break; 671 } 672 } 673 } 674 if (!inicmd) { 675 s = PL_Argv[0]; 676 while (*s) { 677 /* Dosish shells will choke on slashes 678 in paths, fortunately, this is 679 important for zeroth arg only. */ 680 if (*s == '/') 681 *s = '\\'; 682 s++; 683 } 684 } 685 } 686 /* If EXECSHELL is set, we do not set */ 687 688 if (!shell) 689 shell = ((_emx_env & 0x200) 690 ? "c:/os2/cmd.exe" 691 : "c:/command.com"); 692 nargs = shell_opt ? 2 : 1; /* shell file args */ 693 exec_args[0] = shell; 694 exec_args[1] = shell_opt; 695 argsp = exec_args; 696 if (nargs == 2 && inicmd) { 697 /* Use the original cmd line */ 698 /* XXXX This is good only until we refuse 699 quoted arguments... */ 700 PL_Argv[0] = inicmd; 701 PL_Argv[1] = Nullch; 702 } 703 } else if (!buf[0] && inicmd) { /* No file */ 704 /* Start with the original cmdline. */ 705 /* XXXX This is good only until we refuse 706 quoted arguments... */ 707 708 PL_Argv[0] = inicmd; 709 PL_Argv[1] = Nullch; 710 nargs = 2; /* shell -c */ 711 } 712 713 while (a[1]) /* Get to the end */ 714 a++; 715 a++; /* Copy finil NULL too */ 716 while (a >= PL_Argv) { 717 *(a + nargs) = *a; /* PL_Argv was preallocated to be 718 long enough. */ 719 a--; 720 } 721 while (nargs-- >= 0) 722 PL_Argv[nargs] = argsp[nargs]; 723 /* Enable pathless exec if #! (as pdksh). */ 724 pass = (buf[0] == '#' ? 2 : 3); 725 goto retry; 726 } 727 } 728 /* Not found: restore errno */ 729 errno = err; 730 } 731 } 732 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */ 733 char *no_dir = strrchr(PL_Argv[0], '/'); 734 735 /* Do as pdksh port does: if not found with /, try without 736 path. */ 737 if (no_dir) { 738 PL_Argv[0] = no_dir + 1; 739 pass++; 740 goto retry; 741 } 742 } 743 if (rc < 0 && PL_dowarn) 744 warn("Can't %s \"%s\": %s\n", 745 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) 746 ? "spawn" : "exec"), 747 PL_Argv[0], Strerror(errno)); 748 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT) 749 && ((trueflag & 0xFF) == P_WAIT)) 750 rc = 255 << 8; /* Emulate the fork(). */ 751 752 return rc; 753 } 754 755 /* Array spawn. */ 756 int 757 do_aspawn(really,mark,sp) 758 SV *really; 759 register SV **mark; 760 register SV **sp; 761 { 762 dTHR; 763 register char **a; 764 char *tmps = NULL; 765 int rc; 766 int flag = P_WAIT, trueflag, err, secondtry = 0; 767 STRLEN n_a; 768 769 if (sp > mark) { 770 New(1301,PL_Argv, sp - mark + 3, char*); 771 a = PL_Argv; 772 773 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { 774 ++mark; 775 flag = SvIVx(*mark); 776 } 777 778 while (++mark <= sp) { 779 if (*mark) 780 *a++ = SvPVx(*mark, n_a); 781 else 782 *a++ = ""; 783 } 784 *a = Nullch; 785 786 rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL); 787 } else 788 rc = -1; 789 do_execfree(); 790 return rc; 791 } 792 793 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */ 794 int 795 do_spawn2(cmd, execf) 796 char *cmd; 797 int execf; 798 { 799 register char **a; 800 register char *s; 801 char flags[10]; 802 char *shell, *copt, *news = NULL; 803 int rc, err, seenspace = 0; 804 char fullcmd[MAXNAMLEN + 1]; 805 806 #ifdef TRYSHELL 807 if ((shell = getenv("EMXSHELL")) != NULL) 808 copt = "-c"; 809 else if ((shell = getenv("SHELL")) != NULL) 810 copt = "-c"; 811 else if ((shell = getenv("COMSPEC")) != NULL) 812 copt = "/C"; 813 else 814 shell = "cmd.exe"; 815 #else 816 /* Consensus on perl5-porters is that it is _very_ important to 817 have a shell which will not change between computers with the 818 same architecture, to avoid "action on a distance". 819 And to have simple build, this shell should be sh. */ 820 shell = PL_sh_path; 821 copt = "-c"; 822 #endif 823 824 while (*cmd && isSPACE(*cmd)) 825 cmd++; 826 827 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) { 828 STRLEN l = strlen(PL_sh_path); 829 830 New(1302, news, strlen(cmd) - 7 + l + 1, char); 831 strcpy(news, PL_sh_path); 832 strcpy(news + l, cmd + 7); 833 cmd = news; 834 } 835 836 /* save an extra exec if possible */ 837 /* see if there are shell metacharacters in it */ 838 839 if (*cmd == '.' && isSPACE(cmd[1])) 840 goto doshell; 841 842 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) 843 goto doshell; 844 845 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ 846 if (*s == '=') 847 goto doshell; 848 849 for (s = cmd; *s; s++) { 850 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { 851 if (*s == '\n' && s[1] == '\0') { 852 *s = '\0'; 853 break; 854 } else if (*s == '\\' && !seenspace) { 855 continue; /* Allow backslashes in names */ 856 } 857 /* We do not convert this to do_spawn_ve since shell 858 should be smart enough to start itself gloriously. */ 859 doshell: 860 if (execf == EXECF_TRUEEXEC) 861 rc = execl(shell,shell,copt,cmd,(char*)0); 862 else if (execf == EXECF_EXEC) 863 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0); 864 else if (execf == EXECF_SPAWN_NOWAIT) 865 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0); 866 else { 867 /* In the ak code internal P_NOWAIT is P_WAIT ??? */ 868 rc = result(P_WAIT, 869 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); 870 if (rc < 0 && PL_dowarn) 871 warn("Can't %s \"%s\": %s", 872 (execf == EXECF_SPAWN ? "spawn" : "exec"), 873 shell, Strerror(errno)); 874 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ 875 } 876 if (news) 877 Safefree(news); 878 return rc; 879 } else if (*s == ' ' || *s == '\t') { 880 seenspace = 1; 881 } 882 } 883 884 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */ 885 New(1303,PL_Argv, (s - cmd + 11) / 2, char*); 886 PL_Cmd = savepvn(cmd, s-cmd); 887 a = PL_Argv; 888 for (s = PL_Cmd; *s;) { 889 while (*s && isSPACE(*s)) s++; 890 if (*s) 891 *(a++) = s; 892 while (*s && !isSPACE(*s)) s++; 893 if (*s) 894 *s++ = '\0'; 895 } 896 *a = Nullch; 897 if (PL_Argv[0]) 898 rc = do_spawn_ve(NULL, 0, execf, cmd); 899 else 900 rc = -1; 901 if (news) 902 Safefree(news); 903 do_execfree(); 904 return rc; 905 } 906 907 int 908 do_spawn(cmd) 909 char *cmd; 910 { 911 return do_spawn2(cmd, EXECF_SPAWN); 912 } 913 914 int 915 do_spawn_nowait(cmd) 916 char *cmd; 917 { 918 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT); 919 } 920 921 bool 922 do_exec(cmd) 923 char *cmd; 924 { 925 do_spawn2(cmd, EXECF_EXEC); 926 return FALSE; 927 } 928 929 bool 930 os2exec(cmd) 931 char *cmd; 932 { 933 return do_spawn2(cmd, EXECF_TRUEEXEC); 934 } 935 936 PerlIO * 937 my_syspopen(cmd,mode) 938 char *cmd; 939 char *mode; 940 { 941 #ifndef USE_POPEN 942 943 int p[2]; 944 register I32 this, that, newfd; 945 register I32 pid, rc; 946 PerlIO *res; 947 SV *sv; 948 949 /* `this' is what we use in the parent, `that' in the child. */ 950 this = (*mode == 'w'); 951 that = !this; 952 if (PL_tainting) { 953 taint_env(); 954 taint_proper("Insecure %s%s", "EXEC"); 955 } 956 if (pipe(p) < 0) 957 return Nullfp; 958 /* Now we need to spawn the child. */ 959 newfd = dup(*mode == 'r'); /* Preserve std* */ 960 if (p[that] != (*mode == 'r')) { 961 dup2(p[that], *mode == 'r'); 962 close(p[that]); 963 } 964 /* Where is `this' and newfd now? */ 965 fcntl(p[this], F_SETFD, FD_CLOEXEC); 966 fcntl(newfd, F_SETFD, FD_CLOEXEC); 967 pid = do_spawn_nowait(cmd); 968 if (newfd != (*mode == 'r')) { 969 dup2(newfd, *mode == 'r'); /* Return std* back. */ 970 close(newfd); 971 } 972 if (p[that] == (*mode == 'r')) 973 close(p[that]); 974 if (pid == -1) { 975 close(p[this]); 976 return NULL; 977 } 978 if (p[that] < p[this]) { 979 dup2(p[this], p[that]); 980 close(p[this]); 981 p[this] = p[that]; 982 } 983 sv = *av_fetch(PL_fdpid,p[this],TRUE); 984 (void)SvUPGRADE(sv,SVt_IV); 985 SvIVX(sv) = pid; 986 PL_forkprocess = pid; 987 return PerlIO_fdopen(p[this], mode); 988 989 #else /* USE_POPEN */ 990 991 PerlIO *res; 992 SV *sv; 993 994 # ifdef TRYSHELL 995 res = popen(cmd, mode); 996 # else 997 char *shell = getenv("EMXSHELL"); 998 999 my_setenv("EMXSHELL", PL_sh_path); 1000 res = popen(cmd, mode); 1001 my_setenv("EMXSHELL", shell); 1002 # endif 1003 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE); 1004 (void)SvUPGRADE(sv,SVt_IV); 1005 SvIVX(sv) = -1; /* A cooky. */ 1006 return res; 1007 1008 #endif /* USE_POPEN */ 1009 1010 } 1011 1012 /******************************************************************/ 1013 1014 #ifndef HAS_FORK 1015 int 1016 fork(void) 1017 { 1018 die(PL_no_func, "Unsupported function fork"); 1019 errno = EINVAL; 1020 return -1; 1021 } 1022 #endif 1023 1024 /*******************************************************************/ 1025 /* not implemented in EMX 0.9a */ 1026 1027 void * ctermid(x) { return 0; } 1028 1029 #ifdef MYTTYNAME /* was not in emx0.9a */ 1030 void * ttyname(x) { return 0; } 1031 #endif 1032 1033 /******************************************************************/ 1034 /* my socket forwarders - EMX lib only provides static forwarders */ 1035 1036 static HMODULE htcp = 0; 1037 1038 static void * 1039 tcp0(char *name) 1040 { 1041 static BYTE buf[20]; 1042 PFN fcn; 1043 1044 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */ 1045 if (!htcp) 1046 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); 1047 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) 1048 return (void *) ((void * (*)(void)) fcn) (); 1049 return 0; 1050 } 1051 1052 static void 1053 tcp1(char *name, int arg) 1054 { 1055 static BYTE buf[20]; 1056 PFN fcn; 1057 1058 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */ 1059 if (!htcp) 1060 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); 1061 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) 1062 ((void (*)(int)) fcn) (arg); 1063 } 1064 1065 void * gethostent() { return tcp0("GETHOSTENT"); } 1066 void * getnetent() { return tcp0("GETNETENT"); } 1067 void * getprotoent() { return tcp0("GETPROTOENT"); } 1068 void * getservent() { return tcp0("GETSERVENT"); } 1069 void sethostent(x) { tcp1("SETHOSTENT", x); } 1070 void setnetent(x) { tcp1("SETNETENT", x); } 1071 void setprotoent(x) { tcp1("SETPROTOENT", x); } 1072 void setservent(x) { tcp1("SETSERVENT", x); } 1073 void endhostent() { tcp0("ENDHOSTENT"); } 1074 void endnetent() { tcp0("ENDNETENT"); } 1075 void endprotoent() { tcp0("ENDPROTOENT"); } 1076 void endservent() { tcp0("ENDSERVENT"); } 1077 1078 /*****************************************************************************/ 1079 /* not implemented in C Set++ */ 1080 1081 #ifndef __EMX__ 1082 int setuid(x) { errno = EINVAL; return -1; } 1083 int setgid(x) { errno = EINVAL; return -1; } 1084 #endif 1085 1086 /*****************************************************************************/ 1087 /* stat() hack for char/block device */ 1088 1089 #if OS2_STAT_HACK 1090 1091 /* First attempt used DosQueryFSAttach which crashed the system when 1092 used with 5.001. Now just look for /dev/. */ 1093 1094 int 1095 os2_stat(char *name, struct stat *st) 1096 { 1097 static int ino = SHRT_MAX; 1098 1099 if (stricmp(name, "/dev/con") != 0 1100 && stricmp(name, "/dev/tty") != 0) 1101 return stat(name, st); 1102 1103 memset(st, 0, sizeof *st); 1104 st->st_mode = S_IFCHR|0666; 1105 st->st_ino = (ino-- & 0x7FFF); 1106 st->st_nlink = 1; 1107 return 0; 1108 } 1109 1110 #endif 1111 1112 #ifdef USE_PERL_SBRK 1113 1114 /* SBRK() emulation, mostly moved to malloc.c. */ 1115 1116 void * 1117 sys_alloc(int size) { 1118 void *got; 1119 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE); 1120 1121 if (rc == ERROR_NOT_ENOUGH_MEMORY) { 1122 return (void *) -1; 1123 } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc); 1124 return got; 1125 } 1126 1127 #endif /* USE_PERL_SBRK */ 1128 1129 /* tmp path */ 1130 1131 char *tmppath = TMPPATH1; 1132 1133 void 1134 settmppath() 1135 { 1136 char *p = getenv("TMP"), *tpath; 1137 int len; 1138 1139 if (!p) p = getenv("TEMP"); 1140 if (!p) return; 1141 len = strlen(p); 1142 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2); 1143 strcpy(tpath, p); 1144 tpath[len] = '/'; 1145 strcpy(tpath + len + 1, TMPPATH1); 1146 tmppath = tpath; 1147 } 1148 1149 #include "XSUB.h" 1150 1151 XS(XS_File__Copy_syscopy) 1152 { 1153 dXSARGS; 1154 if (items < 2 || items > 3) 1155 croak("Usage: File::Copy::syscopy(src,dst,flag=0)"); 1156 { 1157 STRLEN n_a; 1158 char * src = (char *)SvPV(ST(0),n_a); 1159 char * dst = (char *)SvPV(ST(1),n_a); 1160 U32 flag; 1161 int RETVAL, rc; 1162 1163 if (items < 3) 1164 flag = 0; 1165 else { 1166 flag = (unsigned long)SvIV(ST(2)); 1167 } 1168 1169 RETVAL = !CheckOSError(DosCopy(src, dst, flag)); 1170 ST(0) = sv_newmortal(); 1171 sv_setiv(ST(0), (IV)RETVAL); 1172 } 1173 XSRETURN(1); 1174 } 1175 1176 #include "patchlevel.h" 1177 1178 char * 1179 mod2fname(sv) 1180 SV *sv; 1181 { 1182 static char fname[9]; 1183 int pos = 6, len, avlen; 1184 unsigned int sum = 0; 1185 AV *av; 1186 SV *svp; 1187 char *s; 1188 STRLEN n_a; 1189 1190 if (!SvROK(sv)) croak("Not a reference given to mod2fname"); 1191 sv = SvRV(sv); 1192 if (SvTYPE(sv) != SVt_PVAV) 1193 croak("Not array reference given to mod2fname"); 1194 1195 avlen = av_len((AV*)sv); 1196 if (avlen < 0) 1197 croak("Empty array reference given to mod2fname"); 1198 1199 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); 1200 strncpy(fname, s, 8); 1201 len = strlen(s); 1202 if (len < 6) pos = len; 1203 while (*s) { 1204 sum = 33 * sum + *(s++); /* Checksumming first chars to 1205 * get the capitalization into c.s. */ 1206 } 1207 avlen --; 1208 while (avlen >= 0) { 1209 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); 1210 while (*s) { 1211 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */ 1212 } 1213 avlen --; 1214 } 1215 #ifdef USE_THREADS 1216 sum++; /* Avoid conflict of DLLs in memory. */ 1217 #endif 1218 sum += PATCHLEVEL * 200 + SUBVERSION * 2; /* */ 1219 fname[pos] = 'A' + (sum % 26); 1220 fname[pos + 1] = 'A' + (sum / 26 % 26); 1221 fname[pos + 2] = '\0'; 1222 return (char *)fname; 1223 } 1224 1225 XS(XS_DynaLoader_mod2fname) 1226 { 1227 dXSARGS; 1228 if (items != 1) 1229 croak("Usage: DynaLoader::mod2fname(sv)"); 1230 { 1231 SV * sv = ST(0); 1232 char * RETVAL; 1233 1234 RETVAL = mod2fname(sv); 1235 ST(0) = sv_newmortal(); 1236 sv_setpv((SV*)ST(0), RETVAL); 1237 } 1238 XSRETURN(1); 1239 } 1240 1241 char * 1242 os2error(int rc) 1243 { 1244 static char buf[300]; 1245 ULONG len; 1246 1247 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */ 1248 if (rc == 0) 1249 return NULL; 1250 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len)) 1251 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc); 1252 else 1253 buf[len] = '\0'; 1254 if (len > 0 && buf[len - 1] == '\n') 1255 buf[len - 1] = '\0'; 1256 if (len > 1 && buf[len - 2] == '\r') 1257 buf[len - 2] = '\0'; 1258 if (len > 2 && buf[len - 3] == '.') 1259 buf[len - 3] = '\0'; 1260 return buf; 1261 } 1262 1263 char * 1264 perllib_mangle(char *s, unsigned int l) 1265 { 1266 static char *newp, *oldp; 1267 static int newl, oldl, notfound; 1268 static char ret[STATIC_FILE_LENGTH+1]; 1269 1270 if (!newp && !notfound) { 1271 newp = getenv("PERLLIB_PREFIX"); 1272 if (newp) { 1273 char *s; 1274 1275 oldp = newp; 1276 while (*newp && !isSPACE(*newp) && *newp != ';') { 1277 newp++; oldl++; /* Skip digits. */ 1278 } 1279 while (*newp && (isSPACE(*newp) || *newp == ';')) { 1280 newp++; /* Skip whitespace. */ 1281 } 1282 newl = strlen(newp); 1283 if (newl == 0 || oldl == 0) { 1284 die("Malformed PERLLIB_PREFIX"); 1285 } 1286 strcpy(ret, newp); 1287 s = ret; 1288 while (*s) { 1289 if (*s == '\\') *s = '/'; 1290 s++; 1291 } 1292 } else { 1293 notfound = 1; 1294 } 1295 } 1296 if (!newp) { 1297 return s; 1298 } 1299 if (l == 0) { 1300 l = strlen(s); 1301 } 1302 if (l < oldl || strnicmp(oldp, s, oldl) != 0) { 1303 return s; 1304 } 1305 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) { 1306 die("Malformed PERLLIB_PREFIX"); 1307 } 1308 strcpy(ret + newl, s + oldl); 1309 return ret; 1310 } 1311 1312 extern void dlopen(); 1313 void *fakedl = &dlopen; /* Pull in dynaloading part. */ 1314 1315 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \ 1316 && ((path)[2] == '/' || (path)[2] == '\\')) 1317 #define sys_is_rooted _fnisabs 1318 #define sys_is_relative _fnisrel 1319 #define current_drive _getdrive 1320 1321 #undef chdir /* Was _chdir2. */ 1322 #define sys_chdir(p) (chdir(p) == 0) 1323 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d))) 1324 1325 XS(XS_Cwd_current_drive) 1326 { 1327 dXSARGS; 1328 if (items != 0) 1329 croak("Usage: Cwd::current_drive()"); 1330 { 1331 char RETVAL; 1332 1333 RETVAL = current_drive(); 1334 ST(0) = sv_newmortal(); 1335 sv_setpvn(ST(0), (char *)&RETVAL, 1); 1336 } 1337 XSRETURN(1); 1338 } 1339 1340 XS(XS_Cwd_sys_chdir) 1341 { 1342 dXSARGS; 1343 if (items != 1) 1344 croak("Usage: Cwd::sys_chdir(path)"); 1345 { 1346 STRLEN n_a; 1347 char * path = (char *)SvPV(ST(0),n_a); 1348 bool RETVAL; 1349 1350 RETVAL = sys_chdir(path); 1351 ST(0) = boolSV(RETVAL); 1352 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 1353 } 1354 XSRETURN(1); 1355 } 1356 1357 XS(XS_Cwd_change_drive) 1358 { 1359 dXSARGS; 1360 if (items != 1) 1361 croak("Usage: Cwd::change_drive(d)"); 1362 { 1363 STRLEN n_a; 1364 char d = (char)*SvPV(ST(0),n_a); 1365 bool RETVAL; 1366 1367 RETVAL = change_drive(d); 1368 ST(0) = boolSV(RETVAL); 1369 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 1370 } 1371 XSRETURN(1); 1372 } 1373 1374 XS(XS_Cwd_sys_is_absolute) 1375 { 1376 dXSARGS; 1377 if (items != 1) 1378 croak("Usage: Cwd::sys_is_absolute(path)"); 1379 { 1380 STRLEN n_a; 1381 char * path = (char *)SvPV(ST(0),n_a); 1382 bool RETVAL; 1383 1384 RETVAL = sys_is_absolute(path); 1385 ST(0) = boolSV(RETVAL); 1386 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 1387 } 1388 XSRETURN(1); 1389 } 1390 1391 XS(XS_Cwd_sys_is_rooted) 1392 { 1393 dXSARGS; 1394 if (items != 1) 1395 croak("Usage: Cwd::sys_is_rooted(path)"); 1396 { 1397 STRLEN n_a; 1398 char * path = (char *)SvPV(ST(0),n_a); 1399 bool RETVAL; 1400 1401 RETVAL = sys_is_rooted(path); 1402 ST(0) = boolSV(RETVAL); 1403 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 1404 } 1405 XSRETURN(1); 1406 } 1407 1408 XS(XS_Cwd_sys_is_relative) 1409 { 1410 dXSARGS; 1411 if (items != 1) 1412 croak("Usage: Cwd::sys_is_relative(path)"); 1413 { 1414 STRLEN n_a; 1415 char * path = (char *)SvPV(ST(0),n_a); 1416 bool RETVAL; 1417 1418 RETVAL = sys_is_relative(path); 1419 ST(0) = boolSV(RETVAL); 1420 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 1421 } 1422 XSRETURN(1); 1423 } 1424 1425 XS(XS_Cwd_sys_cwd) 1426 { 1427 dXSARGS; 1428 if (items != 0) 1429 croak("Usage: Cwd::sys_cwd()"); 1430 { 1431 char p[MAXPATHLEN]; 1432 char * RETVAL; 1433 RETVAL = _getcwd2(p, MAXPATHLEN); 1434 ST(0) = sv_newmortal(); 1435 sv_setpv((SV*)ST(0), RETVAL); 1436 } 1437 XSRETURN(1); 1438 } 1439 1440 XS(XS_Cwd_sys_abspath) 1441 { 1442 dXSARGS; 1443 if (items < 1 || items > 2) 1444 croak("Usage: Cwd::sys_abspath(path, dir = NULL)"); 1445 { 1446 STRLEN n_a; 1447 char * path = (char *)SvPV(ST(0),n_a); 1448 char * dir; 1449 char p[MAXPATHLEN]; 1450 char * RETVAL; 1451 1452 if (items < 2) 1453 dir = NULL; 1454 else { 1455 dir = (char *)SvPV(ST(1),n_a); 1456 } 1457 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) { 1458 path += 2; 1459 } 1460 if (dir == NULL) { 1461 if (_abspath(p, path, MAXPATHLEN) == 0) { 1462 RETVAL = p; 1463 } else { 1464 RETVAL = NULL; 1465 } 1466 } else { 1467 /* Absolute with drive: */ 1468 if ( sys_is_absolute(path) ) { 1469 if (_abspath(p, path, MAXPATHLEN) == 0) { 1470 RETVAL = p; 1471 } else { 1472 RETVAL = NULL; 1473 } 1474 } else if (path[0] == '/' || path[0] == '\\') { 1475 /* Rooted, but maybe on different drive. */ 1476 if (isALPHA(dir[0]) && dir[1] == ':' ) { 1477 char p1[MAXPATHLEN]; 1478 1479 /* Need to prepend the drive. */ 1480 p1[0] = dir[0]; 1481 p1[1] = dir[1]; 1482 Copy(path, p1 + 2, strlen(path) + 1, char); 1483 RETVAL = p; 1484 if (_abspath(p, p1, MAXPATHLEN) == 0) { 1485 RETVAL = p; 1486 } else { 1487 RETVAL = NULL; 1488 } 1489 } else if (_abspath(p, path, MAXPATHLEN) == 0) { 1490 RETVAL = p; 1491 } else { 1492 RETVAL = NULL; 1493 } 1494 } else { 1495 /* Either path is relative, or starts with a drive letter. */ 1496 /* If the path starts with a drive letter, then dir is 1497 relevant only if 1498 a/b) it is absolute/x:relative on the same drive. 1499 c) path is on current drive, and dir is rooted 1500 In all the cases it is safe to drop the drive part 1501 of the path. */ 1502 if ( !sys_is_relative(path) ) { 1503 int is_drived; 1504 1505 if ( ( ( sys_is_absolute(dir) 1506 || (isALPHA(dir[0]) && dir[1] == ':' 1507 && strnicmp(dir, path,1) == 0)) 1508 && strnicmp(dir, path,1) == 0) 1509 || ( !(isALPHA(dir[0]) && dir[1] == ':') 1510 && toupper(path[0]) == current_drive())) { 1511 path += 2; 1512 } else if (_abspath(p, path, MAXPATHLEN) == 0) { 1513 RETVAL = p; goto done; 1514 } else { 1515 RETVAL = NULL; goto done; 1516 } 1517 } 1518 { 1519 /* Need to prepend the absolute path of dir. */ 1520 char p1[MAXPATHLEN]; 1521 1522 if (_abspath(p1, dir, MAXPATHLEN) == 0) { 1523 int l = strlen(p1); 1524 1525 if (p1[ l - 1 ] != '/') { 1526 p1[ l ] = '/'; 1527 l++; 1528 } 1529 Copy(path, p1 + l, strlen(path) + 1, char); 1530 if (_abspath(p, p1, MAXPATHLEN) == 0) { 1531 RETVAL = p; 1532 } else { 1533 RETVAL = NULL; 1534 } 1535 } else { 1536 RETVAL = NULL; 1537 } 1538 } 1539 done: 1540 } 1541 } 1542 ST(0) = sv_newmortal(); 1543 sv_setpv((SV*)ST(0), RETVAL); 1544 } 1545 XSRETURN(1); 1546 } 1547 typedef APIRET (*PELP)(PSZ path, ULONG type); 1548 1549 APIRET 1550 ExtLIBPATH(ULONG ord, PSZ path, ULONG type) 1551 { 1552 loadByOrd(ord); /* Guarantied to load or die! */ 1553 return (*(PELP)ExtFCN[ord])(path, type); 1554 } 1555 1556 #define extLibpath(type) \ 1557 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \ 1558 : BEGIN_LIBPATH))) \ 1559 ? NULL : to ) 1560 1561 #define extLibpath_set(p,type) \ 1562 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \ 1563 : BEGIN_LIBPATH)))) 1564 1565 XS(XS_Cwd_extLibpath) 1566 { 1567 dXSARGS; 1568 if (items < 0 || items > 1) 1569 croak("Usage: Cwd::extLibpath(type = 0)"); 1570 { 1571 bool type; 1572 char to[1024]; 1573 U32 rc; 1574 char * RETVAL; 1575 1576 if (items < 1) 1577 type = 0; 1578 else { 1579 type = (int)SvIV(ST(0)); 1580 } 1581 1582 RETVAL = extLibpath(type); 1583 ST(0) = sv_newmortal(); 1584 sv_setpv((SV*)ST(0), RETVAL); 1585 } 1586 XSRETURN(1); 1587 } 1588 1589 XS(XS_Cwd_extLibpath_set) 1590 { 1591 dXSARGS; 1592 if (items < 1 || items > 2) 1593 croak("Usage: Cwd::extLibpath_set(s, type = 0)"); 1594 { 1595 STRLEN n_a; 1596 char * s = (char *)SvPV(ST(0),n_a); 1597 bool type; 1598 U32 rc; 1599 bool RETVAL; 1600 1601 if (items < 2) 1602 type = 0; 1603 else { 1604 type = (int)SvIV(ST(1)); 1605 } 1606 1607 RETVAL = extLibpath_set(s, type); 1608 ST(0) = boolSV(RETVAL); 1609 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 1610 } 1611 XSRETURN(1); 1612 } 1613 1614 int 1615 Xs_OS2_init() 1616 { 1617 char *file = __FILE__; 1618 { 1619 GV *gv; 1620 1621 if (_emx_env & 0x200) { /* OS/2 */ 1622 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); 1623 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); 1624 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file); 1625 } 1626 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file); 1627 newXS("Cwd::current_drive", XS_Cwd_current_drive, file); 1628 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file); 1629 newXS("Cwd::change_drive", XS_Cwd_change_drive, file); 1630 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file); 1631 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file); 1632 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file); 1633 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file); 1634 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file); 1635 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); 1636 GvMULTI_on(gv); 1637 #ifdef PERL_IS_AOUT 1638 sv_setiv(GvSV(gv), 1); 1639 #endif 1640 } 1641 } 1642 1643 OS2_Perl_data_t OS2_Perl_data; 1644 1645 void 1646 Perl_OS2_init(char **env) 1647 { 1648 char *shell; 1649 1650 MALLOC_INIT; 1651 settmppath(); 1652 OS2_Perl_data.xs_init = &Xs_OS2_init; 1653 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY); 1654 if (environ == NULL) { 1655 environ = env; 1656 } 1657 if ( (shell = getenv("PERL_SH_DRIVE")) ) { 1658 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char); 1659 strcpy(PL_sh_path, SH_PATH); 1660 PL_sh_path[0] = shell[0]; 1661 } else if ( (shell = getenv("PERL_SH_DIR")) ) { 1662 int l = strlen(shell), i; 1663 if (shell[l-1] == '/' || shell[l-1] == '\\') { 1664 l--; 1665 } 1666 New(1304, PL_sh_path, l + 8, char); 1667 strncpy(PL_sh_path, shell, l); 1668 strcpy(PL_sh_path + l, "/sh.exe"); 1669 for (i = 0; i < l; i++) { 1670 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/'; 1671 } 1672 } 1673 MUTEX_INIT(&start_thread_mutex); 1674 os2_mytype = my_type(); /* Do it before morphing. Needed? */ 1675 } 1676 1677 #undef tmpnam 1678 #undef tmpfile 1679 1680 char * 1681 my_tmpnam (char *str) 1682 { 1683 char *p = getenv("TMP"), *tpath; 1684 int len; 1685 1686 if (!p) p = getenv("TEMP"); 1687 tpath = tempnam(p, "pltmp"); 1688 if (str && tpath) { 1689 strcpy(str, tpath); 1690 return str; 1691 } 1692 return tpath; 1693 } 1694 1695 FILE * 1696 my_tmpfile () 1697 { 1698 struct stat s; 1699 1700 stat(".", &s); 1701 if (s.st_mode & S_IWOTH) { 1702 return tmpfile(); 1703 } 1704 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but 1705 grants TMP. */ 1706 } 1707 1708 #undef flock 1709 1710 /* This code was contributed by Rocco Caputo. */ 1711 int 1712 my_flock(int handle, int o) 1713 { 1714 FILELOCK rNull, rFull; 1715 ULONG timeout, handle_type, flag_word; 1716 APIRET rc; 1717 int blocking, shared; 1718 static int use_my = -1; 1719 1720 if (use_my == -1) { 1721 char *s = getenv("USE_PERL_FLOCK"); 1722 if (s) 1723 use_my = atoi(s); 1724 else 1725 use_my = 1; 1726 } 1727 if (!(_emx_env & 0x200) || !use_my) 1728 return flock(handle, o); /* Delegate to EMX. */ 1729 1730 // is this a file? 1731 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) || 1732 (handle_type & 0xFF)) 1733 { 1734 errno = EBADF; 1735 return -1; 1736 } 1737 // set lock/unlock ranges 1738 rNull.lOffset = rNull.lRange = rFull.lOffset = 0; 1739 rFull.lRange = 0x7FFFFFFF; 1740 // set timeout for blocking 1741 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1; 1742 // shared or exclusive? 1743 shared = (o & LOCK_SH) ? 1 : 0; 1744 // do not block the unlock 1745 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) { 1746 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared); 1747 switch (rc) { 1748 case 0: 1749 errno = 0; 1750 return 0; 1751 case ERROR_INVALID_HANDLE: 1752 errno = EBADF; 1753 return -1; 1754 case ERROR_SHARING_BUFFER_EXCEEDED: 1755 errno = ENOLCK; 1756 return -1; 1757 case ERROR_LOCK_VIOLATION: 1758 break; // not an error 1759 case ERROR_INVALID_PARAMETER: 1760 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: 1761 case ERROR_READ_LOCKS_NOT_SUPPORTED: 1762 errno = EINVAL; 1763 return -1; 1764 case ERROR_INTERRUPT: 1765 errno = EINTR; 1766 return -1; 1767 default: 1768 errno = EINVAL; 1769 return -1; 1770 } 1771 } 1772 // lock may block 1773 if (o & (LOCK_SH | LOCK_EX)) { 1774 // for blocking operations 1775 for (;;) { 1776 rc = 1777 DosSetFileLocks( 1778 handle, 1779 &rNull, 1780 &rFull, 1781 timeout, 1782 shared 1783 ); 1784 switch (rc) { 1785 case 0: 1786 errno = 0; 1787 return 0; 1788 case ERROR_INVALID_HANDLE: 1789 errno = EBADF; 1790 return -1; 1791 case ERROR_SHARING_BUFFER_EXCEEDED: 1792 errno = ENOLCK; 1793 return -1; 1794 case ERROR_LOCK_VIOLATION: 1795 if (!blocking) { 1796 errno = EWOULDBLOCK; 1797 return -1; 1798 } 1799 break; 1800 case ERROR_INVALID_PARAMETER: 1801 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: 1802 case ERROR_READ_LOCKS_NOT_SUPPORTED: 1803 errno = EINVAL; 1804 return -1; 1805 case ERROR_INTERRUPT: 1806 errno = EINTR; 1807 return -1; 1808 default: 1809 errno = EINVAL; 1810 return -1; 1811 } 1812 // give away timeslice 1813 DosSleep(1); 1814 } 1815 } 1816 1817 errno = 0; 1818 return 0; 1819 } 1820