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 #include <pwd.h> 25 #include <grp.h> 26 27 #define PERLIO_NOT_STDIO 0 28 29 #include "EXTERN.h" 30 #include "perl.h" 31 32 #ifdef USE_5005THREADS 33 34 typedef void (*emx_startroutine)(void *); 35 typedef void* (*pthreads_startroutine)(void *); 36 37 enum pthreads_state { 38 pthreads_st_none = 0, 39 pthreads_st_run, 40 pthreads_st_exited, 41 pthreads_st_detached, 42 pthreads_st_waited, 43 }; 44 const char *pthreads_states[] = { 45 "uninit", 46 "running", 47 "exited", 48 "detached", 49 "waited for", 50 }; 51 52 typedef struct { 53 void *status; 54 perl_cond cond; 55 enum pthreads_state state; 56 } thread_join_t; 57 58 thread_join_t *thread_join_data; 59 int thread_join_count; 60 perl_mutex start_thread_mutex; 61 62 int 63 pthread_join(perl_os_thread tid, void **status) 64 { 65 MUTEX_LOCK(&start_thread_mutex); 66 switch (thread_join_data[tid].state) { 67 case pthreads_st_exited: 68 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */ 69 MUTEX_UNLOCK(&start_thread_mutex); 70 *status = thread_join_data[tid].status; 71 break; 72 case pthreads_st_waited: 73 MUTEX_UNLOCK(&start_thread_mutex); 74 Perl_croak_nocontext("join with a thread with a waiter"); 75 break; 76 case pthreads_st_run: 77 thread_join_data[tid].state = pthreads_st_waited; 78 COND_INIT(&thread_join_data[tid].cond); 79 MUTEX_UNLOCK(&start_thread_mutex); 80 COND_WAIT(&thread_join_data[tid].cond, NULL); 81 COND_DESTROY(&thread_join_data[tid].cond); 82 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */ 83 *status = thread_join_data[tid].status; 84 break; 85 default: 86 MUTEX_UNLOCK(&start_thread_mutex); 87 Perl_croak_nocontext("join: unknown thread state: '%s'", 88 pthreads_states[thread_join_data[tid].state]); 89 break; 90 } 91 return 0; 92 } 93 94 void 95 pthread_startit(void *arg) 96 { 97 /* Thread is already started, we need to transfer control only */ 98 pthreads_startroutine start_routine = *((pthreads_startroutine*)arg); 99 int tid = pthread_self(); 100 void *retval; 101 102 arg = ((void**)arg)[1]; 103 if (tid >= thread_join_count) { 104 int oc = thread_join_count; 105 106 thread_join_count = tid + 5 + tid/5; 107 if (thread_join_data) { 108 Renew(thread_join_data, thread_join_count, thread_join_t); 109 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t); 110 } else { 111 Newz(1323, thread_join_data, thread_join_count, thread_join_t); 112 } 113 } 114 if (thread_join_data[tid].state != pthreads_st_none) 115 Perl_croak_nocontext("attempt to reuse thread id %i", tid); 116 thread_join_data[tid].state = pthreads_st_run; 117 /* Now that we copied/updated the guys, we may release the caller... */ 118 MUTEX_UNLOCK(&start_thread_mutex); 119 thread_join_data[tid].status = (*start_routine)(arg); 120 switch (thread_join_data[tid].state) { 121 case pthreads_st_waited: 122 COND_SIGNAL(&thread_join_data[tid].cond); 123 break; 124 default: 125 thread_join_data[tid].state = pthreads_st_exited; 126 break; 127 } 128 } 129 130 int 131 pthread_create(perl_os_thread *tid, const pthread_attr_t *attr, 132 void *(*start_routine)(void*), void *arg) 133 { 134 void *args[2]; 135 136 args[0] = (void*)start_routine; 137 args[1] = arg; 138 139 MUTEX_LOCK(&start_thread_mutex); 140 *tid = _beginthread(pthread_startit, /*stack*/ NULL, 141 /*stacksize*/ 10*1024*1024, (void*)args); 142 MUTEX_LOCK(&start_thread_mutex); 143 MUTEX_UNLOCK(&start_thread_mutex); 144 return *tid ? 0 : EINVAL; 145 } 146 147 int 148 pthread_detach(perl_os_thread tid) 149 { 150 MUTEX_LOCK(&start_thread_mutex); 151 switch (thread_join_data[tid].state) { 152 case pthreads_st_waited: 153 MUTEX_UNLOCK(&start_thread_mutex); 154 Perl_croak_nocontext("detach on a thread with a waiter"); 155 break; 156 case pthreads_st_run: 157 thread_join_data[tid].state = pthreads_st_detached; 158 MUTEX_UNLOCK(&start_thread_mutex); 159 break; 160 default: 161 MUTEX_UNLOCK(&start_thread_mutex); 162 Perl_croak_nocontext("detach: unknown thread state: '%s'", 163 pthreads_states[thread_join_data[tid].state]); 164 break; 165 } 166 return 0; 167 } 168 169 /* This is a very bastardized version: */ 170 int 171 os2_cond_wait(perl_cond *c, perl_mutex *m) 172 { 173 int rc; 174 STRLEN n_a; 175 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET)) 176 Perl_croak_nocontext("panic: COND_WAIT-reset: rc=%i", rc); 177 if (m) MUTEX_UNLOCK(m); 178 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT)) 179 && (rc != ERROR_INTERRUPT)) 180 Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc); 181 if (rc == ERROR_INTERRUPT) 182 errno = EINTR; 183 if (m) MUTEX_LOCK(m); 184 } 185 #endif 186 187 static int exe_is_aout(void); 188 189 /*****************************************************************************/ 190 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */ 191 #define C_ARR_LEN(sym) (sizeof(sym)/sizeof(*sym)) 192 193 struct dll_handle { 194 const char *modname; 195 HMODULE handle; 196 }; 197 static struct dll_handle doscalls_handle = {"doscalls", 0}; 198 static struct dll_handle tcp_handle = {"tcp32dll", 0}; 199 static struct dll_handle pmwin_handle = {"pmwin", 0}; 200 static struct dll_handle rexx_handle = {"rexx", 0}; 201 static struct dll_handle rexxapi_handle = {"rexxapi", 0}; 202 static struct dll_handle sesmgr_handle = {"sesmgr", 0}; 203 static struct dll_handle pmshapi_handle = {"pmshapi", 0}; 204 205 /* This should match enum entries_ordinals defined in os2ish.h. */ 206 static const struct { 207 struct dll_handle *dll; 208 const char *entryname; 209 int entrypoint; 210 } loadOrdinals[ORD_NENTRIES] = { 211 {&doscalls_handle, NULL, 874}, /* DosQueryExtLibpath */ 212 {&doscalls_handle, NULL, 873}, /* DosSetExtLibpath */ 213 {&doscalls_handle, NULL, 460}, /* DosVerifyPidTid */ 214 {&tcp_handle, "SETHOSTENT", 0}, 215 {&tcp_handle, "SETNETENT" , 0}, 216 {&tcp_handle, "SETPROTOENT", 0}, 217 {&tcp_handle, "SETSERVENT", 0}, 218 {&tcp_handle, "GETHOSTENT", 0}, 219 {&tcp_handle, "GETNETENT" , 0}, 220 {&tcp_handle, "GETPROTOENT", 0}, 221 {&tcp_handle, "GETSERVENT", 0}, 222 {&tcp_handle, "ENDHOSTENT", 0}, 223 {&tcp_handle, "ENDNETENT", 0}, 224 {&tcp_handle, "ENDPROTOENT", 0}, 225 {&tcp_handle, "ENDSERVENT", 0}, 226 {&pmwin_handle, NULL, 763}, /* WinInitialize */ 227 {&pmwin_handle, NULL, 716}, /* WinCreateMsgQueue */ 228 {&pmwin_handle, NULL, 726}, /* WinDestroyMsgQueue */ 229 {&pmwin_handle, NULL, 918}, /* WinPeekMsg */ 230 {&pmwin_handle, NULL, 915}, /* WinGetMsg */ 231 {&pmwin_handle, NULL, 912}, /* WinDispatchMsg */ 232 {&pmwin_handle, NULL, 753}, /* WinGetLastError */ 233 {&pmwin_handle, NULL, 705}, /* WinCancelShutdown */ 234 /* These are needed in extensions. 235 How to protect PMSHAPI: it comes through EMX functions? */ 236 {&rexx_handle, "RexxStart", 0}, 237 {&rexx_handle, "RexxVariablePool", 0}, 238 {&rexxapi_handle, "RexxRegisterFunctionExe", 0}, 239 {&rexxapi_handle, "RexxDeregisterFunction", 0}, 240 {&sesmgr_handle, "DOSSMSETTITLE", 0}, /* Would not work runtime-loaded */ 241 {&pmshapi_handle, "PRF32QUERYPROFILESIZE", 0}, 242 {&pmshapi_handle, "PRF32OPENPROFILE", 0}, 243 {&pmshapi_handle, "PRF32CLOSEPROFILE", 0}, 244 {&pmshapi_handle, "PRF32QUERYPROFILE", 0}, 245 {&pmshapi_handle, "PRF32RESET", 0}, 246 {&pmshapi_handle, "PRF32QUERYPROFILEDATA", 0}, 247 {&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0}, 248 249 /* At least some of these do not work by name, since they need 250 WIN32 instead of WIN... */ 251 #if 0 252 These were generated with 253 nm I:\emx\lib\os2.a | fgrep -f API-list | grep = > API-list-entries 254 perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( ORD_$1,)" API-list-entries > API-list-ORD_ 255 perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( {${2}_handle, NULL, $3},\t\t/* $1 */)" WinSwitch-API-list-entries >API-list-entry 256 #endif 257 {&pmshapi_handle, NULL, 123}, /* WinChangeSwitchEntry */ 258 {&pmshapi_handle, NULL, 124}, /* WinQuerySwitchEntry */ 259 {&pmshapi_handle, NULL, 125}, /* WinQuerySwitchHandle */ 260 {&pmshapi_handle, NULL, 126}, /* WinQuerySwitchList */ 261 {&pmshapi_handle, NULL, 131}, /* WinSwitchToProgram */ 262 {&pmwin_handle, NULL, 702}, /* WinBeginEnumWindows */ 263 {&pmwin_handle, NULL, 737}, /* WinEndEnumWindows */ 264 {&pmwin_handle, NULL, 740}, /* WinEnumDlgItem */ 265 {&pmwin_handle, NULL, 756}, /* WinGetNextWindow */ 266 {&pmwin_handle, NULL, 768}, /* WinIsChild */ 267 {&pmwin_handle, NULL, 799}, /* WinQueryActiveWindow */ 268 {&pmwin_handle, NULL, 805}, /* WinQueryClassName */ 269 {&pmwin_handle, NULL, 817}, /* WinQueryFocus */ 270 {&pmwin_handle, NULL, 834}, /* WinQueryWindow */ 271 {&pmwin_handle, NULL, 837}, /* WinQueryWindowPos */ 272 {&pmwin_handle, NULL, 838}, /* WinQueryWindowProcess */ 273 {&pmwin_handle, NULL, 841}, /* WinQueryWindowText */ 274 {&pmwin_handle, NULL, 842}, /* WinQueryWindowTextLength */ 275 {&pmwin_handle, NULL, 860}, /* WinSetFocus */ 276 {&pmwin_handle, NULL, 875}, /* WinSetWindowPos */ 277 {&pmwin_handle, NULL, 877}, /* WinSetWindowText */ 278 {&pmwin_handle, NULL, 883}, /* WinShowWindow */ 279 {&pmwin_handle, NULL, 772}, /* WinIsWindow */ 280 {&pmwin_handle, NULL, 899}, /* WinWindowFromId */ 281 {&pmwin_handle, NULL, 900}, /* WinWindowFromPoint */ 282 {&pmwin_handle, NULL, 919}, /* WinPostMsg */ 283 {&pmwin_handle, NULL, 735}, /* WinEnableWindow */ 284 {&pmwin_handle, NULL, 736}, /* WinEnableWindowUpdate */ 285 {&pmwin_handle, NULL, 773}, /* WinIsWindowEnabled */ 286 {&pmwin_handle, NULL, 774}, /* WinIsWindowShowing */ 287 {&pmwin_handle, NULL, 775}, /* WinIsWindowVisible */ 288 {&pmwin_handle, NULL, 839}, /* WinQueryWindowPtr */ 289 {&pmwin_handle, NULL, 843}, /* WinQueryWindowULong */ 290 {&pmwin_handle, NULL, 844}, /* WinQueryWindowUShort */ 291 {&pmwin_handle, NULL, 874}, /* WinSetWindowBits */ 292 {&pmwin_handle, NULL, 876}, /* WinSetWindowPtr */ 293 {&pmwin_handle, NULL, 878}, /* WinSetWindowULong */ 294 {&pmwin_handle, NULL, 879}, /* WinSetWindowUShort */ 295 {&pmwin_handle, NULL, 813}, /* WinQueryDesktopWindow */ 296 {&pmwin_handle, NULL, 851}, /* WinSetActiveWindow */ 297 {&doscalls_handle, NULL, 360}, /* DosQueryModFromEIP */ 298 }; 299 300 static PFN ExtFCN[C_ARR_LEN(loadOrdinals)]; /* Labeled by ord ORD_*. */ 301 const Perl_PFN * const pExtFCN = ExtFCN; 302 struct PMWIN_entries_t PMWIN_entries; 303 304 HMODULE 305 loadModule(const char *modname, int fail) 306 { 307 HMODULE h = (HMODULE)dlopen(modname, 0); 308 309 if (!h && fail) 310 Perl_croak_nocontext("Error loading module '%s': %s", 311 modname, dlerror()); 312 return h; 313 } 314 315 PFN 316 loadByOrdinal(enum entries_ordinals ord, int fail) 317 { 318 if (ExtFCN[ord] == NULL) { 319 PFN fcn = (PFN)-1; 320 APIRET rc; 321 322 if (!loadOrdinals[ord].dll->handle) 323 loadOrdinals[ord].dll->handle 324 = loadModule(loadOrdinals[ord].dll->modname, fail); 325 if (!loadOrdinals[ord].dll->handle) 326 return 0; /* Possible with FAIL==0 only */ 327 if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle, 328 loadOrdinals[ord].entrypoint, 329 loadOrdinals[ord].entryname,&fcn))) { 330 char buf[20], *s = (char*)loadOrdinals[ord].entryname; 331 332 if (!fail) 333 return 0; 334 if (!s) 335 sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint); 336 Perl_croak_nocontext( 337 "This version of OS/2 does not support %s.%s", 338 loadOrdinals[ord].dll->modname, s); 339 } 340 ExtFCN[ord] = fcn; 341 } 342 if ((long)ExtFCN[ord] == -1) 343 Perl_croak_nocontext("panic queryaddr"); 344 return ExtFCN[ord]; 345 } 346 347 void 348 init_PMWIN_entries(void) 349 { 350 int i; 351 352 for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++) 353 ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1); 354 } 355 356 /*****************************************************/ 357 /* socket forwarders without linking with tcpip DLLs */ 358 359 DeclFuncByORD(struct hostent *, gethostent, ORD_GETHOSTENT, (void), ()) 360 DeclFuncByORD(struct netent *, getnetent, ORD_GETNETENT, (void), ()) 361 DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ()) 362 DeclFuncByORD(struct servent *, getservent, ORD_GETSERVENT, (void), ()) 363 364 DeclVoidFuncByORD(sethostent, ORD_SETHOSTENT, (int x), (x)) 365 DeclVoidFuncByORD(setnetent, ORD_SETNETENT, (int x), (x)) 366 DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x)) 367 DeclVoidFuncByORD(setservent, ORD_SETSERVENT, (int x), (x)) 368 369 DeclVoidFuncByORD(endhostent, ORD_ENDHOSTENT, (void), ()) 370 DeclVoidFuncByORD(endnetent, ORD_ENDNETENT, (void), ()) 371 DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ()) 372 DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ()) 373 374 /* priorities */ 375 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, 376 self inverse. */ 377 #define QSS_INI_BUFFER 1024 378 379 ULONG (*pDosVerifyPidTid) (PID pid, TID tid); 380 static int pidtid_lookup; 381 382 PQTOPLEVEL 383 get_sysinfo(ULONG pid, ULONG flags) 384 { 385 char *pbuffer; 386 ULONG rc, buf_len = QSS_INI_BUFFER; 387 PQTOPLEVEL psi; 388 389 if (!pidtid_lookup) { 390 pidtid_lookup = 1; 391 *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0); 392 } 393 if (pDosVerifyPidTid) { /* Warp3 or later */ 394 /* Up to some fixpak QuerySysState() kills the system if a non-existent 395 pid is used. */ 396 if (CheckOSError(pDosVerifyPidTid(pid, 1))) 397 return 0; 398 } 399 New(1322, pbuffer, buf_len, char); 400 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */ 401 rc = QuerySysState(flags, pid, pbuffer, buf_len); 402 while (rc == ERROR_BUFFER_OVERFLOW) { 403 Renew(pbuffer, buf_len *= 2, char); 404 rc = QuerySysState(flags, pid, pbuffer, buf_len); 405 } 406 if (rc) { 407 FillOSError(rc); 408 Safefree(pbuffer); 409 return 0; 410 } 411 psi = (PQTOPLEVEL)pbuffer; 412 if (psi && pid && pid != psi->procdata->pid) { 413 Safefree(psi); 414 Perl_croak_nocontext("panic: wrong pid in sysinfo"); 415 } 416 return psi; 417 } 418 419 #define PRIO_ERR 0x1111 420 421 static ULONG 422 sys_prio(pid) 423 { 424 ULONG prio; 425 PQTOPLEVEL psi; 426 427 if (!pid) 428 return PRIO_ERR; 429 psi = get_sysinfo(pid, QSS_PROCESS); 430 if (!psi) 431 return PRIO_ERR; 432 prio = psi->procdata->threads->priority; 433 Safefree(psi); 434 return prio; 435 } 436 437 int 438 setpriority(int which, int pid, int val) 439 { 440 ULONG rc, prio = sys_prio(pid); 441 442 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ 443 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) { 444 /* Do not change class. */ 445 return CheckOSError(DosSetPriority((pid < 0) 446 ? PRTYS_PROCESSTREE : PRTYS_PROCESS, 447 0, 448 (32 - val) % 32 - (prio & 0xFF), 449 abs(pid))) 450 ? -1 : 0; 451 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ { 452 /* Documentation claims one can change both class and basevalue, 453 * but I find it wrong. */ 454 /* Change class, but since delta == 0 denotes absolute 0, correct. */ 455 if (CheckOSError(DosSetPriority((pid < 0) 456 ? PRTYS_PROCESSTREE : PRTYS_PROCESS, 457 priors[(32 - val) >> 5] + 1, 458 0, 459 abs(pid)))) 460 return -1; 461 if ( ((32 - val) % 32) == 0 ) return 0; 462 return CheckOSError(DosSetPriority((pid < 0) 463 ? PRTYS_PROCESSTREE : PRTYS_PROCESS, 464 0, 465 (32 - val) % 32, 466 abs(pid))) 467 ? -1 : 0; 468 } 469 } 470 471 int 472 getpriority(int which /* ignored */, int pid) 473 { 474 ULONG ret; 475 476 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ 477 ret = sys_prio(pid); 478 if (ret == PRIO_ERR) { 479 return -1; 480 } 481 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF); 482 } 483 484 /*****************************************************************************/ 485 /* spawn */ 486 487 int emx_runtime_init; /* If 1, we need to manually init it */ 488 int emx_exception_init; /* If 1, we need to manually set it */ 489 490 /* There is no big sense to make it thread-specific, since signals 491 are delivered to thread 1 only. XXXX Maybe make it into an array? */ 492 static int spawn_pid; 493 static int spawn_killed; 494 495 static Signal_t 496 spawn_sighandler(int sig) 497 { 498 /* Some programs do not arrange for the keyboard signals to be 499 delivered to them. We need to deliver the signal manually. */ 500 /* We may get a signal only if 501 a) kid does not receive keyboard signal: deliver it; 502 b) kid already died, and we get a signal. We may only hope 503 that the pid number was not reused. 504 */ 505 506 if (spawn_killed) 507 sig = SIGKILL; /* Try harder. */ 508 kill(spawn_pid, sig); 509 spawn_killed = 1; 510 } 511 512 static int 513 result(pTHX_ int flag, int pid) 514 { 515 int r, status; 516 Signal_t (*ihand)(); /* place to save signal during system() */ 517 Signal_t (*qhand)(); /* place to save signal during system() */ 518 #ifndef __EMX__ 519 RESULTCODES res; 520 int rpid; 521 #endif 522 523 if (pid < 0 || flag != 0) 524 return pid; 525 526 #ifdef __EMX__ 527 spawn_pid = pid; 528 spawn_killed = 0; 529 ihand = rsignal(SIGINT, &spawn_sighandler); 530 qhand = rsignal(SIGQUIT, &spawn_sighandler); 531 do { 532 r = wait4pid(pid, &status, 0); 533 } while (r == -1 && errno == EINTR); 534 rsignal(SIGINT, ihand); 535 rsignal(SIGQUIT, qhand); 536 537 PL_statusvalue = (U16)status; 538 if (r < 0) 539 return -1; 540 return status & 0xFFFF; 541 #else 542 ihand = rsignal(SIGINT, SIG_IGN); 543 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid); 544 rsignal(SIGINT, ihand); 545 PL_statusvalue = res.codeResult << 8 | res.codeTerminate; 546 if (r) 547 return -1; 548 return PL_statusvalue; 549 #endif 550 } 551 552 enum execf_t { 553 EXECF_SPAWN, 554 EXECF_EXEC, 555 EXECF_TRUEEXEC, 556 EXECF_SPAWN_NOWAIT, 557 EXECF_SPAWN_BYFLAG, 558 EXECF_SYNC 559 }; 560 561 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */ 562 563 static int 564 my_type() 565 { 566 int rc; 567 TIB *tib; 568 PIB *pib; 569 570 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */ 571 if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) 572 return -1; 573 574 return (pib->pib_ultype); 575 } 576 577 static ULONG 578 file_type(char *path) 579 { 580 int rc; 581 ULONG apptype; 582 583 if (!(_emx_env & 0x200)) 584 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */ 585 if (CheckOSError(DosQueryAppType(path, &apptype))) { 586 switch (rc) { 587 case ERROR_FILE_NOT_FOUND: 588 case ERROR_PATH_NOT_FOUND: 589 return -1; 590 case ERROR_ACCESS_DENIED: /* Directory with this name found? */ 591 return -3; 592 default: /* Found, but not an 593 executable, or some other 594 read error. */ 595 return -2; 596 } 597 } 598 return apptype; 599 } 600 601 static ULONG os2_mytype; 602 603 /* Spawn/exec a program, revert to shell if needed. */ 604 /* global PL_Argv[] contains arguments. */ 605 606 extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *, 607 EXCEPTIONREGISTRATIONRECORD *, 608 CONTEXTRECORD *, 609 void *); 610 611 int 612 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) 613 { 614 int trueflag = flag; 615 int rc, pass = 1; 616 char *tmps; 617 char *args[4]; 618 static char * fargs[4] 619 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", }; 620 char **argsp = fargs; 621 int nargs = 4; 622 int force_shell; 623 int new_stderr = -1, nostderr = 0; 624 int fl_stderr = 0; 625 STRLEN n_a; 626 char *buf; 627 PerlIO *file; 628 629 if (flag == P_WAIT) 630 flag = P_NOWAIT; 631 632 retry: 633 if (strEQ(PL_Argv[0],"/bin/sh")) 634 PL_Argv[0] = PL_sh_path; 635 636 /* We should check PERL_SH* and PERLLIB_* as well? */ 637 if (!really || !*(tmps = SvPV(really, n_a))) 638 tmps = PL_Argv[0]; 639 if (tmps[0] != '/' && tmps[0] != '\\' 640 && !(tmps[0] && tmps[1] == ':' 641 && (tmps[2] == '/' || tmps[2] != '\\')) 642 ) /* will spawnvp use PATH? */ 643 TAINT_ENV(); /* testing IFS here is overkill, probably */ 644 645 reread: 646 force_shell = 0; 647 if (_emx_env & 0x200) { /* OS/2. */ 648 int type = file_type(tmps); 649 type_again: 650 if (type == -1) { /* Not found */ 651 errno = ENOENT; 652 rc = -1; 653 goto do_script; 654 } 655 else if (type == -2) { /* Not an EXE */ 656 errno = ENOEXEC; 657 rc = -1; 658 goto do_script; 659 } 660 else if (type == -3) { /* Is a directory? */ 661 /* Special-case this */ 662 char tbuf[512]; 663 int l = strlen(tmps); 664 665 if (l + 5 <= sizeof tbuf) { 666 strcpy(tbuf, tmps); 667 strcpy(tbuf + l, ".exe"); 668 type = file_type(tbuf); 669 if (type >= -3) 670 goto type_again; 671 } 672 673 errno = ENOEXEC; 674 rc = -1; 675 goto do_script; 676 } 677 switch (type & 7) { 678 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */ 679 case FAPPTYP_WINDOWAPI: 680 { 681 if (os2_mytype != 3) { /* not PM */ 682 if (flag == P_NOWAIT) 683 flag = P_PM; 684 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION) 685 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d", 686 flag, os2_mytype); 687 } 688 } 689 break; 690 case FAPPTYP_NOTWINDOWCOMPAT: 691 { 692 if (os2_mytype != 0) { /* not full screen */ 693 if (flag == P_NOWAIT) 694 flag = P_SESSION; 695 else if ((flag & 7) != P_SESSION) 696 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d", 697 flag, os2_mytype); 698 } 699 } 700 break; 701 case FAPPTYP_NOTSPEC: 702 /* Let the shell handle this... */ 703 force_shell = 1; 704 buf = ""; /* Pacify a warning */ 705 file = 0; /* Pacify a warning */ 706 goto doshell_args; 707 break; 708 } 709 } 710 711 if (addflag) { 712 addflag = 0; 713 new_stderr = dup(2); /* Preserve stderr */ 714 if (new_stderr == -1) { 715 if (errno == EBADF) 716 nostderr = 1; 717 else { 718 rc = -1; 719 goto finish; 720 } 721 } else 722 fl_stderr = fcntl(2, F_GETFD); 723 rc = dup2(1,2); 724 if (rc == -1) 725 goto finish; 726 fcntl(new_stderr, F_SETFD, FD_CLOEXEC); 727 } 728 729 #if 0 730 rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv)); 731 #else 732 if (execf == EXECF_TRUEEXEC) 733 rc = execvp(tmps,PL_Argv); 734 else if (execf == EXECF_EXEC) 735 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv); 736 else if (execf == EXECF_SPAWN_NOWAIT) 737 rc = spawnvp(flag,tmps,PL_Argv); 738 else if (execf == EXECF_SYNC) 739 rc = spawnvp(trueflag,tmps,PL_Argv); 740 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */ 741 rc = result(aTHX_ trueflag, 742 spawnvp(flag,tmps,PL_Argv)); 743 #endif 744 if (rc < 0 && pass == 1 745 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */ 746 do_script: 747 { 748 int err = errno; 749 750 if (err == ENOENT || err == ENOEXEC) { 751 /* No such file, or is a script. */ 752 /* Try adding script extensions to the file name, and 753 search on PATH. */ 754 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0); 755 756 if (scr) { 757 char *s = 0, *s1; 758 SV *scrsv = sv_2mortal(newSVpv(scr, 0)); 759 SV *bufsv = sv_newmortal(); 760 761 Safefree(scr); 762 scr = SvPV(scrsv, n_a); /* free()ed later */ 763 764 file = PerlIO_open(scr, "r"); 765 PL_Argv[0] = scr; 766 if (!file) 767 goto panic_file; 768 769 buf = sv_gets(bufsv, file, 0 /* No append */); 770 if (!buf) 771 buf = ""; /* XXX Needed? */ 772 if (!buf[0]) { /* Empty... */ 773 PerlIO_close(file); 774 /* Special case: maybe from -Zexe build, so 775 there is an executable around (contrary to 776 documentation, DosQueryAppType sometimes (?) 777 does not append ".exe", so we could have 778 reached this place). */ 779 sv_catpv(scrsv, ".exe"); 780 scr = SvPV(scrsv, n_a); /* Reload */ 781 if (PerlLIO_stat(scr,&PL_statbuf) >= 0 782 && !S_ISDIR(PL_statbuf.st_mode)) { /* Found */ 783 tmps = scr; 784 pass++; 785 goto reread; 786 } else { /* Restore */ 787 SvCUR_set(scrsv, SvCUR(scrsv) - 4); 788 *SvEND(scrsv) = 0; 789 } 790 } 791 if (PerlIO_close(file) != 0) { /* Failure */ 792 panic_file: 793 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s", 794 scr, Strerror(errno)); 795 buf = ""; /* Not #! */ 796 goto doshell_args; 797 } 798 if (buf[0] == '#') { 799 if (buf[1] == '!') 800 s = buf + 2; 801 } else if (buf[0] == 'e') { 802 if (strnEQ(buf, "extproc", 7) 803 && isSPACE(buf[7])) 804 s = buf + 8; 805 } else if (buf[0] == 'E') { 806 if (strnEQ(buf, "EXTPROC", 7) 807 && isSPACE(buf[7])) 808 s = buf + 8; 809 } 810 if (!s) { 811 buf = ""; /* Not #! */ 812 goto doshell_args; 813 } 814 815 s1 = s; 816 nargs = 0; 817 argsp = args; 818 while (1) { 819 /* Do better than pdksh: allow a few args, 820 strip trailing whitespace. */ 821 while (isSPACE(*s)) 822 s++; 823 if (*s == 0) 824 break; 825 if (nargs == 4) { 826 nargs = -1; 827 break; 828 } 829 args[nargs++] = s; 830 while (*s && !isSPACE(*s)) 831 s++; 832 if (*s == 0) 833 break; 834 *s++ = 0; 835 } 836 if (nargs == -1) { 837 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"", 838 s1 - buf, buf, scr); 839 nargs = 4; 840 argsp = fargs; 841 } 842 /* Can jump from far, buf/file invalid if force_shell: */ 843 doshell_args: 844 { 845 char **a = PL_Argv; 846 char *exec_args[2]; 847 848 if (force_shell 849 || (!buf[0] && file)) { /* File without magic */ 850 /* In fact we tried all what pdksh would 851 try. There is no point in calling 852 pdksh, we may just emulate its logic. */ 853 char *shell = getenv("EXECSHELL"); 854 char *shell_opt = NULL; 855 856 if (!shell) { 857 char *s; 858 859 shell_opt = "/c"; 860 shell = getenv("OS2_SHELL"); 861 if (inicmd) { /* No spaces at start! */ 862 s = inicmd; 863 while (*s && !isSPACE(*s)) { 864 if (*s++ == '/') { 865 inicmd = NULL; /* Cannot use */ 866 break; 867 } 868 } 869 } 870 if (!inicmd) { 871 s = PL_Argv[0]; 872 while (*s) { 873 /* Dosish shells will choke on slashes 874 in paths, fortunately, this is 875 important for zeroth arg only. */ 876 if (*s == '/') 877 *s = '\\'; 878 s++; 879 } 880 } 881 } 882 /* If EXECSHELL is set, we do not set */ 883 884 if (!shell) 885 shell = ((_emx_env & 0x200) 886 ? "c:/os2/cmd.exe" 887 : "c:/command.com"); 888 nargs = shell_opt ? 2 : 1; /* shell file args */ 889 exec_args[0] = shell; 890 exec_args[1] = shell_opt; 891 argsp = exec_args; 892 if (nargs == 2 && inicmd) { 893 /* Use the original cmd line */ 894 /* XXXX This is good only until we refuse 895 quoted arguments... */ 896 PL_Argv[0] = inicmd; 897 PL_Argv[1] = Nullch; 898 } 899 } else if (!buf[0] && inicmd) { /* No file */ 900 /* Start with the original cmdline. */ 901 /* XXXX This is good only until we refuse 902 quoted arguments... */ 903 904 PL_Argv[0] = inicmd; 905 PL_Argv[1] = Nullch; 906 nargs = 2; /* shell -c */ 907 } 908 909 while (a[1]) /* Get to the end */ 910 a++; 911 a++; /* Copy finil NULL too */ 912 while (a >= PL_Argv) { 913 *(a + nargs) = *a; /* PL_Argv was preallocated to be 914 long enough. */ 915 a--; 916 } 917 while (--nargs >= 0) 918 PL_Argv[nargs] = argsp[nargs]; 919 /* Enable pathless exec if #! (as pdksh). */ 920 pass = (buf[0] == '#' ? 2 : 3); 921 goto retry; 922 } 923 } 924 /* Not found: restore errno */ 925 errno = err; 926 } 927 } 928 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */ 929 char *no_dir = strrchr(PL_Argv[0], '/'); 930 931 /* Do as pdksh port does: if not found with /, try without 932 path. */ 933 if (no_dir) { 934 PL_Argv[0] = no_dir + 1; 935 pass++; 936 goto retry; 937 } 938 } 939 if (rc < 0 && ckWARN(WARN_EXEC)) 940 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n", 941 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) 942 ? "spawn" : "exec"), 943 PL_Argv[0], Strerror(errno)); 944 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT) 945 && ((trueflag & 0xFF) == P_WAIT)) 946 rc = -1; 947 948 finish: 949 if (new_stderr != -1) { /* How can we use error codes? */ 950 dup2(new_stderr, 2); 951 close(new_stderr); 952 fcntl(2, F_SETFD, fl_stderr); 953 } else if (nostderr) 954 close(2); 955 return rc; 956 } 957 958 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */ 959 int 960 do_spawn3(pTHX_ char *cmd, int execf, int flag) 961 { 962 register char **a; 963 register char *s; 964 char *shell, *copt, *news = NULL; 965 int rc, seenspace = 0, mergestderr = 0; 966 967 #ifdef TRYSHELL 968 if ((shell = getenv("EMXSHELL")) != NULL) 969 copt = "-c"; 970 else if ((shell = getenv("SHELL")) != NULL) 971 copt = "-c"; 972 else if ((shell = getenv("COMSPEC")) != NULL) 973 copt = "/C"; 974 else 975 shell = "cmd.exe"; 976 #else 977 /* Consensus on perl5-porters is that it is _very_ important to 978 have a shell which will not change between computers with the 979 same architecture, to avoid "action on a distance". 980 And to have simple build, this shell should be sh. */ 981 shell = PL_sh_path; 982 copt = "-c"; 983 #endif 984 985 while (*cmd && isSPACE(*cmd)) 986 cmd++; 987 988 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) { 989 STRLEN l = strlen(PL_sh_path); 990 991 New(1302, news, strlen(cmd) - 7 + l + 1, char); 992 strcpy(news, PL_sh_path); 993 strcpy(news + l, cmd + 7); 994 cmd = news; 995 } 996 997 /* save an extra exec if possible */ 998 /* see if there are shell metacharacters in it */ 999 1000 if (*cmd == '.' && isSPACE(cmd[1])) 1001 goto doshell; 1002 1003 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) 1004 goto doshell; 1005 1006 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ 1007 if (*s == '=') 1008 goto doshell; 1009 1010 for (s = cmd; *s; s++) { 1011 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { 1012 if (*s == '\n' && s[1] == '\0') { 1013 *s = '\0'; 1014 break; 1015 } else if (*s == '\\' && !seenspace) { 1016 continue; /* Allow backslashes in names */ 1017 } else if (*s == '>' && s >= cmd + 3 1018 && s[-1] == '2' && s[1] == '&' && s[2] == '1' 1019 && isSPACE(s[-2]) ) { 1020 char *t = s + 3; 1021 1022 while (*t && isSPACE(*t)) 1023 t++; 1024 if (!*t) { 1025 s[-2] = '\0'; 1026 mergestderr = 1; 1027 break; /* Allow 2>&1 as the last thing */ 1028 } 1029 } 1030 /* We do not convert this to do_spawn_ve since shell 1031 should be smart enough to start itself gloriously. */ 1032 doshell: 1033 if (execf == EXECF_TRUEEXEC) 1034 rc = execl(shell,shell,copt,cmd,(char*)0); 1035 else if (execf == EXECF_EXEC) 1036 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0); 1037 else if (execf == EXECF_SPAWN_NOWAIT) 1038 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0); 1039 else if (execf == EXECF_SPAWN_BYFLAG) 1040 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0); 1041 else { 1042 /* In the ak code internal P_NOWAIT is P_WAIT ??? */ 1043 if (execf == EXECF_SYNC) 1044 rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0); 1045 else 1046 rc = result(aTHX_ P_WAIT, 1047 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); 1048 if (rc < 0 && ckWARN(WARN_EXEC)) 1049 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s", 1050 (execf == EXECF_SPAWN ? "spawn" : "exec"), 1051 shell, Strerror(errno)); 1052 if (rc < 0) 1053 rc = -1; 1054 } 1055 if (news) 1056 Safefree(news); 1057 return rc; 1058 } else if (*s == ' ' || *s == '\t') { 1059 seenspace = 1; 1060 } 1061 } 1062 1063 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */ 1064 New(1303,PL_Argv, (s - cmd + 11) / 2, char*); 1065 PL_Cmd = savepvn(cmd, s-cmd); 1066 a = PL_Argv; 1067 for (s = PL_Cmd; *s;) { 1068 while (*s && isSPACE(*s)) s++; 1069 if (*s) 1070 *(a++) = s; 1071 while (*s && !isSPACE(*s)) s++; 1072 if (*s) 1073 *s++ = '\0'; 1074 } 1075 *a = Nullch; 1076 if (PL_Argv[0]) 1077 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr); 1078 else 1079 rc = -1; 1080 if (news) 1081 Safefree(news); 1082 do_execfree(); 1083 return rc; 1084 } 1085 1086 /* Array spawn. */ 1087 int 1088 os2_do_aspawn(pTHX_ SV *really, register void **vmark, register void **vsp) 1089 { 1090 register SV **mark = (SV **)vmark; 1091 register SV **sp = (SV **)vsp; 1092 register char **a; 1093 int rc; 1094 int flag = P_WAIT, flag_set = 0; 1095 STRLEN n_a; 1096 1097 if (sp > mark) { 1098 New(1301,PL_Argv, sp - mark + 3, char*); 1099 a = PL_Argv; 1100 1101 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { 1102 ++mark; 1103 flag = SvIVx(*mark); 1104 flag_set = 1; 1105 1106 } 1107 1108 while (++mark <= sp) { 1109 if (*mark) 1110 *a++ = SvPVx(*mark, n_a); 1111 else 1112 *a++ = ""; 1113 } 1114 *a = Nullch; 1115 1116 if (flag_set && (a == PL_Argv + 1)) { /* One arg? */ 1117 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag); 1118 } else 1119 rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0); 1120 } else 1121 rc = -1; 1122 do_execfree(); 1123 return rc; 1124 } 1125 1126 int 1127 os2_do_spawn(pTHX_ char *cmd) 1128 { 1129 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0); 1130 } 1131 1132 int 1133 do_spawn_nowait(pTHX_ char *cmd) 1134 { 1135 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0); 1136 } 1137 1138 bool 1139 Perl_do_exec(pTHX_ char *cmd) 1140 { 1141 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0); 1142 return FALSE; 1143 } 1144 1145 bool 1146 os2exec(pTHX_ char *cmd) 1147 { 1148 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0); 1149 } 1150 1151 PerlIO * 1152 my_syspopen(pTHX_ char *cmd, char *mode) 1153 { 1154 #ifndef USE_POPEN 1155 int p[2]; 1156 register I32 this, that, newfd; 1157 register I32 pid; 1158 SV *sv; 1159 int fh_fl = 0; /* Pacify the warning */ 1160 1161 /* `this' is what we use in the parent, `that' in the child. */ 1162 this = (*mode == 'w'); 1163 that = !this; 1164 if (PL_tainting) { 1165 taint_env(); 1166 taint_proper("Insecure %s%s", "EXEC"); 1167 } 1168 if (pipe(p) < 0) 1169 return Nullfp; 1170 /* Now we need to spawn the child. */ 1171 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */ 1172 int new = dup(p[this]); 1173 1174 if (new == -1) 1175 goto closepipes; 1176 close(p[this]); 1177 p[this] = new; 1178 } 1179 newfd = dup(*mode == 'r'); /* Preserve std* */ 1180 if (newfd == -1) { 1181 /* This cannot happen due to fh being bad after pipe(), since 1182 pipe() should have created fh 0 and 1 even if they were 1183 initially closed. But we closed p[this] before. */ 1184 if (errno != EBADF) { 1185 closepipes: 1186 close(p[0]); 1187 close(p[1]); 1188 return Nullfp; 1189 } 1190 } else 1191 fh_fl = fcntl(*mode == 'r', F_GETFD); 1192 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */ 1193 dup2(p[that], *mode == 'r'); 1194 close(p[that]); 1195 } 1196 /* Where is `this' and newfd now? */ 1197 fcntl(p[this], F_SETFD, FD_CLOEXEC); 1198 if (newfd != -1) 1199 fcntl(newfd, F_SETFD, FD_CLOEXEC); 1200 pid = do_spawn_nowait(aTHX_ cmd); 1201 if (newfd == -1) 1202 close(*mode == 'r'); /* It was closed initially */ 1203 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */ 1204 dup2(newfd, *mode == 'r'); /* Return std* back. */ 1205 close(newfd); 1206 fcntl(*mode == 'r', F_SETFD, fh_fl); 1207 } else 1208 fcntl(*mode == 'r', F_SETFD, fh_fl); 1209 if (p[that] == (*mode == 'r')) 1210 close(p[that]); 1211 if (pid == -1) { 1212 close(p[this]); 1213 return Nullfp; 1214 } 1215 if (p[that] < p[this]) { /* Make fh as small as possible */ 1216 dup2(p[this], p[that]); 1217 close(p[this]); 1218 p[this] = p[that]; 1219 } 1220 sv = *av_fetch(PL_fdpid,p[this],TRUE); 1221 (void)SvUPGRADE(sv,SVt_IV); 1222 SvIVX(sv) = pid; 1223 PL_forkprocess = pid; 1224 return PerlIO_fdopen(p[this], mode); 1225 1226 #else /* USE_POPEN */ 1227 1228 PerlIO *res; 1229 SV *sv; 1230 1231 # ifdef TRYSHELL 1232 res = popen(cmd, mode); 1233 # else 1234 char *shell = getenv("EMXSHELL"); 1235 1236 my_setenv("EMXSHELL", PL_sh_path); 1237 res = popen(cmd, mode); 1238 my_setenv("EMXSHELL", shell); 1239 # endif 1240 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE); 1241 (void)SvUPGRADE(sv,SVt_IV); 1242 SvIVX(sv) = -1; /* A cooky. */ 1243 return res; 1244 1245 #endif /* USE_POPEN */ 1246 1247 } 1248 1249 /******************************************************************/ 1250 1251 #ifndef HAS_FORK 1252 int 1253 fork(void) 1254 { 1255 Perl_croak_nocontext(PL_no_func, "Unsupported function fork"); 1256 errno = EINVAL; 1257 return -1; 1258 } 1259 #endif 1260 1261 /*******************************************************************/ 1262 /* not implemented in EMX 0.9d */ 1263 1264 char * ctermid(char *s) { return 0; } 1265 1266 #ifdef MYTTYNAME /* was not in emx0.9a */ 1267 void * ttyname(x) { return 0; } 1268 #endif 1269 1270 /*****************************************************************************/ 1271 /* not implemented in C Set++ */ 1272 1273 #ifndef __EMX__ 1274 int setuid(x) { errno = EINVAL; return -1; } 1275 int setgid(x) { errno = EINVAL; return -1; } 1276 #endif 1277 1278 /*****************************************************************************/ 1279 /* stat() hack for char/block device */ 1280 1281 #if OS2_STAT_HACK 1282 1283 /* First attempt used DosQueryFSAttach which crashed the system when 1284 used with 5.001. Now just look for /dev/. */ 1285 1286 int 1287 os2_stat(const char *name, struct stat *st) 1288 { 1289 static int ino = SHRT_MAX; 1290 1291 if (stricmp(name, "/dev/con") != 0 1292 && stricmp(name, "/dev/tty") != 0) 1293 return stat(name, st); 1294 1295 memset(st, 0, sizeof *st); 1296 st->st_mode = S_IFCHR|0666; 1297 st->st_ino = (ino-- & 0x7FFF); 1298 st->st_nlink = 1; 1299 return 0; 1300 } 1301 1302 #endif 1303 1304 #ifdef USE_PERL_SBRK 1305 1306 /* SBRK() emulation, mostly moved to malloc.c. */ 1307 1308 void * 1309 sys_alloc(int size) { 1310 void *got; 1311 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE); 1312 1313 if (rc == ERROR_NOT_ENOUGH_MEMORY) { 1314 return (void *) -1; 1315 } else if ( rc ) 1316 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc); 1317 return got; 1318 } 1319 1320 #endif /* USE_PERL_SBRK */ 1321 1322 /* tmp path */ 1323 1324 char *tmppath = TMPPATH1; 1325 1326 void 1327 settmppath() 1328 { 1329 char *p = getenv("TMP"), *tpath; 1330 int len; 1331 1332 if (!p) p = getenv("TEMP"); 1333 if (!p) return; 1334 len = strlen(p); 1335 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2); 1336 if (tpath) { 1337 strcpy(tpath, p); 1338 tpath[len] = '/'; 1339 strcpy(tpath + len + 1, TMPPATH1); 1340 tmppath = tpath; 1341 } 1342 } 1343 1344 #include "XSUB.h" 1345 1346 XS(XS_File__Copy_syscopy) 1347 { 1348 dXSARGS; 1349 if (items < 2 || items > 3) 1350 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)"); 1351 { 1352 STRLEN n_a; 1353 char * src = (char *)SvPV(ST(0),n_a); 1354 char * dst = (char *)SvPV(ST(1),n_a); 1355 U32 flag; 1356 int RETVAL, rc; 1357 1358 if (items < 3) 1359 flag = 0; 1360 else { 1361 flag = (unsigned long)SvIV(ST(2)); 1362 } 1363 1364 RETVAL = !CheckOSError(DosCopy(src, dst, flag)); 1365 ST(0) = sv_newmortal(); 1366 sv_setiv(ST(0), (IV)RETVAL); 1367 } 1368 XSRETURN(1); 1369 } 1370 1371 #define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */ 1372 #include "patchlevel.h" 1373 #undef PERL_PATCHLEVEL_H_IMPLICIT 1374 1375 char * 1376 mod2fname(pTHX_ SV *sv) 1377 { 1378 static char fname[9]; 1379 int pos = 6, len, avlen; 1380 unsigned int sum = 0; 1381 char *s; 1382 STRLEN n_a; 1383 1384 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname"); 1385 sv = SvRV(sv); 1386 if (SvTYPE(sv) != SVt_PVAV) 1387 Perl_croak_nocontext("Not array reference given to mod2fname"); 1388 1389 avlen = av_len((AV*)sv); 1390 if (avlen < 0) 1391 Perl_croak_nocontext("Empty array reference given to mod2fname"); 1392 1393 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); 1394 strncpy(fname, s, 8); 1395 len = strlen(s); 1396 if (len < 6) pos = len; 1397 while (*s) { 1398 sum = 33 * sum + *(s++); /* Checksumming first chars to 1399 * get the capitalization into c.s. */ 1400 } 1401 avlen --; 1402 while (avlen >= 0) { 1403 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); 1404 while (*s) { 1405 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */ 1406 } 1407 avlen --; 1408 } 1409 #ifdef USE_5005THREADS 1410 sum++; /* Avoid conflict of DLLs in memory. */ 1411 #endif 1412 /* We always load modules as *specific* DLLs, and with the full name. 1413 When loading a specific DLL by its full name, one cannot get a 1414 different DLL, even if a DLL with the same basename is loaded already. 1415 Thus there is no need to include the version into the mangling scheme. */ 1416 #if 0 1417 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */ 1418 #else 1419 # ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */ 1420 # define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2) 1421 # endif 1422 sum += COMPATIBLE_VERSION_SUM; 1423 #endif 1424 fname[pos] = 'A' + (sum % 26); 1425 fname[pos + 1] = 'A' + (sum / 26 % 26); 1426 fname[pos + 2] = '\0'; 1427 return (char *)fname; 1428 } 1429 1430 XS(XS_DynaLoader_mod2fname) 1431 { 1432 dXSARGS; 1433 if (items != 1) 1434 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)"); 1435 { 1436 SV * sv = ST(0); 1437 char * RETVAL; 1438 1439 RETVAL = mod2fname(aTHX_ sv); 1440 ST(0) = sv_newmortal(); 1441 sv_setpv((SV*)ST(0), RETVAL); 1442 } 1443 XSRETURN(1); 1444 } 1445 1446 char * 1447 os2error(int rc) 1448 { 1449 static char buf[300]; 1450 ULONG len; 1451 char *s; 1452 int number = SvTRUE(get_sv("OS2::nsyserror", TRUE)); 1453 1454 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */ 1455 if (rc == 0) 1456 return ""; 1457 if (number) { 1458 sprintf(buf, "SYS%04d=%#x: ", rc, rc); 1459 s = buf + strlen(buf); 1460 } else 1461 s = buf; 1462 if (DosGetMessage(NULL, 0, s, sizeof(buf) - 1 - (s-buf), 1463 rc, "OSO001.MSG", &len)) { 1464 if (!number) { 1465 sprintf(buf, "SYS%04d=%#x: ", rc, rc); 1466 s = buf + strlen(buf); 1467 } 1468 sprintf(s, "[No description found in OSO001.MSG]"); 1469 } else { 1470 s[len] = '\0'; 1471 if (len && s[len - 1] == '\n') 1472 s[--len] = 0; 1473 if (len && s[len - 1] == '\r') 1474 s[--len] = 0; 1475 if (len && s[len - 1] == '.') 1476 s[--len] = 0; 1477 if (len >= 10 && number && strnEQ(s, buf, 7) 1478 && s[7] == ':' && s[8] == ' ') 1479 /* Some messages start with SYSdddd:, some not */ 1480 Move(s + 9, s, (len -= 9) + 1, char); 1481 } 1482 return buf; 1483 } 1484 1485 void 1486 ResetWinError(void) 1487 { 1488 WinError_2_Perl_rc; 1489 } 1490 1491 void 1492 CroakWinError(int die, char *name) 1493 { 1494 FillWinError; 1495 if (die && Perl_rc) 1496 croak("%s: %s", (name ? name : "Win* API call"), os2error(Perl_rc)); 1497 } 1498 1499 char * 1500 os2_execname(pTHX) 1501 { 1502 char buf[300], *p, *o = PL_origargv[0], ok = 1; 1503 1504 if (_execname(buf, sizeof buf) != 0) 1505 return o; 1506 p = buf; 1507 while (*p) { 1508 if (*p == '\\') 1509 *p = '/'; 1510 if (*p == '/') { 1511 if (ok && *o != '/' && *o != '\\') 1512 ok = 0; 1513 } else if (ok && tolower(*o) != tolower(*p)) 1514 ok = 0; 1515 p++; 1516 o++; 1517 } 1518 if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */ 1519 strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */ 1520 p = buf; 1521 while (*p) { 1522 if (*p == '\\') 1523 *p = '/'; 1524 p++; 1525 } 1526 } 1527 p = savepv(buf); 1528 SAVEFREEPV(p); 1529 return p; 1530 } 1531 1532 char * 1533 perllib_mangle(char *s, unsigned int l) 1534 { 1535 static char *newp, *oldp; 1536 static int newl, oldl, notfound; 1537 static char ret[STATIC_FILE_LENGTH+1]; 1538 1539 if (!newp && !notfound) { 1540 newp = getenv("PERLLIB_PREFIX"); 1541 if (newp) { 1542 char *s; 1543 1544 oldp = newp; 1545 while (*newp && !isSPACE(*newp) && *newp != ';') { 1546 newp++; oldl++; /* Skip digits. */ 1547 } 1548 while (*newp && (isSPACE(*newp) || *newp == ';')) { 1549 newp++; /* Skip whitespace. */ 1550 } 1551 newl = strlen(newp); 1552 if (newl == 0 || oldl == 0) { 1553 Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); 1554 } 1555 strcpy(ret, newp); 1556 s = ret; 1557 while (*s) { 1558 if (*s == '\\') *s = '/'; 1559 s++; 1560 } 1561 } else { 1562 notfound = 1; 1563 } 1564 } 1565 if (!newp) { 1566 return s; 1567 } 1568 if (l == 0) { 1569 l = strlen(s); 1570 } 1571 if (l < oldl || strnicmp(oldp, s, oldl) != 0) { 1572 return s; 1573 } 1574 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) { 1575 Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); 1576 } 1577 strcpy(ret + newl, s + oldl); 1578 return ret; 1579 } 1580 1581 unsigned long 1582 Perl_hab_GET() /* Needed if perl.h cannot be included */ 1583 { 1584 return perl_hab_GET(); 1585 } 1586 1587 HMQ 1588 Perl_Register_MQ(int serve) 1589 { 1590 PPIB pib; 1591 PTIB tib; 1592 1593 if (Perl_hmq_refcnt > 0) 1594 return Perl_hmq; 1595 Perl_hmq_refcnt = 0; /* Be extra safe */ 1596 DosGetInfoBlocks(&tib, &pib); 1597 Perl_os2_initial_mode = pib->pib_ultype; 1598 /* Try morphing into a PM application. */ 1599 if (pib->pib_ultype != 3) /* 2 is VIO */ 1600 pib->pib_ultype = 3; /* 3 is PM */ 1601 init_PMWIN_entries(); 1602 /* 64 messages if before OS/2 3.0, ignored otherwise */ 1603 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64); 1604 if (!Perl_hmq) { 1605 static int cnt; 1606 1607 SAVEINT(cnt); /* Allow catch()ing. */ 1608 if (cnt++) 1609 _exit(188); /* Panic can try to create a window. */ 1610 Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application"); 1611 } 1612 if (serve) { 1613 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */ 1614 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */ 1615 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0); 1616 Perl_hmq_servers++; 1617 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */ 1618 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); 1619 Perl_hmq_refcnt++; 1620 return Perl_hmq; 1621 } 1622 1623 int 1624 Perl_Serve_Messages(int force) 1625 { 1626 int cnt = 0; 1627 QMSG msg; 1628 1629 if (Perl_hmq_servers > 0 && !force) 1630 return 0; 1631 if (Perl_hmq_refcnt <= 0) 1632 Perl_croak_nocontext("No message queue"); 1633 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) { 1634 cnt++; 1635 if (msg.msg == WM_QUIT) 1636 Perl_croak_nocontext("QUITing..."); 1637 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); 1638 } 1639 return cnt; 1640 } 1641 1642 int 1643 Perl_Process_Messages(int force, I32 *cntp) 1644 { 1645 QMSG msg; 1646 1647 if (Perl_hmq_servers > 0 && !force) 1648 return 0; 1649 if (Perl_hmq_refcnt <= 0) 1650 Perl_croak_nocontext("No message queue"); 1651 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) { 1652 if (cntp) 1653 (*cntp)++; 1654 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); 1655 if (msg.msg == WM_DESTROY) 1656 return -1; 1657 if (msg.msg == WM_CREATE) 1658 return +1; 1659 } 1660 Perl_croak_nocontext("QUITing..."); 1661 } 1662 1663 void 1664 Perl_Deregister_MQ(int serve) 1665 { 1666 PPIB pib; 1667 PTIB tib; 1668 1669 if (serve) 1670 Perl_hmq_servers--; 1671 if (--Perl_hmq_refcnt <= 0) { 1672 init_PMWIN_entries(); /* To be extra safe */ 1673 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq); 1674 Perl_hmq = 0; 1675 /* Try morphing back from a PM application. */ 1676 DosGetInfoBlocks(&tib, &pib); 1677 if (pib->pib_ultype == 3) /* 3 is PM */ 1678 pib->pib_ultype = Perl_os2_initial_mode; 1679 else 1680 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM", 1681 pib->pib_ultype); 1682 } else if (serve && Perl_hmq_servers <= 0) /* Last server exited */ 1683 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); 1684 } 1685 1686 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \ 1687 && ((path)[2] == '/' || (path)[2] == '\\')) 1688 #define sys_is_rooted _fnisabs 1689 #define sys_is_relative _fnisrel 1690 #define current_drive _getdrive 1691 1692 #undef chdir /* Was _chdir2. */ 1693 #define sys_chdir(p) (chdir(p) == 0) 1694 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d))) 1695 1696 static int DOS_harderr_state = -1; 1697 1698 XS(XS_OS2_Error) 1699 { 1700 dXSARGS; 1701 if (items != 2) 1702 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)"); 1703 { 1704 int arg1 = SvIV(ST(0)); 1705 int arg2 = SvIV(ST(1)); 1706 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR) 1707 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION)); 1708 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0)); 1709 unsigned long rc; 1710 1711 if (CheckOSError(DosError(a))) 1712 Perl_croak_nocontext("DosError(%d) failed", a); 1713 ST(0) = sv_newmortal(); 1714 if (DOS_harderr_state >= 0) 1715 sv_setiv(ST(0), DOS_harderr_state); 1716 DOS_harderr_state = RETVAL; 1717 } 1718 XSRETURN(1); 1719 } 1720 1721 static signed char DOS_suppression_state = -1; 1722 1723 XS(XS_OS2_Errors2Drive) 1724 { 1725 dXSARGS; 1726 if (items != 1) 1727 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)"); 1728 { 1729 STRLEN n_a; 1730 SV *sv = ST(0); 1731 int suppress = SvOK(sv); 1732 char *s = suppress ? SvPV(sv, n_a) : NULL; 1733 char drive = (s ? *s : 0); 1734 unsigned long rc; 1735 1736 if (suppress && !isALPHA(drive)) 1737 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive); 1738 if (CheckOSError(DosSuppressPopUps((suppress 1739 ? SPU_ENABLESUPPRESSION 1740 : SPU_DISABLESUPPRESSION), 1741 drive))) 1742 Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive); 1743 ST(0) = sv_newmortal(); 1744 if (DOS_suppression_state > 0) 1745 sv_setpvn(ST(0), &DOS_suppression_state, 1); 1746 else if (DOS_suppression_state == 0) 1747 sv_setpvn(ST(0), "", 0); 1748 DOS_suppression_state = drive; 1749 } 1750 XSRETURN(1); 1751 } 1752 1753 static const char * const si_fields[QSV_MAX] = { 1754 "MAX_PATH_LENGTH", 1755 "MAX_TEXT_SESSIONS", 1756 "MAX_PM_SESSIONS", 1757 "MAX_VDM_SESSIONS", 1758 "BOOT_DRIVE", 1759 "DYN_PRI_VARIATION", 1760 "MAX_WAIT", 1761 "MIN_SLICE", 1762 "MAX_SLICE", 1763 "PAGE_SIZE", 1764 "VERSION_MAJOR", 1765 "VERSION_MINOR", 1766 "VERSION_REVISION", 1767 "MS_COUNT", 1768 "TIME_LOW", 1769 "TIME_HIGH", 1770 "TOTPHYSMEM", 1771 "TOTRESMEM", 1772 "TOTAVAILMEM", 1773 "MAXPRMEM", 1774 "MAXSHMEM", 1775 "TIMER_INTERVAL", 1776 "MAX_COMP_LENGTH", 1777 "FOREGROUND_FS_SESSION", 1778 "FOREGROUND_PROCESS" 1779 }; 1780 1781 XS(XS_OS2_SysInfo) 1782 { 1783 dXSARGS; 1784 if (items != 0) 1785 Perl_croak_nocontext("Usage: OS2::SysInfo()"); 1786 { 1787 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */ 1788 APIRET rc = NO_ERROR; /* Return code */ 1789 int i = 0, j = 0; 1790 1791 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */ 1792 QSV_MAX, /* information */ 1793 (PVOID)si, 1794 sizeof(si)))) 1795 Perl_croak_nocontext("DosQuerySysInfo() failed"); 1796 EXTEND(SP,2*QSV_MAX); 1797 while (i < QSV_MAX) { 1798 ST(j) = sv_newmortal(); 1799 sv_setpv(ST(j++), si_fields[i]); 1800 ST(j) = sv_newmortal(); 1801 sv_setiv(ST(j++), si[i]); 1802 i++; 1803 } 1804 } 1805 XSRETURN(2 * QSV_MAX); 1806 } 1807 1808 XS(XS_OS2_BootDrive) 1809 { 1810 dXSARGS; 1811 if (items != 0) 1812 Perl_croak_nocontext("Usage: OS2::BootDrive()"); 1813 { 1814 ULONG si[1] = {0}; /* System Information Data Buffer */ 1815 APIRET rc = NO_ERROR; /* Return code */ 1816 char c; 1817 1818 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE, 1819 (PVOID)si, sizeof(si)))) 1820 Perl_croak_nocontext("DosQuerySysInfo() failed"); 1821 ST(0) = sv_newmortal(); 1822 c = 'a' - 1 + si[0]; 1823 sv_setpvn(ST(0), &c, 1); 1824 } 1825 XSRETURN(1); 1826 } 1827 1828 XS(XS_OS2_MorphPM) 1829 { 1830 dXSARGS; 1831 if (items != 1) 1832 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)"); 1833 { 1834 bool serve = SvOK(ST(0)); 1835 unsigned long pmq = perl_hmq_GET(serve); 1836 1837 ST(0) = sv_newmortal(); 1838 sv_setiv(ST(0), pmq); 1839 } 1840 XSRETURN(1); 1841 } 1842 1843 XS(XS_OS2_UnMorphPM) 1844 { 1845 dXSARGS; 1846 if (items != 1) 1847 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)"); 1848 { 1849 bool serve = SvOK(ST(0)); 1850 1851 perl_hmq_UNSET(serve); 1852 } 1853 XSRETURN(0); 1854 } 1855 1856 XS(XS_OS2_Serve_Messages) 1857 { 1858 dXSARGS; 1859 if (items != 1) 1860 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)"); 1861 { 1862 bool force = SvOK(ST(0)); 1863 unsigned long cnt = Perl_Serve_Messages(force); 1864 1865 ST(0) = sv_newmortal(); 1866 sv_setiv(ST(0), cnt); 1867 } 1868 XSRETURN(1); 1869 } 1870 1871 XS(XS_OS2_Process_Messages) 1872 { 1873 dXSARGS; 1874 if (items < 1 || items > 2) 1875 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])"); 1876 { 1877 bool force = SvOK(ST(0)); 1878 unsigned long cnt; 1879 1880 if (items == 2) { 1881 I32 cntr; 1882 SV *sv = ST(1); 1883 1884 (void)SvIV(sv); /* Force SvIVX */ 1885 if (!SvIOK(sv)) 1886 Perl_croak_nocontext("Can't upgrade count to IV"); 1887 cntr = SvIVX(sv); 1888 cnt = Perl_Process_Messages(force, &cntr); 1889 SvIVX(sv) = cntr; 1890 } else { 1891 cnt = Perl_Process_Messages(force, NULL); 1892 } 1893 ST(0) = sv_newmortal(); 1894 sv_setiv(ST(0), cnt); 1895 } 1896 XSRETURN(1); 1897 } 1898 1899 XS(XS_Cwd_current_drive) 1900 { 1901 dXSARGS; 1902 if (items != 0) 1903 Perl_croak_nocontext("Usage: Cwd::current_drive()"); 1904 { 1905 char RETVAL; 1906 1907 RETVAL = current_drive(); 1908 ST(0) = sv_newmortal(); 1909 sv_setpvn(ST(0), (char *)&RETVAL, 1); 1910 } 1911 XSRETURN(1); 1912 } 1913 1914 XS(XS_Cwd_sys_chdir) 1915 { 1916 dXSARGS; 1917 if (items != 1) 1918 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)"); 1919 { 1920 STRLEN n_a; 1921 char * path = (char *)SvPV(ST(0),n_a); 1922 bool RETVAL; 1923 1924 RETVAL = sys_chdir(path); 1925 ST(0) = boolSV(RETVAL); 1926 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 1927 } 1928 XSRETURN(1); 1929 } 1930 1931 XS(XS_Cwd_change_drive) 1932 { 1933 dXSARGS; 1934 if (items != 1) 1935 Perl_croak_nocontext("Usage: Cwd::change_drive(d)"); 1936 { 1937 STRLEN n_a; 1938 char d = (char)*SvPV(ST(0),n_a); 1939 bool RETVAL; 1940 1941 RETVAL = change_drive(d); 1942 ST(0) = boolSV(RETVAL); 1943 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 1944 } 1945 XSRETURN(1); 1946 } 1947 1948 XS(XS_Cwd_sys_is_absolute) 1949 { 1950 dXSARGS; 1951 if (items != 1) 1952 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)"); 1953 { 1954 STRLEN n_a; 1955 char * path = (char *)SvPV(ST(0),n_a); 1956 bool RETVAL; 1957 1958 RETVAL = sys_is_absolute(path); 1959 ST(0) = boolSV(RETVAL); 1960 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 1961 } 1962 XSRETURN(1); 1963 } 1964 1965 XS(XS_Cwd_sys_is_rooted) 1966 { 1967 dXSARGS; 1968 if (items != 1) 1969 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)"); 1970 { 1971 STRLEN n_a; 1972 char * path = (char *)SvPV(ST(0),n_a); 1973 bool RETVAL; 1974 1975 RETVAL = sys_is_rooted(path); 1976 ST(0) = boolSV(RETVAL); 1977 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 1978 } 1979 XSRETURN(1); 1980 } 1981 1982 XS(XS_Cwd_sys_is_relative) 1983 { 1984 dXSARGS; 1985 if (items != 1) 1986 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)"); 1987 { 1988 STRLEN n_a; 1989 char * path = (char *)SvPV(ST(0),n_a); 1990 bool RETVAL; 1991 1992 RETVAL = sys_is_relative(path); 1993 ST(0) = boolSV(RETVAL); 1994 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 1995 } 1996 XSRETURN(1); 1997 } 1998 1999 XS(XS_Cwd_sys_cwd) 2000 { 2001 dXSARGS; 2002 if (items != 0) 2003 Perl_croak_nocontext("Usage: Cwd::sys_cwd()"); 2004 { 2005 char p[MAXPATHLEN]; 2006 char * RETVAL; 2007 RETVAL = _getcwd2(p, MAXPATHLEN); 2008 ST(0) = sv_newmortal(); 2009 sv_setpv((SV*)ST(0), RETVAL); 2010 #ifndef INCOMPLETE_TAINTS 2011 SvTAINTED_on(ST(0)); 2012 #endif 2013 } 2014 XSRETURN(1); 2015 } 2016 2017 XS(XS_Cwd_sys_abspath) 2018 { 2019 dXSARGS; 2020 if (items < 1 || items > 2) 2021 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)"); 2022 { 2023 STRLEN n_a; 2024 char * path = (char *)SvPV(ST(0),n_a); 2025 char * dir, *s, *t, *e; 2026 char p[MAXPATHLEN]; 2027 char * RETVAL; 2028 int l; 2029 SV *sv; 2030 2031 if (items < 2) 2032 dir = NULL; 2033 else { 2034 dir = (char *)SvPV(ST(1),n_a); 2035 } 2036 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) { 2037 path += 2; 2038 } 2039 if (dir == NULL) { 2040 if (_abspath(p, path, MAXPATHLEN) == 0) { 2041 RETVAL = p; 2042 } else { 2043 RETVAL = NULL; 2044 } 2045 } else { 2046 /* Absolute with drive: */ 2047 if ( sys_is_absolute(path) ) { 2048 if (_abspath(p, path, MAXPATHLEN) == 0) { 2049 RETVAL = p; 2050 } else { 2051 RETVAL = NULL; 2052 } 2053 } else if (path[0] == '/' || path[0] == '\\') { 2054 /* Rooted, but maybe on different drive. */ 2055 if (isALPHA(dir[0]) && dir[1] == ':' ) { 2056 char p1[MAXPATHLEN]; 2057 2058 /* Need to prepend the drive. */ 2059 p1[0] = dir[0]; 2060 p1[1] = dir[1]; 2061 Copy(path, p1 + 2, strlen(path) + 1, char); 2062 RETVAL = p; 2063 if (_abspath(p, p1, MAXPATHLEN) == 0) { 2064 RETVAL = p; 2065 } else { 2066 RETVAL = NULL; 2067 } 2068 } else if (_abspath(p, path, MAXPATHLEN) == 0) { 2069 RETVAL = p; 2070 } else { 2071 RETVAL = NULL; 2072 } 2073 } else { 2074 /* Either path is relative, or starts with a drive letter. */ 2075 /* If the path starts with a drive letter, then dir is 2076 relevant only if 2077 a/b) it is absolute/x:relative on the same drive. 2078 c) path is on current drive, and dir is rooted 2079 In all the cases it is safe to drop the drive part 2080 of the path. */ 2081 if ( !sys_is_relative(path) ) { 2082 if ( ( ( sys_is_absolute(dir) 2083 || (isALPHA(dir[0]) && dir[1] == ':' 2084 && strnicmp(dir, path,1) == 0)) 2085 && strnicmp(dir, path,1) == 0) 2086 || ( !(isALPHA(dir[0]) && dir[1] == ':') 2087 && toupper(path[0]) == current_drive())) { 2088 path += 2; 2089 } else if (_abspath(p, path, MAXPATHLEN) == 0) { 2090 RETVAL = p; goto done; 2091 } else { 2092 RETVAL = NULL; goto done; 2093 } 2094 } 2095 { 2096 /* Need to prepend the absolute path of dir. */ 2097 char p1[MAXPATHLEN]; 2098 2099 if (_abspath(p1, dir, MAXPATHLEN) == 0) { 2100 int l = strlen(p1); 2101 2102 if (p1[ l - 1 ] != '/') { 2103 p1[ l ] = '/'; 2104 l++; 2105 } 2106 Copy(path, p1 + l, strlen(path) + 1, char); 2107 if (_abspath(p, p1, MAXPATHLEN) == 0) { 2108 RETVAL = p; 2109 } else { 2110 RETVAL = NULL; 2111 } 2112 } else { 2113 RETVAL = NULL; 2114 } 2115 } 2116 done: 2117 } 2118 } 2119 if (!RETVAL) 2120 XSRETURN_EMPTY; 2121 /* Backslashes are already converted to slashes. */ 2122 /* Remove trailing slashes */ 2123 l = strlen(RETVAL); 2124 while (l > 0 && RETVAL[l-1] == '/') 2125 l--; 2126 ST(0) = sv_newmortal(); 2127 sv_setpvn( sv = (SV*)ST(0), RETVAL, l); 2128 /* Remove duplicate slashes, skipping the first three, which 2129 may be parts of a server-based path */ 2130 s = t = 3 + SvPV_force(sv, n_a); 2131 e = SvEND(sv); 2132 /* Do not worry about multibyte chars here, this would contradict the 2133 eventual UTFization, and currently most other places break too... */ 2134 while (s < e) { 2135 if (s[0] == t[-1] && s[0] == '/') 2136 s++; /* Skip duplicate / */ 2137 else 2138 *t++ = *s++; 2139 } 2140 if (t < e) { 2141 *t = 0; 2142 SvCUR_set(sv, t - SvPVX(sv)); 2143 } 2144 } 2145 XSRETURN(1); 2146 } 2147 typedef APIRET (*PELP)(PSZ path, ULONG type); 2148 2149 /* Kernels after 2000/09/15 understand this too: */ 2150 #ifndef LIBPATHSTRICT 2151 # define LIBPATHSTRICT 3 2152 #endif 2153 2154 APIRET 2155 ExtLIBPATH(ULONG ord, PSZ path, IV type) 2156 { 2157 ULONG what; 2158 PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */ 2159 2160 if (type > 0) 2161 what = END_LIBPATH; 2162 else if (type == 0) 2163 what = BEGIN_LIBPATH; 2164 else 2165 what = LIBPATHSTRICT; 2166 return (*(PELP)f)(path, what); 2167 } 2168 2169 #define extLibpath(to,type) \ 2170 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) ) 2171 2172 #define extLibpath_set(p,type) \ 2173 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type)))) 2174 2175 XS(XS_Cwd_extLibpath) 2176 { 2177 dXSARGS; 2178 if (items < 0 || items > 1) 2179 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)"); 2180 { 2181 IV type; 2182 char to[1024]; 2183 U32 rc; 2184 char * RETVAL; 2185 2186 if (items < 1) 2187 type = 0; 2188 else { 2189 type = SvIV(ST(0)); 2190 } 2191 2192 to[0] = 1; to[1] = 0; /* Sometimes no error reported */ 2193 RETVAL = extLibpath(to, type); 2194 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0) 2195 Perl_croak_nocontext("panic Cwd::extLibpath parameter"); 2196 ST(0) = sv_newmortal(); 2197 sv_setpv((SV*)ST(0), RETVAL); 2198 } 2199 XSRETURN(1); 2200 } 2201 2202 XS(XS_Cwd_extLibpath_set) 2203 { 2204 dXSARGS; 2205 if (items < 1 || items > 2) 2206 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)"); 2207 { 2208 STRLEN n_a; 2209 char * s = (char *)SvPV(ST(0),n_a); 2210 IV type; 2211 U32 rc; 2212 bool RETVAL; 2213 2214 if (items < 2) 2215 type = 0; 2216 else { 2217 type = SvIV(ST(1)); 2218 } 2219 2220 RETVAL = extLibpath_set(s, type); 2221 ST(0) = boolSV(RETVAL); 2222 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 2223 } 2224 XSRETURN(1); 2225 } 2226 2227 /* Input: Address, BufLen 2228 APIRET APIENTRY 2229 DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf, 2230 ULONG * Offset, ULONG Address); 2231 */ 2232 2233 DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP, 2234 (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf, 2235 ULONG * Offset, ULONG Address), 2236 (hmod, obj, BufLen, Buf, Offset, Address)) 2237 2238 enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full}; 2239 2240 static SV* 2241 module_name_at(void *pp, enum module_name_how how) 2242 { 2243 char buf[MAXPATHLEN]; 2244 char *p = buf; 2245 HMODULE mod; 2246 ULONG obj, offset, rc; 2247 2248 if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, (ULONG)pp)) 2249 return &PL_sv_undef; 2250 if (how == mod_name_handle) 2251 return newSVuv(mod); 2252 /* Full name... */ 2253 if ( how == mod_name_full 2254 && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) ) 2255 return &PL_sv_undef; 2256 while (*p) { 2257 if (*p == '\\') 2258 *p = '/'; 2259 p++; 2260 } 2261 return newSVpv(buf, 0); 2262 } 2263 2264 static SV* 2265 module_name_of_cv(SV *cv, enum module_name_how how) 2266 { 2267 if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) 2268 croak("Not an XSUB reference"); 2269 return module_name_at(CvXSUB(SvRV(cv)), how); 2270 } 2271 2272 /* Find module name to which *this* subroutine is compiled */ 2273 #define module_name(how) module_name_at(&module_name_at, how) 2274 2275 XS(XS_OS2_DLLname) 2276 { 2277 dXSARGS; 2278 if (items > 2) 2279 Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )"); 2280 { 2281 SV * RETVAL; 2282 int how; 2283 2284 if (items < 1) 2285 how = mod_name_full; 2286 else { 2287 how = (int)SvIV(ST(0)); 2288 } 2289 if (items < 2) 2290 RETVAL = module_name(how); 2291 else 2292 RETVAL = module_name_of_cv(ST(1), how); 2293 ST(0) = RETVAL; 2294 sv_2mortal(ST(0)); 2295 } 2296 XSRETURN(1); 2297 } 2298 2299 #define get_control87() _control87(0,0) 2300 #define set_control87 _control87 2301 2302 XS(XS_OS2__control87) 2303 { 2304 dXSARGS; 2305 if (items != 2) 2306 croak("Usage: OS2::_control87(new,mask)"); 2307 { 2308 unsigned new = (unsigned)SvIV(ST(0)); 2309 unsigned mask = (unsigned)SvIV(ST(1)); 2310 unsigned RETVAL; 2311 2312 RETVAL = _control87(new, mask); 2313 ST(0) = sv_newmortal(); 2314 sv_setiv(ST(0), (IV)RETVAL); 2315 } 2316 XSRETURN(1); 2317 } 2318 2319 XS(XS_OS2_get_control87) 2320 { 2321 dXSARGS; 2322 if (items != 0) 2323 croak("Usage: OS2::get_control87()"); 2324 { 2325 unsigned RETVAL; 2326 2327 RETVAL = get_control87(); 2328 ST(0) = sv_newmortal(); 2329 sv_setiv(ST(0), (IV)RETVAL); 2330 } 2331 XSRETURN(1); 2332 } 2333 2334 2335 XS(XS_OS2_set_control87) 2336 { 2337 dXSARGS; 2338 if (items < 0 || items > 2) 2339 croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)"); 2340 { 2341 unsigned new; 2342 unsigned mask; 2343 unsigned RETVAL; 2344 2345 if (items < 1) 2346 new = MCW_EM; 2347 else { 2348 new = (unsigned)SvIV(ST(0)); 2349 } 2350 2351 if (items < 2) 2352 mask = MCW_EM; 2353 else { 2354 mask = (unsigned)SvIV(ST(1)); 2355 } 2356 2357 RETVAL = set_control87(new, mask); 2358 ST(0) = sv_newmortal(); 2359 sv_setiv(ST(0), (IV)RETVAL); 2360 } 2361 XSRETURN(1); 2362 } 2363 2364 int 2365 Xs_OS2_init(pTHX) 2366 { 2367 char *file = __FILE__; 2368 { 2369 GV *gv; 2370 2371 if (_emx_env & 0x200) { /* OS/2 */ 2372 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); 2373 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); 2374 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file); 2375 } 2376 newXS("OS2::Error", XS_OS2_Error, file); 2377 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file); 2378 newXS("OS2::SysInfo", XS_OS2_SysInfo, file); 2379 newXS("OS2::BootDrive", XS_OS2_BootDrive, file); 2380 newXS("OS2::MorphPM", XS_OS2_MorphPM, file); 2381 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file); 2382 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file); 2383 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file); 2384 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file); 2385 newXS("Cwd::current_drive", XS_Cwd_current_drive, file); 2386 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file); 2387 newXS("Cwd::change_drive", XS_Cwd_change_drive, file); 2388 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file); 2389 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file); 2390 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file); 2391 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file); 2392 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file); 2393 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$"); 2394 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, ""); 2395 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$"); 2396 newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$"); 2397 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); 2398 GvMULTI_on(gv); 2399 #ifdef PERL_IS_AOUT 2400 sv_setiv(GvSV(gv), 1); 2401 #endif 2402 gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV); 2403 GvMULTI_on(gv); 2404 sv_setiv(GvSV(gv), exe_is_aout()); 2405 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV); 2406 GvMULTI_on(gv); 2407 sv_setiv(GvSV(gv), _emx_rev); 2408 sv_setpv(GvSV(gv), _emx_vprt); 2409 SvIOK_on(GvSV(gv)); 2410 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV); 2411 GvMULTI_on(gv); 2412 sv_setiv(GvSV(gv), _emx_env); 2413 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV); 2414 GvMULTI_on(gv); 2415 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor); 2416 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV); 2417 GvMULTI_on(gv); 2418 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */ 2419 } 2420 return 0; 2421 } 2422 2423 OS2_Perl_data_t OS2_Perl_data; 2424 2425 extern void _emx_init(void*); 2426 2427 static void jmp_out_of_atexit(void); 2428 2429 #define FORCE_EMX_INIT_CONTRACT_ARGV 1 2430 #define FORCE_EMX_INIT_INSTALL_ATEXIT 2 2431 2432 static void 2433 my_emx_init(void *layout) { 2434 static volatile void *p = 0; /* Cannot be on stack! */ 2435 2436 /* Can't just call emx_init(), since it moves the stack pointer */ 2437 /* It also busts a lot of registers, so be extra careful */ 2438 __asm__( "pushf\n" 2439 "pusha\n" 2440 "movl %%esp, %1\n" 2441 "push %0\n" 2442 "call __emx_init\n" 2443 "movl %1, %%esp\n" 2444 "popa\n" 2445 "popf\n" : : "r" (layout), "m" (p) ); 2446 } 2447 2448 struct layout_table_t { 2449 ULONG text_base; 2450 ULONG text_end; 2451 ULONG data_base; 2452 ULONG data_end; 2453 ULONG bss_base; 2454 ULONG bss_end; 2455 ULONG heap_base; 2456 ULONG heap_end; 2457 ULONG heap_brk; 2458 ULONG heap_off; 2459 ULONG os2_dll; 2460 ULONG stack_base; 2461 ULONG stack_end; 2462 ULONG flags; 2463 ULONG reserved[2]; 2464 char options[64]; 2465 }; 2466 2467 static ULONG 2468 my_os_version() { 2469 static ULONG res; /* Cannot be on stack! */ 2470 2471 /* Can't just call __os_version(), since it does not follow C 2472 calling convention: it busts a lot of registers, so be extra careful */ 2473 __asm__( "pushf\n" 2474 "pusha\n" 2475 "call ___os_version\n" 2476 "movl %%eax, %0\n" 2477 "popa\n" 2478 "popf\n" : "=m" (res) ); 2479 2480 return res; 2481 } 2482 2483 static void 2484 force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags) 2485 { 2486 /* Calling emx_init() will bust the top of stack: it installs an 2487 exception handler and puts argv data there. */ 2488 char *oldarg, *oldenv; 2489 void *oldstackend, *oldstack; 2490 PPIB pib; 2491 PTIB tib; 2492 static ULONG os2_dll; 2493 ULONG rc, error = 0, out; 2494 char buf[512]; 2495 static struct layout_table_t layout_table; 2496 struct { 2497 char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */ 2498 double alignment1; 2499 EXCEPTIONREGISTRATIONRECORD xreg; 2500 } *newstack; 2501 char *s; 2502 2503 layout_table.os2_dll = (ULONG)&os2_dll; 2504 layout_table.flags = 0x02000002; /* flags: application, OMF */ 2505 2506 DosGetInfoBlocks(&tib, &pib); 2507 oldarg = pib->pib_pchcmd; 2508 oldenv = pib->pib_pchenv; 2509 oldstack = tib->tib_pstack; 2510 oldstackend = tib->tib_pstacklimit; 2511 2512 /* Minimize the damage to the stack via reducing the size of argv. */ 2513 if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) { 2514 pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */ 2515 pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */ 2516 } 2517 2518 newstack = alloca(sizeof(*newstack)); 2519 /* Emulate the stack probe */ 2520 s = ((char*)newstack) + sizeof(*newstack); 2521 while (s > (char*)newstack) { 2522 s[-1] = 0; 2523 s -= 4096; 2524 } 2525 2526 /* Reassigning stack is documented to work */ 2527 tib->tib_pstack = (void*)newstack; 2528 tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack)); 2529 2530 /* Can't just call emx_init(), since it moves the stack pointer */ 2531 my_emx_init((void*)&layout_table); 2532 2533 /* Remove the exception handler, cannot use it - too low on the stack. 2534 Check whether it is inside the new stack. */ 2535 buf[0] = 0; 2536 if (tib->tib_pexchain >= tib->tib_pstacklimit 2537 || tib->tib_pexchain < tib->tib_pstack) { 2538 error = 1; 2539 sprintf(buf, 2540 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n", 2541 (unsigned long)tib->tib_pstack, 2542 (unsigned long)tib->tib_pexchain, 2543 (unsigned long)tib->tib_pstacklimit); 2544 goto finish; 2545 } 2546 if (tib->tib_pexchain != &(newstack->xreg)) { 2547 sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n", 2548 (unsigned long)tib->tib_pexchain, 2549 (unsigned long)&(newstack->xreg)); 2550 } 2551 rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain); 2552 if (rc) 2553 sprintf(buf + strlen(buf), 2554 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc); 2555 2556 if (preg) { 2557 /* ExceptionRecords should be on stack, in a correct order. Sigh... */ 2558 preg->prev_structure = 0; 2559 preg->ExceptionHandler = _emx_exception; 2560 rc = DosSetExceptionHandler(preg); 2561 if (rc) { 2562 sprintf(buf + strlen(buf), 2563 "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc); 2564 DosWrite(2, buf, strlen(buf), &out); 2565 emx_exception_init = 1; /* Do it around spawn*() calls */ 2566 } 2567 } else 2568 emx_exception_init = 1; /* Do it around spawn*() calls */ 2569 2570 finish: 2571 /* Restore the damage */ 2572 pib->pib_pchcmd = oldarg; 2573 pib->pib_pchcmd = oldenv; 2574 tib->tib_pstacklimit = oldstackend; 2575 tib->tib_pstack = oldstack; 2576 emx_runtime_init = 1; 2577 if (buf[0]) 2578 DosWrite(2, buf, strlen(buf), &out); 2579 if (error) 2580 exit(56); 2581 } 2582 2583 jmp_buf at_exit_buf; 2584 int longjmp_at_exit; 2585 2586 static void 2587 jmp_out_of_atexit(void) 2588 { 2589 if (longjmp_at_exit) 2590 longjmp(at_exit_buf, 1); 2591 } 2592 2593 extern void _CRT_term(void); 2594 2595 int emx_runtime_secondary; 2596 2597 void 2598 Perl_OS2_term(void **p, int exitstatus, int flags) 2599 { 2600 if (!emx_runtime_secondary) 2601 return; 2602 2603 /* The principal executable is not running the same CRTL, so there 2604 is nobody to shutdown *this* CRTL except us... */ 2605 if (flags & FORCE_EMX_DEINIT_EXIT) { 2606 if (p && !emx_exception_init) 2607 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p); 2608 /* Do not run the executable's CRTL's termination routines */ 2609 exit(exitstatus); /* Run at-exit, flush buffers, etc */ 2610 } 2611 /* Run at-exit list, and jump out at the end */ 2612 if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) { 2613 longjmp_at_exit = 1; 2614 exit(exitstatus); /* The first pass through "if" */ 2615 } 2616 2617 /* Get here if we managed to jump out of exit(), or did not run atexit. */ 2618 longjmp_at_exit = 0; /* Maybe exit() is called again? */ 2619 #if 0 /* _atexit_n is not exported */ 2620 if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT) 2621 _atexit_n = 0; /* Remove the atexit() handlers */ 2622 #endif 2623 /* Will segfault on program termination if we leave this dangling... */ 2624 if (p && !emx_exception_init) 2625 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p); 2626 /* Typically there is no need to do this, done from _DLL_InitTerm() */ 2627 if (flags & FORCE_EMX_DEINIT_CRT_TERM) 2628 _CRT_term(); /* Flush buffers, etc. */ 2629 /* Now it is a good time to call exit() in the caller's CRTL... */ 2630 } 2631 2632 #include <emx/startup.h> 2633 2634 extern ULONG __os_version(); /* See system.doc */ 2635 2636 static int emx_wasnt_initialized; 2637 2638 void 2639 check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg) 2640 { 2641 ULONG v_crt, v_emx; 2642 2643 /* If _environ is not set, this code sits in a DLL which 2644 uses a CRT DLL which not compatible with the executable's 2645 CRT library. Some parts of the DLL are not initialized. 2646 */ 2647 if (_environ != NULL) 2648 return; /* Properly initialized */ 2649 2650 /* If the executable does not use EMX.DLL, EMX.DLL is not completely 2651 initialized either. Uninitialized EMX.DLL returns 0 in the low 2652 nibble of __os_version(). */ 2653 v_emx = my_os_version(); 2654 2655 /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL 2656 (=>_CRT_init=>_entry2) via a call to __os_version(), then 2657 reset when the EXE initialization code calls _text=>_init=>_entry2. 2658 The first time they are wrongly set to 0; the second time the 2659 EXE initialization code had already called emx_init=>initialize1 2660 which correctly set version_major, version_minor used by 2661 __os_version(). */ 2662 v_crt = (_osmajor | _osminor); 2663 2664 if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */ 2665 force_init_emx_runtime( preg, 2666 FORCE_EMX_INIT_CONTRACT_ARGV 2667 | FORCE_EMX_INIT_INSTALL_ATEXIT ); 2668 emx_wasnt_initialized = 1; 2669 /* Update CRTL data basing on now-valid EMX runtime data */ 2670 if (!v_crt) { /* The only wrong data are the versions. */ 2671 v_emx = my_os_version(); /* *Now* it works */ 2672 *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */ 2673 *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF; 2674 } 2675 } 2676 emx_runtime_secondary = 1; 2677 /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */ 2678 atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */ 2679 2680 if (env == NULL) { /* Fetch from the process info block */ 2681 int c = 0; 2682 PPIB pib; 2683 PTIB tib; 2684 char *e, **ep; 2685 2686 DosGetInfoBlocks(&tib, &pib); 2687 e = pib->pib_pchenv; 2688 while (*e) { /* Get count */ 2689 c++; 2690 e = e + strlen(e) + 1; 2691 } 2692 New(1307, env, c + 1, char*); 2693 ep = env; 2694 e = pib->pib_pchenv; 2695 while (c--) { 2696 *ep++ = e; 2697 e = e + strlen(e) + 1; 2698 } 2699 *ep = NULL; 2700 } 2701 _environ = _org_environ = env; 2702 } 2703 2704 #define ENTRY_POINT 0x10000 2705 2706 static int 2707 exe_is_aout(void) 2708 { 2709 struct layout_table_t *layout; 2710 if (emx_wasnt_initialized) 2711 return 0; 2712 /* Now we know that the principal executable is an EMX application 2713 - unless somebody did already play with delayed initialization... */ 2714 /* With EMX applications to determine whether it is AOUT one needs 2715 to examine the start of the executable to find "layout" */ 2716 if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */ 2717 || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */ 2718 || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */ 2719 || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */ 2720 return 0; /* ! EMX executable */ 2721 /* Fix alignment */ 2722 Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*); 2723 return !(layout->flags & 2); 2724 } 2725 2726 void 2727 Perl_OS2_init(char **env) 2728 { 2729 Perl_OS2_init3(env, 0, 0); 2730 } 2731 2732 void 2733 Perl_OS2_init3(char **env, void **preg, int flags) 2734 { 2735 char *shell; 2736 2737 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY); 2738 MALLOC_INIT; 2739 2740 check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg); 2741 2742 settmppath(); 2743 OS2_Perl_data.xs_init = &Xs_OS2_init; 2744 if ( (shell = getenv("PERL_SH_DRIVE")) ) { 2745 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char); 2746 strcpy(PL_sh_path, SH_PATH); 2747 PL_sh_path[0] = shell[0]; 2748 } else if ( (shell = getenv("PERL_SH_DIR")) ) { 2749 int l = strlen(shell), i; 2750 if (shell[l-1] == '/' || shell[l-1] == '\\') { 2751 l--; 2752 } 2753 New(1304, PL_sh_path, l + 8, char); 2754 strncpy(PL_sh_path, shell, l); 2755 strcpy(PL_sh_path + l, "/sh.exe"); 2756 for (i = 0; i < l; i++) { 2757 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/'; 2758 } 2759 } 2760 MUTEX_INIT(&start_thread_mutex); 2761 os2_mytype = my_type(); /* Do it before morphing. Needed? */ 2762 /* Some DLLs reset FP flags on load. We may have been linked with them */ 2763 _control87(MCW_EM, MCW_EM); 2764 } 2765 2766 #undef tmpnam 2767 #undef tmpfile 2768 2769 char * 2770 my_tmpnam (char *str) 2771 { 2772 char *p = getenv("TMP"), *tpath; 2773 2774 if (!p) p = getenv("TEMP"); 2775 tpath = tempnam(p, "pltmp"); 2776 if (str && tpath) { 2777 strcpy(str, tpath); 2778 return str; 2779 } 2780 return tpath; 2781 } 2782 2783 FILE * 2784 my_tmpfile () 2785 { 2786 struct stat s; 2787 2788 stat(".", &s); 2789 if (s.st_mode & S_IWOTH) { 2790 return tmpfile(); 2791 } 2792 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but 2793 grants TMP. */ 2794 } 2795 2796 #undef rmdir 2797 2798 int 2799 my_rmdir (__const__ char *s) 2800 { 2801 char buf[MAXPATHLEN]; 2802 STRLEN l = strlen(s); 2803 2804 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX rmdir fails... */ 2805 strcpy(buf,s); 2806 buf[l - 1] = 0; 2807 s = buf; 2808 } 2809 return rmdir(s); 2810 } 2811 2812 #undef mkdir 2813 2814 int 2815 my_mkdir (__const__ char *s, long perm) 2816 { 2817 char buf[MAXPATHLEN]; 2818 STRLEN l = strlen(s); 2819 2820 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */ 2821 strcpy(buf,s); 2822 buf[l - 1] = 0; 2823 s = buf; 2824 } 2825 return mkdir(s, perm); 2826 } 2827 2828 #undef flock 2829 2830 /* This code was contributed by Rocco Caputo. */ 2831 int 2832 my_flock(int handle, int o) 2833 { 2834 FILELOCK rNull, rFull; 2835 ULONG timeout, handle_type, flag_word; 2836 APIRET rc; 2837 int blocking, shared; 2838 static int use_my = -1; 2839 2840 if (use_my == -1) { 2841 char *s = getenv("USE_PERL_FLOCK"); 2842 if (s) 2843 use_my = atoi(s); 2844 else 2845 use_my = 1; 2846 } 2847 if (!(_emx_env & 0x200) || !use_my) 2848 return flock(handle, o); /* Delegate to EMX. */ 2849 2850 /* is this a file? */ 2851 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) || 2852 (handle_type & 0xFF)) 2853 { 2854 errno = EBADF; 2855 return -1; 2856 } 2857 /* set lock/unlock ranges */ 2858 rNull.lOffset = rNull.lRange = rFull.lOffset = 0; 2859 rFull.lRange = 0x7FFFFFFF; 2860 /* set timeout for blocking */ 2861 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1; 2862 /* shared or exclusive? */ 2863 shared = (o & LOCK_SH) ? 1 : 0; 2864 /* do not block the unlock */ 2865 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) { 2866 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared); 2867 switch (rc) { 2868 case 0: 2869 errno = 0; 2870 return 0; 2871 case ERROR_INVALID_HANDLE: 2872 errno = EBADF; 2873 return -1; 2874 case ERROR_SHARING_BUFFER_EXCEEDED: 2875 errno = ENOLCK; 2876 return -1; 2877 case ERROR_LOCK_VIOLATION: 2878 break; /* not an error */ 2879 case ERROR_INVALID_PARAMETER: 2880 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: 2881 case ERROR_READ_LOCKS_NOT_SUPPORTED: 2882 errno = EINVAL; 2883 return -1; 2884 case ERROR_INTERRUPT: 2885 errno = EINTR; 2886 return -1; 2887 default: 2888 errno = EINVAL; 2889 return -1; 2890 } 2891 } 2892 /* lock may block */ 2893 if (o & (LOCK_SH | LOCK_EX)) { 2894 /* for blocking operations */ 2895 for (;;) { 2896 rc = 2897 DosSetFileLocks( 2898 handle, 2899 &rNull, 2900 &rFull, 2901 timeout, 2902 shared 2903 ); 2904 switch (rc) { 2905 case 0: 2906 errno = 0; 2907 return 0; 2908 case ERROR_INVALID_HANDLE: 2909 errno = EBADF; 2910 return -1; 2911 case ERROR_SHARING_BUFFER_EXCEEDED: 2912 errno = ENOLCK; 2913 return -1; 2914 case ERROR_LOCK_VIOLATION: 2915 if (!blocking) { 2916 errno = EWOULDBLOCK; 2917 return -1; 2918 } 2919 break; 2920 case ERROR_INVALID_PARAMETER: 2921 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: 2922 case ERROR_READ_LOCKS_NOT_SUPPORTED: 2923 errno = EINVAL; 2924 return -1; 2925 case ERROR_INTERRUPT: 2926 errno = EINTR; 2927 return -1; 2928 default: 2929 errno = EINVAL; 2930 return -1; 2931 } 2932 /* give away timeslice */ 2933 DosSleep(1); 2934 } 2935 } 2936 2937 errno = 0; 2938 return 0; 2939 } 2940 2941 static int pwent_cnt; 2942 static int _my_pwent = -1; 2943 2944 static int 2945 use_my_pwent(void) 2946 { 2947 if (_my_pwent == -1) { 2948 char *s = getenv("USE_PERL_PWENT"); 2949 if (s) 2950 _my_pwent = atoi(s); 2951 else 2952 _my_pwent = 1; 2953 } 2954 return _my_pwent; 2955 } 2956 2957 #undef setpwent 2958 #undef getpwent 2959 #undef endpwent 2960 2961 void 2962 my_setpwent(void) 2963 { 2964 if (!use_my_pwent()) { 2965 setpwent(); /* Delegate to EMX. */ 2966 return; 2967 } 2968 pwent_cnt = 0; 2969 } 2970 2971 void 2972 my_endpwent(void) 2973 { 2974 if (!use_my_pwent()) { 2975 endpwent(); /* Delegate to EMX. */ 2976 return; 2977 } 2978 } 2979 2980 struct passwd * 2981 my_getpwent (void) 2982 { 2983 if (!use_my_pwent()) 2984 return getpwent(); /* Delegate to EMX. */ 2985 if (pwent_cnt++) 2986 return 0; /* Return one entry only */ 2987 return getpwuid(0); 2988 } 2989 2990 static int grent_cnt; 2991 2992 void 2993 setgrent(void) 2994 { 2995 grent_cnt = 0; 2996 } 2997 2998 void 2999 endgrent(void) 3000 { 3001 } 3002 3003 struct group * 3004 getgrent (void) 3005 { 3006 if (grent_cnt++) 3007 return 0; /* Return one entry only */ 3008 return getgrgid(0); 3009 } 3010 3011 #undef getpwuid 3012 #undef getpwnam 3013 3014 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */ 3015 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK"; 3016 3017 static struct passwd * 3018 passw_wrap(struct passwd *p) 3019 { 3020 static struct passwd pw; 3021 char *s; 3022 3023 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */ 3024 return p; 3025 pw = *p; 3026 s = getenv("PW_PASSWD"); 3027 if (!s) 3028 s = (char*)pw_p; /* Make match impossible */ 3029 3030 pw.pw_passwd = s; 3031 return &pw; 3032 } 3033 3034 struct passwd * 3035 my_getpwuid (uid_t id) 3036 { 3037 return passw_wrap(getpwuid(id)); 3038 } 3039 3040 struct passwd * 3041 my_getpwnam (__const__ char *n) 3042 { 3043 return passw_wrap(getpwnam(n)); 3044 } 3045 3046 char * 3047 gcvt_os2 (double value, int digits, char *buffer) 3048 { 3049 return gcvt (value, digits, buffer); 3050 } 3051