1 #define INCL_DOS 2 #define INCL_NOPM 3 #define INCL_DOSFILEMGR 4 #define INCL_DOSMEMMGR 5 #define INCL_DOSERRORS 6 /* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */ 7 #define INCL_DOSPROCESS 8 #define SPU_DISABLESUPPRESSION 0 9 #define SPU_ENABLESUPPRESSION 1 10 #include <os2.h> 11 #include "dlfcn.h" 12 13 #include <sys/uflags.h> 14 15 /* 16 * Various Unix compatibility functions for OS/2 17 */ 18 19 #include <stdio.h> 20 #include <errno.h> 21 #include <limits.h> 22 #include <process.h> 23 #include <fcntl.h> 24 25 #include "EXTERN.h" 26 #include "perl.h" 27 28 #ifdef USE_THREADS 29 30 typedef void (*emx_startroutine)(void *); 31 typedef void* (*pthreads_startroutine)(void *); 32 33 enum pthreads_state { 34 pthreads_st_none = 0, 35 pthreads_st_run, 36 pthreads_st_exited, 37 pthreads_st_detached, 38 pthreads_st_waited, 39 }; 40 const char *pthreads_states[] = { 41 "uninit", 42 "running", 43 "exited", 44 "detached", 45 "waited for", 46 }; 47 48 typedef struct { 49 void *status; 50 perl_cond cond; 51 enum pthreads_state state; 52 } thread_join_t; 53 54 thread_join_t *thread_join_data; 55 int thread_join_count; 56 perl_mutex start_thread_mutex; 57 58 int 59 pthread_join(perl_os_thread tid, void **status) 60 { 61 MUTEX_LOCK(&start_thread_mutex); 62 switch (thread_join_data[tid].state) { 63 case pthreads_st_exited: 64 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */ 65 MUTEX_UNLOCK(&start_thread_mutex); 66 *status = thread_join_data[tid].status; 67 break; 68 case pthreads_st_waited: 69 MUTEX_UNLOCK(&start_thread_mutex); 70 Perl_croak_nocontext("join with a thread with a waiter"); 71 break; 72 case pthreads_st_run: 73 thread_join_data[tid].state = pthreads_st_waited; 74 COND_INIT(&thread_join_data[tid].cond); 75 MUTEX_UNLOCK(&start_thread_mutex); 76 COND_WAIT(&thread_join_data[tid].cond, NULL); 77 COND_DESTROY(&thread_join_data[tid].cond); 78 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */ 79 *status = thread_join_data[tid].status; 80 break; 81 default: 82 MUTEX_UNLOCK(&start_thread_mutex); 83 Perl_croak_nocontext("join: unknown thread state: '%s'", 84 pthreads_states[thread_join_data[tid].state]); 85 break; 86 } 87 return 0; 88 } 89 90 void 91 pthread_startit(void *arg) 92 { 93 /* Thread is already started, we need to transfer control only */ 94 pthreads_startroutine start_routine = *((pthreads_startroutine*)arg); 95 int tid = pthread_self(); 96 void *retval; 97 98 arg = ((void**)arg)[1]; 99 if (tid >= thread_join_count) { 100 int oc = thread_join_count; 101 102 thread_join_count = tid + 5 + tid/5; 103 if (thread_join_data) { 104 Renew(thread_join_data, thread_join_count, thread_join_t); 105 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t); 106 } else { 107 Newz(1323, thread_join_data, thread_join_count, thread_join_t); 108 } 109 } 110 if (thread_join_data[tid].state != pthreads_st_none) 111 Perl_croak_nocontext("attempt to reuse thread id %i", tid); 112 thread_join_data[tid].state = pthreads_st_run; 113 /* Now that we copied/updated the guys, we may release the caller... */ 114 MUTEX_UNLOCK(&start_thread_mutex); 115 thread_join_data[tid].status = (*start_routine)(arg); 116 switch (thread_join_data[tid].state) { 117 case pthreads_st_waited: 118 COND_SIGNAL(&thread_join_data[tid].cond); 119 break; 120 default: 121 thread_join_data[tid].state = pthreads_st_exited; 122 break; 123 } 124 } 125 126 int 127 pthread_create(perl_os_thread *tid, const pthread_attr_t *attr, 128 void *(*start_routine)(void*), void *arg) 129 { 130 void *args[2]; 131 132 args[0] = (void*)start_routine; 133 args[1] = arg; 134 135 MUTEX_LOCK(&start_thread_mutex); 136 *tid = _beginthread(pthread_startit, /*stack*/ NULL, 137 /*stacksize*/ 10*1024*1024, (void*)args); 138 MUTEX_LOCK(&start_thread_mutex); 139 MUTEX_UNLOCK(&start_thread_mutex); 140 return *tid ? 0 : EINVAL; 141 } 142 143 int 144 pthread_detach(perl_os_thread tid) 145 { 146 MUTEX_LOCK(&start_thread_mutex); 147 switch (thread_join_data[tid].state) { 148 case pthreads_st_waited: 149 MUTEX_UNLOCK(&start_thread_mutex); 150 Perl_croak_nocontext("detach on a thread with a waiter"); 151 break; 152 case pthreads_st_run: 153 thread_join_data[tid].state = pthreads_st_detached; 154 MUTEX_UNLOCK(&start_thread_mutex); 155 break; 156 default: 157 MUTEX_UNLOCK(&start_thread_mutex); 158 Perl_croak_nocontext("detach: unknown thread state: '%s'", 159 pthreads_states[thread_join_data[tid].state]); 160 break; 161 } 162 return 0; 163 } 164 165 /* This is a very bastardized version: */ 166 int 167 os2_cond_wait(perl_cond *c, perl_mutex *m) 168 { 169 int rc; 170 STRLEN n_a; 171 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET)) 172 Perl_croak_nocontext("panic: COND_WAIT-reset: rc=%i", rc); 173 if (m) MUTEX_UNLOCK(m); 174 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT)) 175 && (rc != ERROR_INTERRUPT)) 176 Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc); 177 if (rc == ERROR_INTERRUPT) 178 errno = EINTR; 179 if (m) MUTEX_LOCK(m); 180 } 181 #endif 182 183 /*****************************************************************************/ 184 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */ 185 static PFN ExtFCN[2]; /* Labeled by ord below. */ 186 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */ 187 #define ORD_QUERY_ELP 0 188 #define ORD_SET_ELP 1 189 struct PMWIN_entries_t PMWIN_entries; 190 191 HMODULE 192 loadModule(char *modname) 193 { 194 HMODULE h = (HMODULE)dlopen(modname, 0); 195 if (!h) 196 Perl_croak_nocontext("Error loading module '%s': %s", 197 modname, dlerror()); 198 return h; 199 } 200 201 APIRET 202 loadByOrd(char *modname, ULONG ord) 203 { 204 if (ExtFCN[ord] == NULL) { 205 static HMODULE hdosc = 0; 206 BYTE buf[20]; 207 PFN fcn; 208 APIRET rc; 209 210 211 if (!hdosc) { 212 hdosc = loadModule(modname); 213 if (CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn))) 214 Perl_croak_nocontext( 215 "This version of OS/2 does not support %s.%i", 216 modname, loadOrd[ord]); 217 } 218 ExtFCN[ord] = fcn; 219 } 220 if ((long)ExtFCN[ord] == -1) 221 Perl_croak_nocontext("panic queryaddr"); 222 } 223 224 void 225 init_PMWIN_entries(void) 226 { 227 static HMODULE hpmwin = 0; 228 static const int ords[] = { 229 763, /* Initialize */ 230 716, /* CreateMsgQueue */ 231 726, /* DestroyMsgQueue */ 232 918, /* PeekMsg */ 233 915, /* GetMsg */ 234 912, /* DispatchMsg */ 235 753, /* GetLastError */ 236 705, /* CancelShutdown */ 237 }; 238 BYTE buf[20]; 239 int i = 0; 240 unsigned long rc; 241 242 if (hpmwin) 243 return; 244 245 hpmwin = loadModule("pmwin"); 246 while (i < sizeof(ords)/sizeof(int)) { 247 if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL, 248 ((PFN*)&PMWIN_entries)+i))) 249 Perl_croak_nocontext("This version of OS/2 does not support pmwin.%d", ords[i]); 250 i++; 251 } 252 } 253 254 255 /* priorities */ 256 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, 257 self inverse. */ 258 #define QSS_INI_BUFFER 1024 259 260 PQTOPLEVEL 261 get_sysinfo(ULONG pid, ULONG flags) 262 { 263 char *pbuffer; 264 ULONG rc, buf_len = QSS_INI_BUFFER; 265 266 New(1322, pbuffer, buf_len, char); 267 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */ 268 rc = QuerySysState(flags, pid, pbuffer, buf_len); 269 while (rc == ERROR_BUFFER_OVERFLOW) { 270 Renew(pbuffer, buf_len *= 2, char); 271 rc = QuerySysState(flags, pid, pbuffer, buf_len); 272 } 273 if (rc) { 274 FillOSError(rc); 275 Safefree(pbuffer); 276 return 0; 277 } 278 return (PQTOPLEVEL)pbuffer; 279 } 280 281 #define PRIO_ERR 0x1111 282 283 static ULONG 284 sys_prio(pid) 285 { 286 ULONG prio; 287 PQTOPLEVEL psi; 288 289 psi = get_sysinfo(pid, QSS_PROCESS); 290 if (!psi) { 291 return PRIO_ERR; 292 } 293 if (pid != psi->procdata->pid) { 294 Safefree(psi); 295 Perl_croak_nocontext("panic: wrong pid in sysinfo"); 296 } 297 prio = psi->procdata->threads->priority; 298 Safefree(psi); 299 return prio; 300 } 301 302 int 303 setpriority(int which, int pid, int val) 304 { 305 ULONG rc, prio; 306 PQTOPLEVEL psi; 307 308 prio = sys_prio(pid); 309 310 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ 311 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) { 312 /* Do not change class. */ 313 return CheckOSError(DosSetPriority((pid < 0) 314 ? PRTYS_PROCESSTREE : PRTYS_PROCESS, 315 0, 316 (32 - val) % 32 - (prio & 0xFF), 317 abs(pid))) 318 ? -1 : 0; 319 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ { 320 /* Documentation claims one can change both class and basevalue, 321 * but I find it wrong. */ 322 /* Change class, but since delta == 0 denotes absolute 0, correct. */ 323 if (CheckOSError(DosSetPriority((pid < 0) 324 ? PRTYS_PROCESSTREE : PRTYS_PROCESS, 325 priors[(32 - val) >> 5] + 1, 326 0, 327 abs(pid)))) 328 return -1; 329 if ( ((32 - val) % 32) == 0 ) return 0; 330 return CheckOSError(DosSetPriority((pid < 0) 331 ? PRTYS_PROCESSTREE : PRTYS_PROCESS, 332 0, 333 (32 - val) % 32, 334 abs(pid))) 335 ? -1 : 0; 336 } 337 /* else return CheckOSError(DosSetPriority((pid < 0) */ 338 /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */ 339 /* priors[(32 - val) >> 5] + 1, */ 340 /* (32 - val) % 32 - (prio & 0xFF), */ 341 /* abs(pid))) */ 342 /* ? -1 : 0; */ 343 } 344 345 int 346 getpriority(int which /* ignored */, int pid) 347 { 348 TIB *tib; 349 PIB *pib; 350 ULONG rc, ret; 351 352 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ 353 /* DosGetInfoBlocks has old priority! */ 354 /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */ 355 /* if (pid != pib->pib_ulpid) { */ 356 ret = sys_prio(pid); 357 if (ret == PRIO_ERR) { 358 return -1; 359 } 360 /* } else */ 361 /* ret = tib->tib_ptib2->tib2_ulpri; */ 362 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF); 363 } 364 365 /*****************************************************************************/ 366 /* spawn */ 367 368 /* There is no big sense to make it thread-specific, since signals 369 are delivered to thread 1 only. XXXX Maybe make it into an array? */ 370 static int spawn_pid; 371 static int spawn_killed; 372 373 static Signal_t 374 spawn_sighandler(int sig) 375 { 376 /* Some programs do not arrange for the keyboard signals to be 377 delivered to them. We need to deliver the signal manually. */ 378 /* We may get a signal only if 379 a) kid does not receive keyboard signal: deliver it; 380 b) kid already died, and we get a signal. We may only hope 381 that the pid number was not reused. 382 */ 383 384 if (spawn_killed) 385 sig = SIGKILL; /* Try harder. */ 386 kill(spawn_pid, sig); 387 spawn_killed = 1; 388 } 389 390 static int 391 result(pTHX_ int flag, int pid) 392 { 393 int r, status; 394 Signal_t (*ihand)(); /* place to save signal during system() */ 395 Signal_t (*qhand)(); /* place to save signal during system() */ 396 #ifndef __EMX__ 397 RESULTCODES res; 398 int rpid; 399 #endif 400 401 if (pid < 0 || flag != 0) 402 return pid; 403 404 #ifdef __EMX__ 405 spawn_pid = pid; 406 spawn_killed = 0; 407 ihand = rsignal(SIGINT, &spawn_sighandler); 408 qhand = rsignal(SIGQUIT, &spawn_sighandler); 409 do { 410 r = wait4pid(pid, &status, 0); 411 } while (r == -1 && errno == EINTR); 412 rsignal(SIGINT, ihand); 413 rsignal(SIGQUIT, qhand); 414 415 PL_statusvalue = (U16)status; 416 if (r < 0) 417 return -1; 418 return status & 0xFFFF; 419 #else 420 ihand = rsignal(SIGINT, SIG_IGN); 421 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid); 422 rsignal(SIGINT, ihand); 423 PL_statusvalue = res.codeResult << 8 | res.codeTerminate; 424 if (r) 425 return -1; 426 return PL_statusvalue; 427 #endif 428 } 429 430 #define EXECF_SPAWN 0 431 #define EXECF_EXEC 1 432 #define EXECF_TRUEEXEC 2 433 #define EXECF_SPAWN_NOWAIT 3 434 #define EXECF_SPAWN_BYFLAG 4 435 436 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */ 437 438 static int 439 my_type() 440 { 441 int rc; 442 TIB *tib; 443 PIB *pib; 444 445 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */ 446 if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) 447 return -1; 448 449 return (pib->pib_ultype); 450 } 451 452 static ULONG 453 file_type(char *path) 454 { 455 int rc; 456 ULONG apptype; 457 458 if (!(_emx_env & 0x200)) 459 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */ 460 if (CheckOSError(DosQueryAppType(path, &apptype))) { 461 switch (rc) { 462 case ERROR_FILE_NOT_FOUND: 463 case ERROR_PATH_NOT_FOUND: 464 return -1; 465 case ERROR_ACCESS_DENIED: /* Directory with this name found? */ 466 return -3; 467 default: /* Found, but not an 468 executable, or some other 469 read error. */ 470 return -2; 471 } 472 } 473 return apptype; 474 } 475 476 static ULONG os2_mytype; 477 478 /* Spawn/exec a program, revert to shell if needed. */ 479 /* global PL_Argv[] contains arguments. */ 480 481 int 482 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) 483 { 484 int trueflag = flag; 485 int rc, pass = 1; 486 char *tmps; 487 char buf[256], *s = 0, scrbuf[280]; 488 char *args[4]; 489 static char * fargs[4] 490 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", }; 491 char **argsp = fargs; 492 char nargs = 4; 493 int force_shell; 494 int new_stderr = -1, nostderr = 0, fl_stderr; 495 STRLEN n_a; 496 497 if (flag == P_WAIT) 498 flag = P_NOWAIT; 499 500 retry: 501 if (strEQ(PL_Argv[0],"/bin/sh")) 502 PL_Argv[0] = PL_sh_path; 503 504 if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\' 505 && !(PL_Argv[0][0] && PL_Argv[0][1] == ':' 506 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\')) 507 ) /* will spawnvp use PATH? */ 508 TAINT_ENV(); /* testing IFS here is overkill, probably */ 509 /* We should check PERL_SH* and PERLLIB_* as well? */ 510 if (!really || !*(tmps = SvPV(really, n_a))) 511 tmps = PL_Argv[0]; 512 513 reread: 514 force_shell = 0; 515 if (_emx_env & 0x200) { /* OS/2. */ 516 int type = file_type(tmps); 517 type_again: 518 if (type == -1) { /* Not found */ 519 errno = ENOENT; 520 rc = -1; 521 goto do_script; 522 } 523 else if (type == -2) { /* Not an EXE */ 524 errno = ENOEXEC; 525 rc = -1; 526 goto do_script; 527 } 528 else if (type == -3) { /* Is a directory? */ 529 /* Special-case this */ 530 char tbuf[512]; 531 int l = strlen(tmps); 532 533 if (l + 5 <= sizeof tbuf) { 534 strcpy(tbuf, tmps); 535 strcpy(tbuf + l, ".exe"); 536 type = file_type(tbuf); 537 if (type >= -3) 538 goto type_again; 539 } 540 541 errno = ENOEXEC; 542 rc = -1; 543 goto do_script; 544 } 545 switch (type & 7) { 546 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */ 547 case FAPPTYP_WINDOWAPI: 548 { 549 if (os2_mytype != 3) { /* not PM */ 550 if (flag == P_NOWAIT) 551 flag = P_PM; 552 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION) 553 Perl_warner(aTHX_ WARN_EXEC, "Starting PM process with flag=%d, mytype=%d", 554 flag, os2_mytype); 555 } 556 } 557 break; 558 case FAPPTYP_NOTWINDOWCOMPAT: 559 { 560 if (os2_mytype != 0) { /* not full screen */ 561 if (flag == P_NOWAIT) 562 flag = P_SESSION; 563 else if ((flag & 7) != P_SESSION) 564 Perl_warner(aTHX_ WARN_EXEC, "Starting Full Screen process with flag=%d, mytype=%d", 565 flag, os2_mytype); 566 } 567 } 568 break; 569 case FAPPTYP_NOTSPEC: 570 /* Let the shell handle this... */ 571 force_shell = 1; 572 goto doshell_args; 573 break; 574 } 575 } 576 577 if (addflag) { 578 addflag = 0; 579 new_stderr = dup(2); /* Preserve stderr */ 580 if (new_stderr == -1) { 581 if (errno == EBADF) 582 nostderr = 1; 583 else { 584 rc = -1; 585 goto finish; 586 } 587 } else 588 fl_stderr = fcntl(2, F_GETFD); 589 rc = dup2(1,2); 590 if (rc == -1) 591 goto finish; 592 fcntl(new_stderr, F_SETFD, FD_CLOEXEC); 593 } 594 595 #if 0 596 rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv)); 597 #else 598 if (execf == EXECF_TRUEEXEC) 599 rc = execvp(tmps,PL_Argv); 600 else if (execf == EXECF_EXEC) 601 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv); 602 else if (execf == EXECF_SPAWN_NOWAIT) 603 rc = spawnvp(flag,tmps,PL_Argv); 604 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */ 605 rc = result(aTHX_ trueflag, 606 spawnvp(flag,tmps,PL_Argv)); 607 #endif 608 if (rc < 0 && pass == 1 609 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */ 610 do_script: 611 { 612 int err = errno; 613 614 if (err == ENOENT || err == ENOEXEC) { 615 /* No such file, or is a script. */ 616 /* Try adding script extensions to the file name, and 617 search on PATH. */ 618 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0); 619 620 if (scr) { 621 FILE *file; 622 char *s = 0, *s1; 623 int l; 624 625 l = strlen(scr); 626 627 if (l >= sizeof scrbuf) { 628 Safefree(scr); 629 longbuf: 630 Perl_warner(aTHX_ WARN_EXEC, "Size of scriptname too big: %d", l); 631 rc = -1; 632 goto finish; 633 } 634 strcpy(scrbuf, scr); 635 Safefree(scr); 636 scr = scrbuf; 637 638 file = fopen(scr, "r"); 639 PL_Argv[0] = scr; 640 if (!file) 641 goto panic_file; 642 if (!fgets(buf, sizeof buf, file)) { /* Empty... */ 643 644 buf[0] = 0; 645 fclose(file); 646 /* Special case: maybe from -Zexe build, so 647 there is an executable around (contrary to 648 documentation, DosQueryAppType sometimes (?) 649 does not append ".exe", so we could have 650 reached this place). */ 651 if (l + 5 < sizeof scrbuf) { 652 strcpy(scrbuf + l, ".exe"); 653 if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0 654 && !S_ISDIR(PL_statbuf.st_mode)) { 655 /* Found */ 656 tmps = scr; 657 pass++; 658 goto reread; 659 } else 660 scrbuf[l] = 0; 661 } else 662 goto longbuf; 663 } 664 if (fclose(file) != 0) { /* Failure */ 665 panic_file: 666 Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s", 667 scr, Strerror(errno)); 668 buf[0] = 0; /* Not #! */ 669 goto doshell_args; 670 } 671 if (buf[0] == '#') { 672 if (buf[1] == '!') 673 s = buf + 2; 674 } else if (buf[0] == 'e') { 675 if (strnEQ(buf, "extproc", 7) 676 && isSPACE(buf[7])) 677 s = buf + 8; 678 } else if (buf[0] == 'E') { 679 if (strnEQ(buf, "EXTPROC", 7) 680 && isSPACE(buf[7])) 681 s = buf + 8; 682 } 683 if (!s) { 684 buf[0] = 0; /* Not #! */ 685 goto doshell_args; 686 } 687 688 s1 = s; 689 nargs = 0; 690 argsp = args; 691 while (1) { 692 /* Do better than pdksh: allow a few args, 693 strip trailing whitespace. */ 694 while (isSPACE(*s)) 695 s++; 696 if (*s == 0) 697 break; 698 if (nargs == 4) { 699 nargs = -1; 700 break; 701 } 702 args[nargs++] = s; 703 while (*s && !isSPACE(*s)) 704 s++; 705 if (*s == 0) 706 break; 707 *s++ = 0; 708 } 709 if (nargs == -1) { 710 Perl_warner(aTHX_ WARN_EXEC, "Too many args on %.*s line of \"%s\"", 711 s1 - buf, buf, scr); 712 nargs = 4; 713 argsp = fargs; 714 } 715 doshell_args: 716 { 717 char **a = PL_Argv; 718 char *exec_args[2]; 719 720 if (force_shell 721 || (!buf[0] && file)) { /* File without magic */ 722 /* In fact we tried all what pdksh would 723 try. There is no point in calling 724 pdksh, we may just emulate its logic. */ 725 char *shell = getenv("EXECSHELL"); 726 char *shell_opt = NULL; 727 728 if (!shell) { 729 char *s; 730 731 shell_opt = "/c"; 732 shell = getenv("OS2_SHELL"); 733 if (inicmd) { /* No spaces at start! */ 734 s = inicmd; 735 while (*s && !isSPACE(*s)) { 736 if (*s++ = '/') { 737 inicmd = NULL; /* Cannot use */ 738 break; 739 } 740 } 741 } 742 if (!inicmd) { 743 s = PL_Argv[0]; 744 while (*s) { 745 /* Dosish shells will choke on slashes 746 in paths, fortunately, this is 747 important for zeroth arg only. */ 748 if (*s == '/') 749 *s = '\\'; 750 s++; 751 } 752 } 753 } 754 /* If EXECSHELL is set, we do not set */ 755 756 if (!shell) 757 shell = ((_emx_env & 0x200) 758 ? "c:/os2/cmd.exe" 759 : "c:/command.com"); 760 nargs = shell_opt ? 2 : 1; /* shell file args */ 761 exec_args[0] = shell; 762 exec_args[1] = shell_opt; 763 argsp = exec_args; 764 if (nargs == 2 && inicmd) { 765 /* Use the original cmd line */ 766 /* XXXX This is good only until we refuse 767 quoted arguments... */ 768 PL_Argv[0] = inicmd; 769 PL_Argv[1] = Nullch; 770 } 771 } else if (!buf[0] && inicmd) { /* No file */ 772 /* Start with the original cmdline. */ 773 /* XXXX This is good only until we refuse 774 quoted arguments... */ 775 776 PL_Argv[0] = inicmd; 777 PL_Argv[1] = Nullch; 778 nargs = 2; /* shell -c */ 779 } 780 781 while (a[1]) /* Get to the end */ 782 a++; 783 a++; /* Copy finil NULL too */ 784 while (a >= PL_Argv) { 785 *(a + nargs) = *a; /* PL_Argv was preallocated to be 786 long enough. */ 787 a--; 788 } 789 while (--nargs >= 0) 790 PL_Argv[nargs] = argsp[nargs]; 791 /* Enable pathless exec if #! (as pdksh). */ 792 pass = (buf[0] == '#' ? 2 : 3); 793 goto retry; 794 } 795 } 796 /* Not found: restore errno */ 797 errno = err; 798 } 799 } 800 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */ 801 char *no_dir = strrchr(PL_Argv[0], '/'); 802 803 /* Do as pdksh port does: if not found with /, try without 804 path. */ 805 if (no_dir) { 806 PL_Argv[0] = no_dir + 1; 807 pass++; 808 goto retry; 809 } 810 } 811 if (rc < 0 && ckWARN(WARN_EXEC)) 812 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n", 813 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) 814 ? "spawn" : "exec"), 815 PL_Argv[0], Strerror(errno)); 816 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT) 817 && ((trueflag & 0xFF) == P_WAIT)) 818 rc = -1; 819 820 finish: 821 if (new_stderr != -1) { /* How can we use error codes? */ 822 dup2(new_stderr, 2); 823 close(new_stderr); 824 fcntl(2, F_SETFD, fl_stderr); 825 } else if (nostderr) 826 close(2); 827 return rc; 828 } 829 830 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */ 831 int 832 do_spawn3(pTHX_ char *cmd, int execf, int flag) 833 { 834 register char **a; 835 register char *s; 836 char flags[10]; 837 char *shell, *copt, *news = NULL; 838 int rc, err, seenspace = 0, mergestderr = 0; 839 char fullcmd[MAXNAMLEN + 1]; 840 841 #ifdef TRYSHELL 842 if ((shell = getenv("EMXSHELL")) != NULL) 843 copt = "-c"; 844 else if ((shell = getenv("SHELL")) != NULL) 845 copt = "-c"; 846 else if ((shell = getenv("COMSPEC")) != NULL) 847 copt = "/C"; 848 else 849 shell = "cmd.exe"; 850 #else 851 /* Consensus on perl5-porters is that it is _very_ important to 852 have a shell which will not change between computers with the 853 same architecture, to avoid "action on a distance". 854 And to have simple build, this shell should be sh. */ 855 shell = PL_sh_path; 856 copt = "-c"; 857 #endif 858 859 while (*cmd && isSPACE(*cmd)) 860 cmd++; 861 862 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) { 863 STRLEN l = strlen(PL_sh_path); 864 865 New(1302, news, strlen(cmd) - 7 + l + 1, char); 866 strcpy(news, PL_sh_path); 867 strcpy(news + l, cmd + 7); 868 cmd = news; 869 } 870 871 /* save an extra exec if possible */ 872 /* see if there are shell metacharacters in it */ 873 874 if (*cmd == '.' && isSPACE(cmd[1])) 875 goto doshell; 876 877 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) 878 goto doshell; 879 880 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ 881 if (*s == '=') 882 goto doshell; 883 884 for (s = cmd; *s; s++) { 885 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { 886 if (*s == '\n' && s[1] == '\0') { 887 *s = '\0'; 888 break; 889 } else if (*s == '\\' && !seenspace) { 890 continue; /* Allow backslashes in names */ 891 } else if (*s == '>' && s >= cmd + 3 892 && s[-1] == '2' && s[1] == '&' && s[2] == '1' 893 && isSPACE(s[-2]) ) { 894 char *t = s + 3; 895 896 while (*t && isSPACE(*t)) 897 t++; 898 if (!*t) { 899 s[-2] = '\0'; 900 mergestderr = 1; 901 break; /* Allow 2>&1 as the last thing */ 902 } 903 } 904 /* We do not convert this to do_spawn_ve since shell 905 should be smart enough to start itself gloriously. */ 906 doshell: 907 if (execf == EXECF_TRUEEXEC) 908 rc = execl(shell,shell,copt,cmd,(char*)0); 909 else if (execf == EXECF_EXEC) 910 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0); 911 else if (execf == EXECF_SPAWN_NOWAIT) 912 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0); 913 else if (execf == EXECF_SPAWN_BYFLAG) 914 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0); 915 else { 916 /* In the ak code internal P_NOWAIT is P_WAIT ??? */ 917 rc = result(aTHX_ P_WAIT, 918 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); 919 if (rc < 0 && ckWARN(WARN_EXEC)) 920 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s", 921 (execf == EXECF_SPAWN ? "spawn" : "exec"), 922 shell, Strerror(errno)); 923 if (rc < 0) 924 rc = -1; 925 } 926 if (news) 927 Safefree(news); 928 return rc; 929 } else if (*s == ' ' || *s == '\t') { 930 seenspace = 1; 931 } 932 } 933 934 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */ 935 New(1303,PL_Argv, (s - cmd + 11) / 2, char*); 936 PL_Cmd = savepvn(cmd, s-cmd); 937 a = PL_Argv; 938 for (s = PL_Cmd; *s;) { 939 while (*s && isSPACE(*s)) s++; 940 if (*s) 941 *(a++) = s; 942 while (*s && !isSPACE(*s)) s++; 943 if (*s) 944 *s++ = '\0'; 945 } 946 *a = Nullch; 947 if (PL_Argv[0]) 948 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr); 949 else 950 rc = -1; 951 if (news) 952 Safefree(news); 953 do_execfree(); 954 return rc; 955 } 956 957 /* Array spawn. */ 958 int 959 os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp) 960 { 961 register char **a; 962 int rc; 963 int flag = P_WAIT, flag_set = 0; 964 STRLEN n_a; 965 966 if (sp > mark) { 967 New(1301,PL_Argv, sp - mark + 3, char*); 968 a = PL_Argv; 969 970 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { 971 ++mark; 972 flag = SvIVx(*mark); 973 flag_set = 1; 974 975 } 976 977 while (++mark <= sp) { 978 if (*mark) 979 *a++ = SvPVx(*mark, n_a); 980 else 981 *a++ = ""; 982 } 983 *a = Nullch; 984 985 if (flag_set && (a == PL_Argv + 1)) { /* One arg? */ 986 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag); 987 } else 988 rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0); 989 } else 990 rc = -1; 991 do_execfree(); 992 return rc; 993 } 994 995 int 996 os2_do_spawn(pTHX_ char *cmd) 997 { 998 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0); 999 } 1000 1001 int 1002 do_spawn_nowait(pTHX_ char *cmd) 1003 { 1004 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0); 1005 } 1006 1007 bool 1008 Perl_do_exec(pTHX_ char *cmd) 1009 { 1010 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0); 1011 return FALSE; 1012 } 1013 1014 bool 1015 os2exec(pTHX_ char *cmd) 1016 { 1017 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0); 1018 } 1019 1020 PerlIO * 1021 my_syspopen(pTHX_ char *cmd, char *mode) 1022 { 1023 #ifndef USE_POPEN 1024 1025 int p[2]; 1026 register I32 this, that, newfd; 1027 register I32 pid, rc; 1028 PerlIO *res; 1029 SV *sv; 1030 int fh_fl; 1031 1032 /* `this' is what we use in the parent, `that' in the child. */ 1033 this = (*mode == 'w'); 1034 that = !this; 1035 if (PL_tainting) { 1036 taint_env(); 1037 taint_proper("Insecure %s%s", "EXEC"); 1038 } 1039 if (pipe(p) < 0) 1040 return Nullfp; 1041 /* Now we need to spawn the child. */ 1042 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */ 1043 int new = dup(p[this]); 1044 1045 if (new == -1) 1046 goto closepipes; 1047 close(p[this]); 1048 p[this] = new; 1049 } 1050 newfd = dup(*mode == 'r'); /* Preserve std* */ 1051 if (newfd == -1) { 1052 /* This cannot happen due to fh being bad after pipe(), since 1053 pipe() should have created fh 0 and 1 even if they were 1054 initially closed. But we closed p[this] before. */ 1055 if (errno != EBADF) { 1056 closepipes: 1057 close(p[0]); 1058 close(p[1]); 1059 return Nullfp; 1060 } 1061 } else 1062 fh_fl = fcntl(*mode == 'r', F_GETFD); 1063 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */ 1064 dup2(p[that], *mode == 'r'); 1065 close(p[that]); 1066 } 1067 /* Where is `this' and newfd now? */ 1068 fcntl(p[this], F_SETFD, FD_CLOEXEC); 1069 if (newfd != -1) 1070 fcntl(newfd, F_SETFD, FD_CLOEXEC); 1071 pid = do_spawn_nowait(aTHX_ cmd); 1072 if (newfd == -1) 1073 close(*mode == 'r'); /* It was closed initially */ 1074 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */ 1075 dup2(newfd, *mode == 'r'); /* Return std* back. */ 1076 close(newfd); 1077 fcntl(*mode == 'r', F_SETFD, fh_fl); 1078 } else 1079 fcntl(*mode == 'r', F_SETFD, fh_fl); 1080 if (p[that] == (*mode == 'r')) 1081 close(p[that]); 1082 if (pid == -1) { 1083 close(p[this]); 1084 return Nullfp; 1085 } 1086 if (p[that] < p[this]) { /* Make fh as small as possible */ 1087 dup2(p[this], p[that]); 1088 close(p[this]); 1089 p[this] = p[that]; 1090 } 1091 sv = *av_fetch(PL_fdpid,p[this],TRUE); 1092 (void)SvUPGRADE(sv,SVt_IV); 1093 SvIVX(sv) = pid; 1094 PL_forkprocess = pid; 1095 return PerlIO_fdopen(p[this], mode); 1096 1097 #else /* USE_POPEN */ 1098 1099 PerlIO *res; 1100 SV *sv; 1101 1102 # ifdef TRYSHELL 1103 res = popen(cmd, mode); 1104 # else 1105 char *shell = getenv("EMXSHELL"); 1106 1107 my_setenv("EMXSHELL", PL_sh_path); 1108 res = popen(cmd, mode); 1109 my_setenv("EMXSHELL", shell); 1110 # endif 1111 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE); 1112 (void)SvUPGRADE(sv,SVt_IV); 1113 SvIVX(sv) = -1; /* A cooky. */ 1114 return res; 1115 1116 #endif /* USE_POPEN */ 1117 1118 } 1119 1120 /******************************************************************/ 1121 1122 #ifndef HAS_FORK 1123 int 1124 fork(void) 1125 { 1126 Perl_croak_nocontext(PL_no_func, "Unsupported function fork"); 1127 errno = EINVAL; 1128 return -1; 1129 } 1130 #endif 1131 1132 /*******************************************************************/ 1133 /* not implemented in EMX 0.9d */ 1134 1135 char * ctermid(char *s) { return 0; } 1136 1137 #ifdef MYTTYNAME /* was not in emx0.9a */ 1138 void * ttyname(x) { return 0; } 1139 #endif 1140 1141 /******************************************************************/ 1142 /* my socket forwarders - EMX lib only provides static forwarders */ 1143 1144 static HMODULE htcp = 0; 1145 1146 static void * 1147 tcp0(char *name) 1148 { 1149 PFN fcn; 1150 1151 if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */ 1152 if (!htcp) 1153 htcp = loadModule("tcp32dll"); 1154 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) 1155 return (void *) ((void * (*)(void)) fcn) (); 1156 return 0; 1157 } 1158 1159 static void 1160 tcp1(char *name, int arg) 1161 { 1162 static BYTE buf[20]; 1163 PFN fcn; 1164 1165 if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */ 1166 if (!htcp) 1167 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); 1168 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) 1169 ((void (*)(int)) fcn) (arg); 1170 } 1171 1172 struct hostent * gethostent() { return tcp0("GETHOSTENT"); } 1173 struct netent * getnetent() { return tcp0("GETNETENT"); } 1174 struct protoent * getprotoent() { return tcp0("GETPROTOENT"); } 1175 struct servent * getservent() { return tcp0("GETSERVENT"); } 1176 1177 void sethostent(x) { tcp1("SETHOSTENT", x); } 1178 void setnetent(x) { tcp1("SETNETENT", x); } 1179 void setprotoent(x) { tcp1("SETPROTOENT", x); } 1180 void setservent(x) { tcp1("SETSERVENT", x); } 1181 void endhostent() { tcp0("ENDHOSTENT"); } 1182 void endnetent() { tcp0("ENDNETENT"); } 1183 void endprotoent() { tcp0("ENDPROTOENT"); } 1184 void endservent() { tcp0("ENDSERVENT"); } 1185 1186 /*****************************************************************************/ 1187 /* not implemented in C Set++ */ 1188 1189 #ifndef __EMX__ 1190 int setuid(x) { errno = EINVAL; return -1; } 1191 int setgid(x) { errno = EINVAL; return -1; } 1192 #endif 1193 1194 /*****************************************************************************/ 1195 /* stat() hack for char/block device */ 1196 1197 #if OS2_STAT_HACK 1198 1199 /* First attempt used DosQueryFSAttach which crashed the system when 1200 used with 5.001. Now just look for /dev/. */ 1201 1202 int 1203 os2_stat(char *name, struct stat *st) 1204 { 1205 static int ino = SHRT_MAX; 1206 1207 if (stricmp(name, "/dev/con") != 0 1208 && stricmp(name, "/dev/tty") != 0) 1209 return stat(name, st); 1210 1211 memset(st, 0, sizeof *st); 1212 st->st_mode = S_IFCHR|0666; 1213 st->st_ino = (ino-- & 0x7FFF); 1214 st->st_nlink = 1; 1215 return 0; 1216 } 1217 1218 #endif 1219 1220 #ifdef USE_PERL_SBRK 1221 1222 /* SBRK() emulation, mostly moved to malloc.c. */ 1223 1224 void * 1225 sys_alloc(int size) { 1226 void *got; 1227 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE); 1228 1229 if (rc == ERROR_NOT_ENOUGH_MEMORY) { 1230 return (void *) -1; 1231 } else if ( rc ) 1232 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc); 1233 return got; 1234 } 1235 1236 #endif /* USE_PERL_SBRK */ 1237 1238 /* tmp path */ 1239 1240 char *tmppath = TMPPATH1; 1241 1242 void 1243 settmppath() 1244 { 1245 char *p = getenv("TMP"), *tpath; 1246 int len; 1247 1248 if (!p) p = getenv("TEMP"); 1249 if (!p) return; 1250 len = strlen(p); 1251 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2); 1252 if (tpath) { 1253 strcpy(tpath, p); 1254 tpath[len] = '/'; 1255 strcpy(tpath + len + 1, TMPPATH1); 1256 tmppath = tpath; 1257 } 1258 } 1259 1260 #include "XSUB.h" 1261 1262 XS(XS_File__Copy_syscopy) 1263 { 1264 dXSARGS; 1265 if (items < 2 || items > 3) 1266 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)"); 1267 { 1268 STRLEN n_a; 1269 char * src = (char *)SvPV(ST(0),n_a); 1270 char * dst = (char *)SvPV(ST(1),n_a); 1271 U32 flag; 1272 int RETVAL, rc; 1273 1274 if (items < 3) 1275 flag = 0; 1276 else { 1277 flag = (unsigned long)SvIV(ST(2)); 1278 } 1279 1280 RETVAL = !CheckOSError(DosCopy(src, dst, flag)); 1281 ST(0) = sv_newmortal(); 1282 sv_setiv(ST(0), (IV)RETVAL); 1283 } 1284 XSRETURN(1); 1285 } 1286 1287 #include "patchlevel.h" 1288 1289 char * 1290 mod2fname(pTHX_ SV *sv) 1291 { 1292 static char fname[9]; 1293 int pos = 6, len, avlen; 1294 unsigned int sum = 0; 1295 AV *av; 1296 SV *svp; 1297 char *s; 1298 STRLEN n_a; 1299 1300 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname"); 1301 sv = SvRV(sv); 1302 if (SvTYPE(sv) != SVt_PVAV) 1303 Perl_croak_nocontext("Not array reference given to mod2fname"); 1304 1305 avlen = av_len((AV*)sv); 1306 if (avlen < 0) 1307 Perl_croak_nocontext("Empty array reference given to mod2fname"); 1308 1309 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); 1310 strncpy(fname, s, 8); 1311 len = strlen(s); 1312 if (len < 6) pos = len; 1313 while (*s) { 1314 sum = 33 * sum + *(s++); /* Checksumming first chars to 1315 * get the capitalization into c.s. */ 1316 } 1317 avlen --; 1318 while (avlen >= 0) { 1319 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); 1320 while (*s) { 1321 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */ 1322 } 1323 avlen --; 1324 } 1325 #ifdef USE_THREADS 1326 sum++; /* Avoid conflict of DLLs in memory. */ 1327 #endif 1328 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* */ 1329 fname[pos] = 'A' + (sum % 26); 1330 fname[pos + 1] = 'A' + (sum / 26 % 26); 1331 fname[pos + 2] = '\0'; 1332 return (char *)fname; 1333 } 1334 1335 XS(XS_DynaLoader_mod2fname) 1336 { 1337 dXSARGS; 1338 if (items != 1) 1339 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)"); 1340 { 1341 SV * sv = ST(0); 1342 char * RETVAL; 1343 1344 RETVAL = mod2fname(aTHX_ sv); 1345 ST(0) = sv_newmortal(); 1346 sv_setpv((SV*)ST(0), RETVAL); 1347 } 1348 XSRETURN(1); 1349 } 1350 1351 char * 1352 os2error(int rc) 1353 { 1354 static char buf[300]; 1355 ULONG len; 1356 1357 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */ 1358 if (rc == 0) 1359 return NULL; 1360 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len)) 1361 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc); 1362 else { 1363 buf[len] = '\0'; 1364 if (len && buf[len - 1] == '\n') 1365 buf[--len] = 0; 1366 if (len && buf[len - 1] == '\r') 1367 buf[--len] = 0; 1368 if (len && buf[len - 1] == '.') 1369 buf[--len] = 0; 1370 } 1371 return buf; 1372 } 1373 1374 char * 1375 os2_execname(pTHX) 1376 { 1377 char buf[300], *p, *o = PL_origargv[0], ok = 1; 1378 1379 if (_execname(buf, sizeof buf) != 0) 1380 return o; 1381 p = buf; 1382 while (*p) { 1383 if (*p == '\\') 1384 *p = '/'; 1385 if (*p == '/') { 1386 if (ok && *o != '/' && *o != '\\') 1387 ok = 0; 1388 } else if (ok && tolower(*o) != tolower(*p)) 1389 ok = 0; 1390 p++; 1391 o++; 1392 } 1393 if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */ 1394 strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */ 1395 p = buf; 1396 while (*p) { 1397 if (*p == '\\') 1398 *p = '/'; 1399 p++; 1400 } 1401 } 1402 p = savepv(buf); 1403 SAVEFREEPV(p); 1404 return p; 1405 } 1406 1407 char * 1408 perllib_mangle(char *s, unsigned int l) 1409 { 1410 static char *newp, *oldp; 1411 static int newl, oldl, notfound; 1412 static char ret[STATIC_FILE_LENGTH+1]; 1413 1414 if (!newp && !notfound) { 1415 newp = getenv("PERLLIB_PREFIX"); 1416 if (newp) { 1417 char *s; 1418 1419 oldp = newp; 1420 while (*newp && !isSPACE(*newp) && *newp != ';') { 1421 newp++; oldl++; /* Skip digits. */ 1422 } 1423 while (*newp && (isSPACE(*newp) || *newp == ';')) { 1424 newp++; /* Skip whitespace. */ 1425 } 1426 newl = strlen(newp); 1427 if (newl == 0 || oldl == 0) { 1428 Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); 1429 } 1430 strcpy(ret, newp); 1431 s = ret; 1432 while (*s) { 1433 if (*s == '\\') *s = '/'; 1434 s++; 1435 } 1436 } else { 1437 notfound = 1; 1438 } 1439 } 1440 if (!newp) { 1441 return s; 1442 } 1443 if (l == 0) { 1444 l = strlen(s); 1445 } 1446 if (l < oldl || strnicmp(oldp, s, oldl) != 0) { 1447 return s; 1448 } 1449 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) { 1450 Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); 1451 } 1452 strcpy(ret + newl, s + oldl); 1453 return ret; 1454 } 1455 1456 unsigned long 1457 Perl_hab_GET() /* Needed if perl.h cannot be included */ 1458 { 1459 return perl_hab_GET(); 1460 } 1461 1462 HMQ 1463 Perl_Register_MQ(int serve) 1464 { 1465 PPIB pib; 1466 PTIB tib; 1467 1468 if (Perl_os2_initial_mode++) 1469 return Perl_hmq; 1470 DosGetInfoBlocks(&tib, &pib); 1471 Perl_os2_initial_mode = pib->pib_ultype; 1472 /* Try morphing into a PM application. */ 1473 if (pib->pib_ultype != 3) /* 2 is VIO */ 1474 pib->pib_ultype = 3; /* 3 is PM */ 1475 init_PMWIN_entries(); 1476 /* 64 messages if before OS/2 3.0, ignored otherwise */ 1477 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64); 1478 if (!Perl_hmq) { 1479 static int cnt; 1480 1481 SAVEINT(cnt); /* Allow catch()ing. */ 1482 if (cnt++) 1483 _exit(188); /* Panic can try to create a window. */ 1484 Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application"); 1485 } 1486 if (serve) { 1487 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */ 1488 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */ 1489 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0); 1490 Perl_hmq_servers++; 1491 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */ 1492 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); 1493 Perl_hmq_refcnt++; 1494 return Perl_hmq; 1495 } 1496 1497 int 1498 Perl_Serve_Messages(int force) 1499 { 1500 int cnt = 0; 1501 QMSG msg; 1502 1503 if (Perl_hmq_servers > 0 && !force) 1504 return 0; 1505 if (Perl_hmq_refcnt <= 0) 1506 Perl_croak_nocontext("No message queue"); 1507 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) { 1508 cnt++; 1509 if (msg.msg == WM_QUIT) 1510 Perl_croak_nocontext("QUITing..."); 1511 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); 1512 } 1513 return cnt; 1514 } 1515 1516 int 1517 Perl_Process_Messages(int force, I32 *cntp) 1518 { 1519 QMSG msg; 1520 1521 if (Perl_hmq_servers > 0 && !force) 1522 return 0; 1523 if (Perl_hmq_refcnt <= 0) 1524 Perl_croak_nocontext("No message queue"); 1525 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) { 1526 if (cntp) 1527 (*cntp)++; 1528 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); 1529 if (msg.msg == WM_DESTROY) 1530 return -1; 1531 if (msg.msg == WM_CREATE) 1532 return +1; 1533 } 1534 Perl_croak_nocontext("QUITing..."); 1535 } 1536 1537 void 1538 Perl_Deregister_MQ(int serve) 1539 { 1540 PPIB pib; 1541 PTIB tib; 1542 1543 if (serve) 1544 Perl_hmq_servers--; 1545 if (--Perl_hmq_refcnt <= 0) { 1546 init_PMWIN_entries(); /* To be extra safe */ 1547 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq); 1548 Perl_hmq = 0; 1549 /* Try morphing back from a PM application. */ 1550 DosGetInfoBlocks(&tib, &pib); 1551 if (pib->pib_ultype == 3) /* 3 is PM */ 1552 pib->pib_ultype = Perl_os2_initial_mode; 1553 else 1554 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM", 1555 pib->pib_ultype); 1556 } else if (serve && Perl_hmq_servers <= 0) /* Last server exited */ 1557 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); 1558 } 1559 1560 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \ 1561 && ((path)[2] == '/' || (path)[2] == '\\')) 1562 #define sys_is_rooted _fnisabs 1563 #define sys_is_relative _fnisrel 1564 #define current_drive _getdrive 1565 1566 #undef chdir /* Was _chdir2. */ 1567 #define sys_chdir(p) (chdir(p) == 0) 1568 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d))) 1569 1570 static int DOS_harderr_state = -1; 1571 1572 XS(XS_OS2_Error) 1573 { 1574 dXSARGS; 1575 if (items != 2) 1576 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)"); 1577 { 1578 int arg1 = SvIV(ST(0)); 1579 int arg2 = SvIV(ST(1)); 1580 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR) 1581 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION)); 1582 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0)); 1583 unsigned long rc; 1584 1585 if (CheckOSError(DosError(a))) 1586 Perl_croak_nocontext("DosError(%d) failed", a); 1587 ST(0) = sv_newmortal(); 1588 if (DOS_harderr_state >= 0) 1589 sv_setiv(ST(0), DOS_harderr_state); 1590 DOS_harderr_state = RETVAL; 1591 } 1592 XSRETURN(1); 1593 } 1594 1595 static signed char DOS_suppression_state = -1; 1596 1597 XS(XS_OS2_Errors2Drive) 1598 { 1599 dXSARGS; 1600 if (items != 1) 1601 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)"); 1602 { 1603 STRLEN n_a; 1604 SV *sv = ST(0); 1605 int suppress = SvOK(sv); 1606 char *s = suppress ? SvPV(sv, n_a) : NULL; 1607 char drive = (s ? *s : 0); 1608 unsigned long rc; 1609 1610 if (suppress && !isALPHA(drive)) 1611 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive); 1612 if (CheckOSError(DosSuppressPopUps((suppress 1613 ? SPU_ENABLESUPPRESSION 1614 : SPU_DISABLESUPPRESSION), 1615 drive))) 1616 Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive); 1617 ST(0) = sv_newmortal(); 1618 if (DOS_suppression_state > 0) 1619 sv_setpvn(ST(0), &DOS_suppression_state, 1); 1620 else if (DOS_suppression_state == 0) 1621 sv_setpvn(ST(0), "", 0); 1622 DOS_suppression_state = drive; 1623 } 1624 XSRETURN(1); 1625 } 1626 1627 static const char * const si_fields[QSV_MAX] = { 1628 "MAX_PATH_LENGTH", 1629 "MAX_TEXT_SESSIONS", 1630 "MAX_PM_SESSIONS", 1631 "MAX_VDM_SESSIONS", 1632 "BOOT_DRIVE", 1633 "DYN_PRI_VARIATION", 1634 "MAX_WAIT", 1635 "MIN_SLICE", 1636 "MAX_SLICE", 1637 "PAGE_SIZE", 1638 "VERSION_MAJOR", 1639 "VERSION_MINOR", 1640 "VERSION_REVISION", 1641 "MS_COUNT", 1642 "TIME_LOW", 1643 "TIME_HIGH", 1644 "TOTPHYSMEM", 1645 "TOTRESMEM", 1646 "TOTAVAILMEM", 1647 "MAXPRMEM", 1648 "MAXSHMEM", 1649 "TIMER_INTERVAL", 1650 "MAX_COMP_LENGTH", 1651 "FOREGROUND_FS_SESSION", 1652 "FOREGROUND_PROCESS" 1653 }; 1654 1655 XS(XS_OS2_SysInfo) 1656 { 1657 dXSARGS; 1658 if (items != 0) 1659 Perl_croak_nocontext("Usage: OS2::SysInfo()"); 1660 { 1661 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */ 1662 APIRET rc = NO_ERROR; /* Return code */ 1663 int i = 0, j = 0; 1664 1665 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */ 1666 QSV_MAX, /* information */ 1667 (PVOID)si, 1668 sizeof(si)))) 1669 Perl_croak_nocontext("DosQuerySysInfo() failed"); 1670 EXTEND(SP,2*QSV_MAX); 1671 while (i < QSV_MAX) { 1672 ST(j) = sv_newmortal(); 1673 sv_setpv(ST(j++), si_fields[i]); 1674 ST(j) = sv_newmortal(); 1675 sv_setiv(ST(j++), si[i]); 1676 i++; 1677 } 1678 } 1679 XSRETURN(2 * QSV_MAX); 1680 } 1681 1682 XS(XS_OS2_BootDrive) 1683 { 1684 dXSARGS; 1685 if (items != 0) 1686 Perl_croak_nocontext("Usage: OS2::BootDrive()"); 1687 { 1688 ULONG si[1] = {0}; /* System Information Data Buffer */ 1689 APIRET rc = NO_ERROR; /* Return code */ 1690 char c; 1691 1692 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE, 1693 (PVOID)si, sizeof(si)))) 1694 Perl_croak_nocontext("DosQuerySysInfo() failed"); 1695 ST(0) = sv_newmortal(); 1696 c = 'a' - 1 + si[0]; 1697 sv_setpvn(ST(0), &c, 1); 1698 } 1699 XSRETURN(1); 1700 } 1701 1702 XS(XS_OS2_MorphPM) 1703 { 1704 dXSARGS; 1705 if (items != 1) 1706 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)"); 1707 { 1708 bool serve = SvOK(ST(0)); 1709 unsigned long pmq = perl_hmq_GET(serve); 1710 1711 ST(0) = sv_newmortal(); 1712 sv_setiv(ST(0), pmq); 1713 } 1714 XSRETURN(1); 1715 } 1716 1717 XS(XS_OS2_UnMorphPM) 1718 { 1719 dXSARGS; 1720 if (items != 1) 1721 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)"); 1722 { 1723 bool serve = SvOK(ST(0)); 1724 1725 perl_hmq_UNSET(serve); 1726 } 1727 XSRETURN(0); 1728 } 1729 1730 XS(XS_OS2_Serve_Messages) 1731 { 1732 dXSARGS; 1733 if (items != 1) 1734 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)"); 1735 { 1736 bool force = SvOK(ST(0)); 1737 unsigned long cnt = Perl_Serve_Messages(force); 1738 1739 ST(0) = sv_newmortal(); 1740 sv_setiv(ST(0), cnt); 1741 } 1742 XSRETURN(1); 1743 } 1744 1745 XS(XS_OS2_Process_Messages) 1746 { 1747 dXSARGS; 1748 if (items < 1 || items > 2) 1749 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])"); 1750 { 1751 bool force = SvOK(ST(0)); 1752 unsigned long cnt; 1753 1754 if (items == 2) { 1755 I32 cntr; 1756 SV *sv = ST(1); 1757 int fake = SvIV(sv); /* Force SvIVX */ 1758 1759 if (!SvIOK(sv)) 1760 Perl_croak_nocontext("Can't upgrade count to IV"); 1761 cntr = SvIVX(sv); 1762 cnt = Perl_Process_Messages(force, &cntr); 1763 SvIVX(sv) = cntr; 1764 } else { 1765 cnt = Perl_Process_Messages(force, NULL); 1766 } 1767 ST(0) = sv_newmortal(); 1768 sv_setiv(ST(0), cnt); 1769 } 1770 XSRETURN(1); 1771 } 1772 1773 XS(XS_Cwd_current_drive) 1774 { 1775 dXSARGS; 1776 if (items != 0) 1777 Perl_croak_nocontext("Usage: Cwd::current_drive()"); 1778 { 1779 char RETVAL; 1780 1781 RETVAL = current_drive(); 1782 ST(0) = sv_newmortal(); 1783 sv_setpvn(ST(0), (char *)&RETVAL, 1); 1784 } 1785 XSRETURN(1); 1786 } 1787 1788 XS(XS_Cwd_sys_chdir) 1789 { 1790 dXSARGS; 1791 if (items != 1) 1792 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)"); 1793 { 1794 STRLEN n_a; 1795 char * path = (char *)SvPV(ST(0),n_a); 1796 bool RETVAL; 1797 1798 RETVAL = sys_chdir(path); 1799 ST(0) = boolSV(RETVAL); 1800 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 1801 } 1802 XSRETURN(1); 1803 } 1804 1805 XS(XS_Cwd_change_drive) 1806 { 1807 dXSARGS; 1808 if (items != 1) 1809 Perl_croak_nocontext("Usage: Cwd::change_drive(d)"); 1810 { 1811 STRLEN n_a; 1812 char d = (char)*SvPV(ST(0),n_a); 1813 bool RETVAL; 1814 1815 RETVAL = change_drive(d); 1816 ST(0) = boolSV(RETVAL); 1817 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 1818 } 1819 XSRETURN(1); 1820 } 1821 1822 XS(XS_Cwd_sys_is_absolute) 1823 { 1824 dXSARGS; 1825 if (items != 1) 1826 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)"); 1827 { 1828 STRLEN n_a; 1829 char * path = (char *)SvPV(ST(0),n_a); 1830 bool RETVAL; 1831 1832 RETVAL = sys_is_absolute(path); 1833 ST(0) = boolSV(RETVAL); 1834 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 1835 } 1836 XSRETURN(1); 1837 } 1838 1839 XS(XS_Cwd_sys_is_rooted) 1840 { 1841 dXSARGS; 1842 if (items != 1) 1843 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)"); 1844 { 1845 STRLEN n_a; 1846 char * path = (char *)SvPV(ST(0),n_a); 1847 bool RETVAL; 1848 1849 RETVAL = sys_is_rooted(path); 1850 ST(0) = boolSV(RETVAL); 1851 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 1852 } 1853 XSRETURN(1); 1854 } 1855 1856 XS(XS_Cwd_sys_is_relative) 1857 { 1858 dXSARGS; 1859 if (items != 1) 1860 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)"); 1861 { 1862 STRLEN n_a; 1863 char * path = (char *)SvPV(ST(0),n_a); 1864 bool RETVAL; 1865 1866 RETVAL = sys_is_relative(path); 1867 ST(0) = boolSV(RETVAL); 1868 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 1869 } 1870 XSRETURN(1); 1871 } 1872 1873 XS(XS_Cwd_sys_cwd) 1874 { 1875 dXSARGS; 1876 if (items != 0) 1877 Perl_croak_nocontext("Usage: Cwd::sys_cwd()"); 1878 { 1879 char p[MAXPATHLEN]; 1880 char * RETVAL; 1881 RETVAL = _getcwd2(p, MAXPATHLEN); 1882 ST(0) = sv_newmortal(); 1883 sv_setpv((SV*)ST(0), RETVAL); 1884 } 1885 XSRETURN(1); 1886 } 1887 1888 XS(XS_Cwd_sys_abspath) 1889 { 1890 dXSARGS; 1891 if (items < 1 || items > 2) 1892 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)"); 1893 { 1894 STRLEN n_a; 1895 char * path = (char *)SvPV(ST(0),n_a); 1896 char * dir; 1897 char p[MAXPATHLEN]; 1898 char * RETVAL; 1899 1900 if (items < 2) 1901 dir = NULL; 1902 else { 1903 dir = (char *)SvPV(ST(1),n_a); 1904 } 1905 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) { 1906 path += 2; 1907 } 1908 if (dir == NULL) { 1909 if (_abspath(p, path, MAXPATHLEN) == 0) { 1910 RETVAL = p; 1911 } else { 1912 RETVAL = NULL; 1913 } 1914 } else { 1915 /* Absolute with drive: */ 1916 if ( sys_is_absolute(path) ) { 1917 if (_abspath(p, path, MAXPATHLEN) == 0) { 1918 RETVAL = p; 1919 } else { 1920 RETVAL = NULL; 1921 } 1922 } else if (path[0] == '/' || path[0] == '\\') { 1923 /* Rooted, but maybe on different drive. */ 1924 if (isALPHA(dir[0]) && dir[1] == ':' ) { 1925 char p1[MAXPATHLEN]; 1926 1927 /* Need to prepend the drive. */ 1928 p1[0] = dir[0]; 1929 p1[1] = dir[1]; 1930 Copy(path, p1 + 2, strlen(path) + 1, char); 1931 RETVAL = p; 1932 if (_abspath(p, p1, MAXPATHLEN) == 0) { 1933 RETVAL = p; 1934 } else { 1935 RETVAL = NULL; 1936 } 1937 } else if (_abspath(p, path, MAXPATHLEN) == 0) { 1938 RETVAL = p; 1939 } else { 1940 RETVAL = NULL; 1941 } 1942 } else { 1943 /* Either path is relative, or starts with a drive letter. */ 1944 /* If the path starts with a drive letter, then dir is 1945 relevant only if 1946 a/b) it is absolute/x:relative on the same drive. 1947 c) path is on current drive, and dir is rooted 1948 In all the cases it is safe to drop the drive part 1949 of the path. */ 1950 if ( !sys_is_relative(path) ) { 1951 int is_drived; 1952 1953 if ( ( ( sys_is_absolute(dir) 1954 || (isALPHA(dir[0]) && dir[1] == ':' 1955 && strnicmp(dir, path,1) == 0)) 1956 && strnicmp(dir, path,1) == 0) 1957 || ( !(isALPHA(dir[0]) && dir[1] == ':') 1958 && toupper(path[0]) == current_drive())) { 1959 path += 2; 1960 } else if (_abspath(p, path, MAXPATHLEN) == 0) { 1961 RETVAL = p; goto done; 1962 } else { 1963 RETVAL = NULL; goto done; 1964 } 1965 } 1966 { 1967 /* Need to prepend the absolute path of dir. */ 1968 char p1[MAXPATHLEN]; 1969 1970 if (_abspath(p1, dir, MAXPATHLEN) == 0) { 1971 int l = strlen(p1); 1972 1973 if (p1[ l - 1 ] != '/') { 1974 p1[ l ] = '/'; 1975 l++; 1976 } 1977 Copy(path, p1 + l, strlen(path) + 1, char); 1978 if (_abspath(p, p1, MAXPATHLEN) == 0) { 1979 RETVAL = p; 1980 } else { 1981 RETVAL = NULL; 1982 } 1983 } else { 1984 RETVAL = NULL; 1985 } 1986 } 1987 done: 1988 } 1989 } 1990 ST(0) = sv_newmortal(); 1991 sv_setpv((SV*)ST(0), RETVAL); 1992 } 1993 XSRETURN(1); 1994 } 1995 typedef APIRET (*PELP)(PSZ path, ULONG type); 1996 1997 APIRET 1998 ExtLIBPATH(ULONG ord, PSZ path, ULONG type) 1999 { 2000 loadByOrd("doscalls",ord); /* Guarantied to load or die! */ 2001 return (*(PELP)ExtFCN[ord])(path, type); 2002 } 2003 2004 #define extLibpath(type) \ 2005 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \ 2006 : BEGIN_LIBPATH))) \ 2007 ? NULL : to ) 2008 2009 #define extLibpath_set(p,type) \ 2010 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \ 2011 : BEGIN_LIBPATH)))) 2012 2013 XS(XS_Cwd_extLibpath) 2014 { 2015 dXSARGS; 2016 if (items < 0 || items > 1) 2017 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)"); 2018 { 2019 bool type; 2020 char to[1024]; 2021 U32 rc; 2022 char * RETVAL; 2023 2024 if (items < 1) 2025 type = 0; 2026 else { 2027 type = (int)SvIV(ST(0)); 2028 } 2029 2030 RETVAL = extLibpath(type); 2031 ST(0) = sv_newmortal(); 2032 sv_setpv((SV*)ST(0), RETVAL); 2033 } 2034 XSRETURN(1); 2035 } 2036 2037 XS(XS_Cwd_extLibpath_set) 2038 { 2039 dXSARGS; 2040 if (items < 1 || items > 2) 2041 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)"); 2042 { 2043 STRLEN n_a; 2044 char * s = (char *)SvPV(ST(0),n_a); 2045 bool type; 2046 U32 rc; 2047 bool RETVAL; 2048 2049 if (items < 2) 2050 type = 0; 2051 else { 2052 type = (int)SvIV(ST(1)); 2053 } 2054 2055 RETVAL = extLibpath_set(s, type); 2056 ST(0) = boolSV(RETVAL); 2057 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 2058 } 2059 XSRETURN(1); 2060 } 2061 2062 #define get_control87() _control87(0,0) 2063 #define set_control87 _control87 2064 2065 XS(XS_OS2__control87) 2066 { 2067 dXSARGS; 2068 if (items != 2) 2069 croak("Usage: OS2::_control87(new,mask)"); 2070 { 2071 unsigned new = (unsigned)SvIV(ST(0)); 2072 unsigned mask = (unsigned)SvIV(ST(1)); 2073 unsigned RETVAL; 2074 2075 RETVAL = _control87(new, mask); 2076 ST(0) = sv_newmortal(); 2077 sv_setiv(ST(0), (IV)RETVAL); 2078 } 2079 XSRETURN(1); 2080 } 2081 2082 XS(XS_OS2_get_control87) 2083 { 2084 dXSARGS; 2085 if (items != 0) 2086 croak("Usage: OS2::get_control87()"); 2087 { 2088 unsigned RETVAL; 2089 2090 RETVAL = get_control87(); 2091 ST(0) = sv_newmortal(); 2092 sv_setiv(ST(0), (IV)RETVAL); 2093 } 2094 XSRETURN(1); 2095 } 2096 2097 2098 XS(XS_OS2_set_control87) 2099 { 2100 dXSARGS; 2101 if (items < 0 || items > 2) 2102 croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)"); 2103 { 2104 unsigned new; 2105 unsigned mask; 2106 unsigned RETVAL; 2107 2108 if (items < 1) 2109 new = MCW_EM; 2110 else { 2111 new = (unsigned)SvIV(ST(0)); 2112 } 2113 2114 if (items < 2) 2115 mask = MCW_EM; 2116 else { 2117 mask = (unsigned)SvIV(ST(1)); 2118 } 2119 2120 RETVAL = set_control87(new, mask); 2121 ST(0) = sv_newmortal(); 2122 sv_setiv(ST(0), (IV)RETVAL); 2123 } 2124 XSRETURN(1); 2125 } 2126 2127 int 2128 Xs_OS2_init(pTHX) 2129 { 2130 char *file = __FILE__; 2131 { 2132 GV *gv; 2133 2134 if (_emx_env & 0x200) { /* OS/2 */ 2135 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); 2136 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); 2137 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file); 2138 } 2139 newXS("OS2::Error", XS_OS2_Error, file); 2140 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file); 2141 newXS("OS2::SysInfo", XS_OS2_SysInfo, file); 2142 newXS("OS2::BootDrive", XS_OS2_BootDrive, file); 2143 newXS("OS2::MorphPM", XS_OS2_MorphPM, file); 2144 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file); 2145 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file); 2146 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file); 2147 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file); 2148 newXS("Cwd::current_drive", XS_Cwd_current_drive, file); 2149 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file); 2150 newXS("Cwd::change_drive", XS_Cwd_change_drive, file); 2151 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file); 2152 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file); 2153 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file); 2154 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file); 2155 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file); 2156 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$"); 2157 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, ""); 2158 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$"); 2159 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); 2160 GvMULTI_on(gv); 2161 #ifdef PERL_IS_AOUT 2162 sv_setiv(GvSV(gv), 1); 2163 #endif 2164 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV); 2165 GvMULTI_on(gv); 2166 sv_setiv(GvSV(gv), _emx_rev); 2167 sv_setpv(GvSV(gv), _emx_vprt); 2168 SvIOK_on(GvSV(gv)); 2169 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV); 2170 GvMULTI_on(gv); 2171 sv_setiv(GvSV(gv), _emx_env); 2172 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV); 2173 GvMULTI_on(gv); 2174 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor); 2175 } 2176 } 2177 2178 OS2_Perl_data_t OS2_Perl_data; 2179 2180 void 2181 Perl_OS2_init(char **env) 2182 { 2183 char *shell; 2184 2185 MALLOC_INIT; 2186 settmppath(); 2187 OS2_Perl_data.xs_init = &Xs_OS2_init; 2188 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY); 2189 if (environ == NULL && env) { 2190 environ = env; 2191 } 2192 if ( (shell = getenv("PERL_SH_DRIVE")) ) { 2193 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char); 2194 strcpy(PL_sh_path, SH_PATH); 2195 PL_sh_path[0] = shell[0]; 2196 } else if ( (shell = getenv("PERL_SH_DIR")) ) { 2197 int l = strlen(shell), i; 2198 if (shell[l-1] == '/' || shell[l-1] == '\\') { 2199 l--; 2200 } 2201 New(1304, PL_sh_path, l + 8, char); 2202 strncpy(PL_sh_path, shell, l); 2203 strcpy(PL_sh_path + l, "/sh.exe"); 2204 for (i = 0; i < l; i++) { 2205 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/'; 2206 } 2207 } 2208 MUTEX_INIT(&start_thread_mutex); 2209 os2_mytype = my_type(); /* Do it before morphing. Needed? */ 2210 /* Some DLLs reset FP flags on load. We may have been linked with them */ 2211 _control87(MCW_EM, MCW_EM); 2212 } 2213 2214 #undef tmpnam 2215 #undef tmpfile 2216 2217 char * 2218 my_tmpnam (char *str) 2219 { 2220 char *p = getenv("TMP"), *tpath; 2221 int len; 2222 2223 if (!p) p = getenv("TEMP"); 2224 tpath = tempnam(p, "pltmp"); 2225 if (str && tpath) { 2226 strcpy(str, tpath); 2227 return str; 2228 } 2229 return tpath; 2230 } 2231 2232 FILE * 2233 my_tmpfile () 2234 { 2235 struct stat s; 2236 2237 stat(".", &s); 2238 if (s.st_mode & S_IWOTH) { 2239 return tmpfile(); 2240 } 2241 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but 2242 grants TMP. */ 2243 } 2244 2245 #undef rmdir 2246 2247 int 2248 my_rmdir (__const__ char *s) 2249 { 2250 char buf[MAXPATHLEN]; 2251 STRLEN l = strlen(s); 2252 2253 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX rmdir fails... */ 2254 strcpy(buf,s); 2255 buf[l - 1] = 0; 2256 s = buf; 2257 } 2258 return rmdir(s); 2259 } 2260 2261 #undef mkdir 2262 2263 int 2264 my_mkdir (__const__ char *s, long perm) 2265 { 2266 char buf[MAXPATHLEN]; 2267 STRLEN l = strlen(s); 2268 2269 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */ 2270 strcpy(buf,s); 2271 buf[l - 1] = 0; 2272 s = buf; 2273 } 2274 return mkdir(s, perm); 2275 } 2276 2277 #undef flock 2278 2279 /* This code was contributed by Rocco Caputo. */ 2280 int 2281 my_flock(int handle, int o) 2282 { 2283 FILELOCK rNull, rFull; 2284 ULONG timeout, handle_type, flag_word; 2285 APIRET rc; 2286 int blocking, shared; 2287 static int use_my = -1; 2288 2289 if (use_my == -1) { 2290 char *s = getenv("USE_PERL_FLOCK"); 2291 if (s) 2292 use_my = atoi(s); 2293 else 2294 use_my = 1; 2295 } 2296 if (!(_emx_env & 0x200) || !use_my) 2297 return flock(handle, o); /* Delegate to EMX. */ 2298 2299 // is this a file? 2300 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) || 2301 (handle_type & 0xFF)) 2302 { 2303 errno = EBADF; 2304 return -1; 2305 } 2306 // set lock/unlock ranges 2307 rNull.lOffset = rNull.lRange = rFull.lOffset = 0; 2308 rFull.lRange = 0x7FFFFFFF; 2309 // set timeout for blocking 2310 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1; 2311 // shared or exclusive? 2312 shared = (o & LOCK_SH) ? 1 : 0; 2313 // do not block the unlock 2314 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) { 2315 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared); 2316 switch (rc) { 2317 case 0: 2318 errno = 0; 2319 return 0; 2320 case ERROR_INVALID_HANDLE: 2321 errno = EBADF; 2322 return -1; 2323 case ERROR_SHARING_BUFFER_EXCEEDED: 2324 errno = ENOLCK; 2325 return -1; 2326 case ERROR_LOCK_VIOLATION: 2327 break; // not an error 2328 case ERROR_INVALID_PARAMETER: 2329 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: 2330 case ERROR_READ_LOCKS_NOT_SUPPORTED: 2331 errno = EINVAL; 2332 return -1; 2333 case ERROR_INTERRUPT: 2334 errno = EINTR; 2335 return -1; 2336 default: 2337 errno = EINVAL; 2338 return -1; 2339 } 2340 } 2341 // lock may block 2342 if (o & (LOCK_SH | LOCK_EX)) { 2343 // for blocking operations 2344 for (;;) { 2345 rc = 2346 DosSetFileLocks( 2347 handle, 2348 &rNull, 2349 &rFull, 2350 timeout, 2351 shared 2352 ); 2353 switch (rc) { 2354 case 0: 2355 errno = 0; 2356 return 0; 2357 case ERROR_INVALID_HANDLE: 2358 errno = EBADF; 2359 return -1; 2360 case ERROR_SHARING_BUFFER_EXCEEDED: 2361 errno = ENOLCK; 2362 return -1; 2363 case ERROR_LOCK_VIOLATION: 2364 if (!blocking) { 2365 errno = EWOULDBLOCK; 2366 return -1; 2367 } 2368 break; 2369 case ERROR_INVALID_PARAMETER: 2370 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: 2371 case ERROR_READ_LOCKS_NOT_SUPPORTED: 2372 errno = EINVAL; 2373 return -1; 2374 case ERROR_INTERRUPT: 2375 errno = EINTR; 2376 return -1; 2377 default: 2378 errno = EINVAL; 2379 return -1; 2380 } 2381 // give away timeslice 2382 DosSleep(1); 2383 } 2384 } 2385 2386 errno = 0; 2387 return 0; 2388 } 2389