1 #define INCL_DOS 2 #define INCL_NOPM 3 #define INCL_DOSFILEMGR 4 #define INCL_DOSMEMMGR 5 #define INCL_DOSERRORS 6 #define INCL_WINERRORS 7 #define INCL_WINSYS 8 /* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */ 9 #define INCL_DOSPROCESS 10 #define SPU_DISABLESUPPRESSION 0 11 #define SPU_ENABLESUPPRESSION 1 12 #include <os2.h> 13 #include "dlfcn.h" 14 #include <emx/syscalls.h> 15 16 #include <sys/uflags.h> 17 18 /* 19 * Various Unix compatibility functions for OS/2 20 */ 21 22 #include <stdio.h> 23 #include <errno.h> 24 #include <limits.h> 25 #include <process.h> 26 #include <fcntl.h> 27 #include <pwd.h> 28 #include <grp.h> 29 30 #define PERLIO_NOT_STDIO 0 31 32 #include "EXTERN.h" 33 #include "perl.h" 34 35 void 36 croak_with_os2error(char *s) 37 { 38 Perl_croak_nocontext("%s: %s", s, os2error(Perl_rc)); 39 } 40 41 struct PMWIN_entries_t PMWIN_entries; 42 43 /*****************************************************************************/ 44 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */ 45 46 struct dll_handle_t { 47 const char *modname; 48 HMODULE handle; 49 int requires_pm; 50 }; 51 52 static struct dll_handle_t dll_handles[] = { 53 {"doscalls", 0, 0}, 54 {"tcp32dll", 0, 0}, 55 {"pmwin", 0, 1}, 56 {"rexx", 0, 0}, 57 {"rexxapi", 0, 0}, 58 {"sesmgr", 0, 0}, 59 {"pmshapi", 0, 1}, 60 {"pmwp", 0, 1}, 61 {"pmgpi", 0, 1}, 62 {NULL, 0}, 63 }; 64 65 enum dll_handle_e { 66 dll_handle_doscalls, 67 dll_handle_tcp32dll, 68 dll_handle_pmwin, 69 dll_handle_rexx, 70 dll_handle_rexxapi, 71 dll_handle_sesmgr, 72 dll_handle_pmshapi, 73 dll_handle_pmwp, 74 dll_handle_pmgpi, 75 dll_handle_LAST, 76 }; 77 78 #define doscalls_handle (dll_handles[dll_handle_doscalls]) 79 #define tcp_handle (dll_handles[dll_handle_tcp32dll]) 80 #define pmwin_handle (dll_handles[dll_handle_pmwin]) 81 #define rexx_handle (dll_handles[dll_handle_rexx]) 82 #define rexxapi_handle (dll_handles[dll_handle_rexxapi]) 83 #define sesmgr_handle (dll_handles[dll_handle_sesmgr]) 84 #define pmshapi_handle (dll_handles[dll_handle_pmshapi]) 85 #define pmwp_handle (dll_handles[dll_handle_pmwp]) 86 #define pmgpi_handle (dll_handles[dll_handle_pmgpi]) 87 88 /* The following local-scope data is not yet included: 89 fargs.140 // const => OK 90 ino.165 // locked - and the access is almost cosmetic 91 layout_table.260 // startup only, locked 92 osv_res.257 // startup only, locked 93 old_esp.254 // startup only, locked 94 priors // const ==> OK 95 use_my_flock.283 // locked 96 emx_init_done.268 // locked 97 dll_handles // locked 98 hmtx_emx_init.267 // THIS is the lock for startup 99 perlos2_state_mutex // THIS is the lock for all the rest 100 BAD: 101 perlos2_state // see below 102 */ 103 /* The following global-scope data is not yet included: 104 OS2_Perl_data 105 pthreads_states // const now? 106 start_thread_mutex 107 thread_join_count // protected 108 thread_join_data // protected 109 tmppath 110 111 pDosVerifyPidTid 112 113 Perl_OS2_init3() - should it be protected? 114 */ 115 OS2_Perl_data_t OS2_Perl_data; 116 117 static struct perlos2_state_t { 118 int po2__my_pwent; /* = -1; */ 119 int po2_DOS_harderr_state; /* = -1; */ 120 signed char po2_DOS_suppression_state; /* = -1; */ 121 PFN po2_ExtFCN[ORD_NENTRIES]; /* Labeled by ord ORD_*. */ 122 /* struct PMWIN_entries_t po2_PMWIN_entries; */ 123 124 int po2_emx_wasnt_initialized; 125 126 char po2_fname[9]; 127 int po2_rmq_cnt; 128 129 int po2_grent_cnt; 130 131 char *po2_newp; 132 char *po2_oldp; 133 int po2_newl; 134 int po2_oldl; 135 int po2_notfound; 136 char po2_mangle_ret[STATIC_FILE_LENGTH+1]; 137 ULONG po2_os2_dll_fake; 138 ULONG po2_os2_mytype; 139 ULONG po2_os2_mytype_ini; 140 int po2_pidtid_lookup; 141 struct passwd po2_pw; 142 143 int po2_pwent_cnt; 144 char po2_pthreads_state_buf[80]; 145 char po2_os2error_buf[300]; 146 /* There is no big sense to make it thread-specific, since signals 147 are delivered to thread 1 only. XXXX Maybe make it into an array? */ 148 int po2_spawn_pid; 149 int po2_spawn_killed; 150 151 jmp_buf po2_at_exit_buf; 152 int po2_longjmp_at_exit; 153 int po2_emx_runtime_init; /* If 1, we need to manually init it */ 154 int po2_emx_exception_init; /* If 1, we need to manually set it */ 155 int po2_emx_runtime_secondary; 156 157 } perlos2_state = { 158 -1, /* po2__my_pwent */ 159 -1, /* po2_DOS_harderr_state */ 160 -1, /* po2_DOS_suppression_state */ 161 }; 162 163 #define Perl_po2() (&perlos2_state) 164 165 #define ExtFCN (Perl_po2()->po2_ExtFCN) 166 /* #define PMWIN_entries (Perl_po2()->po2_PMWIN_entries) */ 167 #define emx_wasnt_initialized (Perl_po2()->po2_emx_wasnt_initialized) 168 #define fname (Perl_po2()->po2_fname) 169 #define rmq_cnt (Perl_po2()->po2_rmq_cnt) 170 #define grent_cnt (Perl_po2()->po2_grent_cnt) 171 #define newp (Perl_po2()->po2_newp) 172 #define oldp (Perl_po2()->po2_oldp) 173 #define newl (Perl_po2()->po2_newl) 174 #define oldl (Perl_po2()->po2_oldl) 175 #define notfound (Perl_po2()->po2_notfound) 176 #define mangle_ret (Perl_po2()->po2_mangle_ret) 177 #define os2_dll_fake (Perl_po2()->po2_os2_dll_fake) 178 #define os2_mytype (Perl_po2()->po2_os2_mytype) 179 #define os2_mytype_ini (Perl_po2()->po2_os2_mytype_ini) 180 #define pidtid_lookup (Perl_po2()->po2_pidtid_lookup) 181 #define pw (Perl_po2()->po2_pw) 182 #define pwent_cnt (Perl_po2()->po2_pwent_cnt) 183 #define _my_pwent (Perl_po2()->po2__my_pwent) 184 #define pthreads_state_buf (Perl_po2()->po2_pthreads_state_buf) 185 #define os2error_buf (Perl_po2()->po2_os2error_buf) 186 /* There is no big sense to make it thread-specific, since signals 187 are delivered to thread 1 only. XXXX Maybe make it into an array? */ 188 #define spawn_pid (Perl_po2()->po2_spawn_pid) 189 #define spawn_killed (Perl_po2()->po2_spawn_killed) 190 #define DOS_harderr_state (Perl_po2()->po2_DOS_harderr_state) 191 #define DOS_suppression_state (Perl_po2()->po2_DOS_suppression_state) 192 193 #define at_exit_buf (Perl_po2()->po2_at_exit_buf) 194 #define longjmp_at_exit (Perl_po2()->po2_longjmp_at_exit) 195 #define emx_runtime_init (Perl_po2()->po2_emx_runtime_init) 196 #define emx_exception_init (Perl_po2()->po2_emx_exception_init) 197 #define emx_runtime_secondary (Perl_po2()->po2_emx_runtime_secondary) 198 199 const Perl_PFN * const pExtFCN = (Perl_po2()->po2_ExtFCN); 200 201 202 #if defined(USE_5005THREADS) || defined(USE_ITHREADS) 203 204 typedef void (*emx_startroutine)(void *); 205 typedef void* (*pthreads_startroutine)(void *); 206 207 enum pthreads_state { 208 pthreads_st_none = 0, 209 pthreads_st_run, 210 pthreads_st_exited, 211 pthreads_st_detached, 212 pthreads_st_waited, 213 pthreads_st_norun, 214 pthreads_st_exited_waited, 215 }; 216 const char * const pthreads_states[] = { 217 "uninit", 218 "running", 219 "exited", 220 "detached", 221 "waited for", 222 "could not start", 223 "exited, then waited on", 224 }; 225 226 enum pthread_exists { pthread_not_existant = -0xff }; 227 228 static const char* 229 pthreads_state_string(enum pthreads_state state) 230 { 231 if (state < 0 || state >= sizeof(pthreads_states)/sizeof(*pthreads_states)) { 232 snprintf(pthreads_state_buf, sizeof(pthreads_state_buf), 233 "unknown thread state %d", (int)state); 234 return pthreads_state_buf; 235 } 236 return pthreads_states[state]; 237 } 238 239 typedef struct { 240 void *status; 241 perl_cond cond; 242 enum pthreads_state state; 243 } thread_join_t; 244 245 thread_join_t *thread_join_data; 246 int thread_join_count; 247 perl_mutex start_thread_mutex; 248 static perl_mutex perlos2_state_mutex; 249 250 251 int 252 pthread_join(perl_os_thread tid, void **status) 253 { 254 MUTEX_LOCK(&start_thread_mutex); 255 if (tid < 1 || tid >= thread_join_count) { 256 MUTEX_UNLOCK(&start_thread_mutex); 257 if (tid != pthread_not_existant) 258 Perl_croak_nocontext("panic: join with a thread with strange ordinal %d", (int)tid); 259 Perl_warn_nocontext("panic: join with a thread which could not start"); 260 *status = 0; 261 return 0; 262 } 263 switch (thread_join_data[tid].state) { 264 case pthreads_st_exited: 265 thread_join_data[tid].state = pthreads_st_exited_waited; 266 *status = thread_join_data[tid].status; 267 MUTEX_UNLOCK(&start_thread_mutex); 268 COND_SIGNAL(&thread_join_data[tid].cond); 269 break; 270 case pthreads_st_waited: 271 MUTEX_UNLOCK(&start_thread_mutex); 272 Perl_croak_nocontext("join with a thread with a waiter"); 273 break; 274 case pthreads_st_norun: 275 { 276 int state = (int)thread_join_data[tid].status; 277 278 thread_join_data[tid].state = pthreads_st_none; 279 MUTEX_UNLOCK(&start_thread_mutex); 280 Perl_croak_nocontext("panic: join with a thread which could not run" 281 " due to attempt of tid reuse (state='%s')", 282 pthreads_state_string(state)); 283 break; 284 } 285 case pthreads_st_run: 286 { 287 perl_cond cond; 288 289 thread_join_data[tid].state = pthreads_st_waited; 290 thread_join_data[tid].status = (void *)status; 291 COND_INIT(&thread_join_data[tid].cond); 292 cond = thread_join_data[tid].cond; 293 COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex); 294 COND_DESTROY(&cond); 295 MUTEX_UNLOCK(&start_thread_mutex); 296 break; 297 } 298 default: 299 MUTEX_UNLOCK(&start_thread_mutex); 300 Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'", 301 pthreads_state_string(thread_join_data[tid].state)); 302 break; 303 } 304 return 0; 305 } 306 307 typedef struct { 308 pthreads_startroutine sub; 309 void *arg; 310 void *ctx; 311 } pthr_startit; 312 313 /* The lock is used: 314 a) Since we temporarily usurp the caller interp, so malloc() may 315 use it to decide on debugging the call; 316 b) Since *args is on the caller's stack. 317 */ 318 void 319 pthread_startit(void *arg1) 320 { 321 /* Thread is already started, we need to transfer control only */ 322 pthr_startit args = *(pthr_startit *)arg1; 323 int tid = pthread_self(); 324 void *rc; 325 int state; 326 327 if (tid <= 1) { 328 /* Can't croak, the setjmp() is not in scope... */ 329 char buf[80]; 330 331 snprintf(buf, sizeof(buf), 332 "panic: thread with strange ordinal %d created\n\r", tid); 333 write(2,buf,strlen(buf)); 334 MUTEX_UNLOCK(&start_thread_mutex); 335 return; 336 } 337 /* Until args.sub resets it, makes debugging Perl_malloc() work: */ 338 PERL_SET_CONTEXT(0); 339 if (tid >= thread_join_count) { 340 int oc = thread_join_count; 341 342 thread_join_count = tid + 5 + tid/5; 343 if (thread_join_data) { 344 Renew(thread_join_data, thread_join_count, thread_join_t); 345 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t); 346 } else { 347 Newz(1323, thread_join_data, thread_join_count, thread_join_t); 348 } 349 } 350 if (thread_join_data[tid].state != pthreads_st_none) { 351 /* Can't croak, the setjmp() is not in scope... */ 352 char buf[80]; 353 354 snprintf(buf, sizeof(buf), 355 "panic: attempt to reuse thread id %d (state='%s')\n\r", 356 tid, pthreads_state_string(thread_join_data[tid].state)); 357 write(2,buf,strlen(buf)); 358 thread_join_data[tid].status = (void*)thread_join_data[tid].state; 359 thread_join_data[tid].state = pthreads_st_norun; 360 MUTEX_UNLOCK(&start_thread_mutex); 361 return; 362 } 363 thread_join_data[tid].state = pthreads_st_run; 364 /* Now that we copied/updated the guys, we may release the caller... */ 365 MUTEX_UNLOCK(&start_thread_mutex); 366 rc = (*args.sub)(args.arg); 367 MUTEX_LOCK(&start_thread_mutex); 368 switch (thread_join_data[tid].state) { 369 case pthreads_st_waited: 370 COND_SIGNAL(&thread_join_data[tid].cond); 371 thread_join_data[tid].state = pthreads_st_none; 372 *((void**)thread_join_data[tid].status) = rc; 373 break; 374 case pthreads_st_detached: 375 thread_join_data[tid].state = pthreads_st_none; 376 break; 377 case pthreads_st_run: 378 /* Somebody can wait on us; cannot exit, since OS can reuse the tid 379 and our waiter will get somebody else's status. */ 380 thread_join_data[tid].state = pthreads_st_exited; 381 thread_join_data[tid].status = rc; 382 COND_INIT(&thread_join_data[tid].cond); 383 COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex); 384 COND_DESTROY(&thread_join_data[tid].cond); 385 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */ 386 break; 387 default: 388 state = thread_join_data[tid].state; 389 MUTEX_UNLOCK(&start_thread_mutex); 390 Perl_croak_nocontext("panic: unexpected thread state on exit: '%s'", 391 pthreads_state_string(state)); 392 } 393 MUTEX_UNLOCK(&start_thread_mutex); 394 } 395 396 int 397 pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr, 398 void *(*start_routine)(void*), void *arg) 399 { 400 dTHX; 401 pthr_startit args; 402 403 args.sub = (void*)start_routine; 404 args.arg = arg; 405 args.ctx = PERL_GET_CONTEXT; 406 407 MUTEX_LOCK(&start_thread_mutex); 408 /* Test suite creates 31 extra threads; 409 on machine without shared-memory-hogs this stack sizeis OK with 31: */ 410 *tidp = _beginthread(pthread_startit, /*stack*/ NULL, 411 /*stacksize*/ 4*1024*1024, (void*)&args); 412 if (*tidp == -1) { 413 *tidp = pthread_not_existant; 414 MUTEX_UNLOCK(&start_thread_mutex); 415 return EINVAL; 416 } 417 MUTEX_LOCK(&start_thread_mutex); /* Wait for init to proceed */ 418 MUTEX_UNLOCK(&start_thread_mutex); 419 return 0; 420 } 421 422 int 423 pthread_detach(perl_os_thread tid) 424 { 425 MUTEX_LOCK(&start_thread_mutex); 426 if (tid < 1 || tid >= thread_join_count) { 427 MUTEX_UNLOCK(&start_thread_mutex); 428 if (tid != pthread_not_existant) 429 Perl_croak_nocontext("panic: detach of a thread with strange ordinal %d", (int)tid); 430 Perl_warn_nocontext("detach of a thread which could not start"); 431 return 0; 432 } 433 switch (thread_join_data[tid].state) { 434 case pthreads_st_waited: 435 MUTEX_UNLOCK(&start_thread_mutex); 436 Perl_croak_nocontext("detach on a thread with a waiter"); 437 break; 438 case pthreads_st_run: 439 thread_join_data[tid].state = pthreads_st_detached; 440 MUTEX_UNLOCK(&start_thread_mutex); 441 break; 442 case pthreads_st_exited: 443 MUTEX_UNLOCK(&start_thread_mutex); 444 COND_SIGNAL(&thread_join_data[tid].cond); 445 break; 446 case pthreads_st_detached: 447 MUTEX_UNLOCK(&start_thread_mutex); 448 Perl_warn_nocontext("detach on an already detached thread"); 449 break; 450 case pthreads_st_norun: 451 { 452 int state = (int)thread_join_data[tid].status; 453 454 thread_join_data[tid].state = pthreads_st_none; 455 MUTEX_UNLOCK(&start_thread_mutex); 456 Perl_croak_nocontext("panic: detaching thread which could not run" 457 " due to attempt of tid reuse (state='%s')", 458 pthreads_state_string(state)); 459 break; 460 } 461 default: 462 MUTEX_UNLOCK(&start_thread_mutex); 463 Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'", 464 pthreads_state_string(thread_join_data[tid].state)); 465 break; 466 } 467 return 0; 468 } 469 470 /* This is a very bastardized version; may be OK due to edge trigger of Wait */ 471 int 472 os2_cond_wait(perl_cond *c, perl_mutex *m) 473 { 474 int rc; 475 STRLEN n_a; 476 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET)) 477 Perl_rc = rc, croak_with_os2error("panic: COND_WAIT-reset"); 478 if (m) MUTEX_UNLOCK(m); 479 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT)) 480 && (rc != ERROR_INTERRUPT)) 481 croak_with_os2error("panic: COND_WAIT"); 482 if (rc == ERROR_INTERRUPT) 483 errno = EINTR; 484 if (m) MUTEX_LOCK(m); 485 return 0; 486 } 487 #endif 488 489 static int exe_is_aout(void); 490 491 /* This should match enum entries_ordinals defined in os2ish.h. */ 492 static const struct { 493 struct dll_handle_t *dll; 494 const char *entryname; 495 int entrypoint; 496 } loadOrdinals[] = { 497 {&doscalls_handle, NULL, 874}, /* DosQueryExtLibpath */ 498 {&doscalls_handle, NULL, 873}, /* DosSetExtLibpath */ 499 {&doscalls_handle, NULL, 460}, /* DosVerifyPidTid */ 500 {&tcp_handle, "SETHOSTENT", 0}, 501 {&tcp_handle, "SETNETENT" , 0}, 502 {&tcp_handle, "SETPROTOENT", 0}, 503 {&tcp_handle, "SETSERVENT", 0}, 504 {&tcp_handle, "GETHOSTENT", 0}, 505 {&tcp_handle, "GETNETENT" , 0}, 506 {&tcp_handle, "GETPROTOENT", 0}, 507 {&tcp_handle, "GETSERVENT", 0}, 508 {&tcp_handle, "ENDHOSTENT", 0}, 509 {&tcp_handle, "ENDNETENT", 0}, 510 {&tcp_handle, "ENDPROTOENT", 0}, 511 {&tcp_handle, "ENDSERVENT", 0}, 512 {&pmwin_handle, NULL, 763}, /* WinInitialize */ 513 {&pmwin_handle, NULL, 716}, /* WinCreateMsgQueue */ 514 {&pmwin_handle, NULL, 726}, /* WinDestroyMsgQueue */ 515 {&pmwin_handle, NULL, 918}, /* WinPeekMsg */ 516 {&pmwin_handle, NULL, 915}, /* WinGetMsg */ 517 {&pmwin_handle, NULL, 912}, /* WinDispatchMsg */ 518 {&pmwin_handle, NULL, 753}, /* WinGetLastError */ 519 {&pmwin_handle, NULL, 705}, /* WinCancelShutdown */ 520 /* These are needed in extensions. 521 How to protect PMSHAPI: it comes through EMX functions? */ 522 {&rexx_handle, "RexxStart", 0}, 523 {&rexx_handle, "RexxVariablePool", 0}, 524 {&rexxapi_handle, "RexxRegisterFunctionExe", 0}, 525 {&rexxapi_handle, "RexxDeregisterFunction", 0}, 526 {&sesmgr_handle, "DOSSMSETTITLE", 0}, /* Would not work runtime-loaded */ 527 {&pmshapi_handle, "PRF32QUERYPROFILESIZE", 0}, 528 {&pmshapi_handle, "PRF32OPENPROFILE", 0}, 529 {&pmshapi_handle, "PRF32CLOSEPROFILE", 0}, 530 {&pmshapi_handle, "PRF32QUERYPROFILE", 0}, 531 {&pmshapi_handle, "PRF32RESET", 0}, 532 {&pmshapi_handle, "PRF32QUERYPROFILEDATA", 0}, 533 {&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0}, 534 535 /* At least some of these do not work by name, since they need 536 WIN32 instead of WIN... */ 537 #if 0 538 These were generated with 539 nm I:\emx\lib\os2.a | fgrep -f API-list | grep = > API-list-entries 540 perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( ORD_$1,)" API-list-entries > API-list-ORD_ 541 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 542 #endif 543 {&pmshapi_handle, NULL, 123}, /* WinChangeSwitchEntry */ 544 {&pmshapi_handle, NULL, 124}, /* WinQuerySwitchEntry */ 545 {&pmshapi_handle, NULL, 125}, /* WinQuerySwitchHandle */ 546 {&pmshapi_handle, NULL, 126}, /* WinQuerySwitchList */ 547 {&pmshapi_handle, NULL, 131}, /* WinSwitchToProgram */ 548 {&pmwin_handle, NULL, 702}, /* WinBeginEnumWindows */ 549 {&pmwin_handle, NULL, 737}, /* WinEndEnumWindows */ 550 {&pmwin_handle, NULL, 740}, /* WinEnumDlgItem */ 551 {&pmwin_handle, NULL, 756}, /* WinGetNextWindow */ 552 {&pmwin_handle, NULL, 768}, /* WinIsChild */ 553 {&pmwin_handle, NULL, 799}, /* WinQueryActiveWindow */ 554 {&pmwin_handle, NULL, 805}, /* WinQueryClassName */ 555 {&pmwin_handle, NULL, 817}, /* WinQueryFocus */ 556 {&pmwin_handle, NULL, 834}, /* WinQueryWindow */ 557 {&pmwin_handle, NULL, 837}, /* WinQueryWindowPos */ 558 {&pmwin_handle, NULL, 838}, /* WinQueryWindowProcess */ 559 {&pmwin_handle, NULL, 841}, /* WinQueryWindowText */ 560 {&pmwin_handle, NULL, 842}, /* WinQueryWindowTextLength */ 561 {&pmwin_handle, NULL, 860}, /* WinSetFocus */ 562 {&pmwin_handle, NULL, 875}, /* WinSetWindowPos */ 563 {&pmwin_handle, NULL, 877}, /* WinSetWindowText */ 564 {&pmwin_handle, NULL, 883}, /* WinShowWindow */ 565 {&pmwin_handle, NULL, 772}, /* WinIsWindow */ 566 {&pmwin_handle, NULL, 899}, /* WinWindowFromId */ 567 {&pmwin_handle, NULL, 900}, /* WinWindowFromPoint */ 568 {&pmwin_handle, NULL, 919}, /* WinPostMsg */ 569 {&pmwin_handle, NULL, 735}, /* WinEnableWindow */ 570 {&pmwin_handle, NULL, 736}, /* WinEnableWindowUpdate */ 571 {&pmwin_handle, NULL, 773}, /* WinIsWindowEnabled */ 572 {&pmwin_handle, NULL, 774}, /* WinIsWindowShowing */ 573 {&pmwin_handle, NULL, 775}, /* WinIsWindowVisible */ 574 {&pmwin_handle, NULL, 839}, /* WinQueryWindowPtr */ 575 {&pmwin_handle, NULL, 843}, /* WinQueryWindowULong */ 576 {&pmwin_handle, NULL, 844}, /* WinQueryWindowUShort */ 577 {&pmwin_handle, NULL, 874}, /* WinSetWindowBits */ 578 {&pmwin_handle, NULL, 876}, /* WinSetWindowPtr */ 579 {&pmwin_handle, NULL, 878}, /* WinSetWindowULong */ 580 {&pmwin_handle, NULL, 879}, /* WinSetWindowUShort */ 581 {&pmwin_handle, NULL, 813}, /* WinQueryDesktopWindow */ 582 {&pmwin_handle, NULL, 851}, /* WinSetActiveWindow */ 583 {&doscalls_handle, NULL, 360}, /* DosQueryModFromEIP */ 584 {&doscalls_handle, NULL, 582}, /* Dos32QueryHeaderInfo */ 585 {&doscalls_handle, NULL, 362}, /* DosTmrQueryFreq */ 586 {&doscalls_handle, NULL, 363}, /* DosTmrQueryTime */ 587 {&pmwp_handle, NULL, 262}, /* WinQueryActiveDesktopPathname */ 588 {&pmwin_handle, NULL, 765}, /* WinInvalidateRect */ 589 {&pmwin_handle, NULL, 906}, /* WinCreateFrameControl */ 590 {&pmwin_handle, NULL, 807}, /* WinQueryClipbrdFmtInfo */ 591 {&pmwin_handle, NULL, 808}, /* WinQueryClipbrdOwner */ 592 {&pmwin_handle, NULL, 809}, /* WinQueryClipbrdViewer */ 593 {&pmwin_handle, NULL, 806}, /* WinQueryClipbrdData */ 594 {&pmwin_handle, NULL, 793}, /* WinOpenClipbrd */ 595 {&pmwin_handle, NULL, 707}, /* WinCloseClipbrd */ 596 {&pmwin_handle, NULL, 854}, /* WinSetClipbrdData */ 597 {&pmwin_handle, NULL, 855}, /* WinSetClipbrdOwner */ 598 {&pmwin_handle, NULL, 856}, /* WinSetClipbrdViewer */ 599 {&pmwin_handle, NULL, 739}, /* WinEnumClipbrdFmts */ 600 {&pmwin_handle, NULL, 733}, /* WinEmptyClipbrd */ 601 {&pmwin_handle, NULL, 700}, /* WinAddAtom */ 602 {&pmwin_handle, NULL, 744}, /* WinFindAtom */ 603 {&pmwin_handle, NULL, 721}, /* WinDeleteAtom */ 604 {&pmwin_handle, NULL, 803}, /* WinQueryAtomUsage */ 605 {&pmwin_handle, NULL, 802}, /* WinQueryAtomName */ 606 {&pmwin_handle, NULL, 801}, /* WinQueryAtomLength */ 607 {&pmwin_handle, NULL, 830}, /* WinQuerySystemAtomTable */ 608 {&pmwin_handle, NULL, 714}, /* WinCreateAtomTable */ 609 {&pmwin_handle, NULL, 724}, /* WinDestroyAtomTable */ 610 {&pmwin_handle, NULL, 794}, /* WinOpenWindowDC */ 611 {&pmgpi_handle, NULL, 610}, /* DevOpenDC */ 612 {&pmgpi_handle, NULL, 606}, /* DevQueryCaps */ 613 {&pmgpi_handle, NULL, 604}, /* DevCloseDC */ 614 {&pmwin_handle, NULL, 789}, /* WinMessageBox */ 615 {&pmwin_handle, NULL, 1015}, /* WinMessageBox2 */ 616 {&pmwin_handle, NULL, 829}, /* WinQuerySysValue */ 617 {&pmwin_handle, NULL, 873}, /* WinSetSysValue */ 618 {&pmwin_handle, NULL, 701}, /* WinAlarm */ 619 {&pmwin_handle, NULL, 745}, /* WinFlashWindow */ 620 {&pmwin_handle, NULL, 780}, /* WinLoadPointer */ 621 {&pmwin_handle, NULL, 828}, /* WinQuerySysPointer */ 622 {&doscalls_handle, NULL, 417}, /* DosReplaceModule */ 623 {&doscalls_handle, NULL, 976}, /* DosPerfSysCall */ 624 {&rexxapi_handle, "RexxRegisterSubcomExe", 0}, 625 }; 626 627 HMODULE 628 loadModule(const char *modname, int fail) 629 { 630 HMODULE h = (HMODULE)dlopen(modname, 0); 631 632 if (!h && fail) 633 Perl_croak_nocontext("Error loading module '%s': %s", 634 modname, dlerror()); 635 return h; 636 } 637 638 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */ 639 640 static int 641 my_type() 642 { 643 int rc; 644 TIB *tib; 645 PIB *pib; 646 647 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */ 648 if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) 649 return -1; 650 651 return (pib->pib_ultype); 652 } 653 654 static void 655 my_type_set(int type) 656 { 657 int rc; 658 TIB *tib; 659 PIB *pib; 660 661 if (!(_emx_env & 0x200)) 662 Perl_croak_nocontext("Can't set type on DOS"); /* not OS/2. */ 663 if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) 664 croak_with_os2error("Error getting info blocks"); 665 pib->pib_ultype = type; 666 } 667 668 PFN 669 loadByOrdinal(enum entries_ordinals ord, int fail) 670 { 671 if (sizeof(loadOrdinals)/sizeof(loadOrdinals[0]) != ORD_NENTRIES) 672 Perl_croak_nocontext( 673 "Wrong size of loadOrdinals array: expected %d, actual %d", 674 sizeof(loadOrdinals)/sizeof(loadOrdinals[0]), ORD_NENTRIES); 675 if (ExtFCN[ord] == NULL) { 676 PFN fcn = (PFN)-1; 677 APIRET rc; 678 679 if (!loadOrdinals[ord].dll->handle) { 680 if (loadOrdinals[ord].dll->requires_pm && my_type() < 2) { /* FS */ 681 char *s = getenv("PERL_ASIF_PM"); 682 683 if (!s || !atoi(s)) { 684 /* The module will not function well without PM. 685 The usual way to detect PM is the existence of the mutex 686 \SEM32\PMDRAG.SEM. */ 687 HMTX hMtx = 0; 688 689 if (CheckOSError(DosOpenMutexSem("\\SEM32\\PMDRAG.SEM", 690 &hMtx))) 691 Perl_croak_nocontext("Looks like we have no PM; will not load DLL %s without $ENV{PERL_ASIF_PM}", 692 loadOrdinals[ord].dll->modname); 693 DosCloseMutexSem(hMtx); 694 } 695 } 696 MUTEX_LOCK(&perlos2_state_mutex); 697 loadOrdinals[ord].dll->handle 698 = loadModule(loadOrdinals[ord].dll->modname, fail); 699 MUTEX_UNLOCK(&perlos2_state_mutex); 700 } 701 if (!loadOrdinals[ord].dll->handle) 702 return 0; /* Possible with FAIL==0 only */ 703 if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle, 704 loadOrdinals[ord].entrypoint, 705 loadOrdinals[ord].entryname,&fcn))) { 706 char buf[20], *s = (char*)loadOrdinals[ord].entryname; 707 708 if (!fail) 709 return 0; 710 if (!s) 711 sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint); 712 Perl_croak_nocontext( 713 "This version of OS/2 does not support %s.%s", 714 loadOrdinals[ord].dll->modname, s); 715 } 716 ExtFCN[ord] = fcn; 717 } 718 if ((long)ExtFCN[ord] == -1) 719 Perl_croak_nocontext("panic queryaddr"); 720 return ExtFCN[ord]; 721 } 722 723 void 724 init_PMWIN_entries(void) 725 { 726 int i; 727 728 for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++) 729 ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1); 730 } 731 732 /*****************************************************/ 733 /* socket forwarders without linking with tcpip DLLs */ 734 735 DeclFuncByORD(struct hostent *, gethostent, ORD_GETHOSTENT, (void), ()) 736 DeclFuncByORD(struct netent *, getnetent, ORD_GETNETENT, (void), ()) 737 DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ()) 738 DeclFuncByORD(struct servent *, getservent, ORD_GETSERVENT, (void), ()) 739 740 DeclVoidFuncByORD(sethostent, ORD_SETHOSTENT, (int x), (x)) 741 DeclVoidFuncByORD(setnetent, ORD_SETNETENT, (int x), (x)) 742 DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x)) 743 DeclVoidFuncByORD(setservent, ORD_SETSERVENT, (int x), (x)) 744 745 DeclVoidFuncByORD(endhostent, ORD_ENDHOSTENT, (void), ()) 746 DeclVoidFuncByORD(endnetent, ORD_ENDNETENT, (void), ()) 747 DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ()) 748 DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ()) 749 750 /* priorities */ 751 static const signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, 752 self inverse. */ 753 #define QSS_INI_BUFFER 1024 754 755 ULONG (*pDosVerifyPidTid) (PID pid, TID tid); 756 757 PQTOPLEVEL 758 get_sysinfo(ULONG pid, ULONG flags) 759 { 760 char *pbuffer; 761 ULONG rc, buf_len = QSS_INI_BUFFER; 762 PQTOPLEVEL psi; 763 764 if (pid) { 765 if (!pidtid_lookup) { 766 pidtid_lookup = 1; 767 *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0); 768 } 769 if (pDosVerifyPidTid) { /* Warp3 or later */ 770 /* Up to some fixpak QuerySysState() kills the system if a non-existent 771 pid is used. */ 772 if (CheckOSError(pDosVerifyPidTid(pid, 1))) 773 return 0; 774 } 775 } 776 New(1322, pbuffer, buf_len, char); 777 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */ 778 rc = QuerySysState(flags, pid, pbuffer, buf_len); 779 while (rc == ERROR_BUFFER_OVERFLOW) { 780 Renew(pbuffer, buf_len *= 2, char); 781 rc = QuerySysState(flags, pid, pbuffer, buf_len); 782 } 783 if (rc) { 784 FillOSError(rc); 785 Safefree(pbuffer); 786 return 0; 787 } 788 psi = (PQTOPLEVEL)pbuffer; 789 if (psi && pid && psi->procdata && pid != psi->procdata->pid) { 790 Safefree(psi); 791 Perl_croak_nocontext("panic: wrong pid in sysinfo"); 792 } 793 return psi; 794 } 795 796 #define PRIO_ERR 0x1111 797 798 static ULONG 799 sys_prio(pid) 800 { 801 ULONG prio; 802 PQTOPLEVEL psi; 803 804 if (!pid) 805 return PRIO_ERR; 806 psi = get_sysinfo(pid, QSS_PROCESS); 807 if (!psi) 808 return PRIO_ERR; 809 prio = psi->procdata->threads->priority; 810 Safefree(psi); 811 return prio; 812 } 813 814 int 815 setpriority(int which, int pid, int val) 816 { 817 ULONG rc, prio = sys_prio(pid); 818 819 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ 820 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) { 821 /* Do not change class. */ 822 return CheckOSError(DosSetPriority((pid < 0) 823 ? PRTYS_PROCESSTREE : PRTYS_PROCESS, 824 0, 825 (32 - val) % 32 - (prio & 0xFF), 826 abs(pid))) 827 ? -1 : 0; 828 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ { 829 /* Documentation claims one can change both class and basevalue, 830 * but I find it wrong. */ 831 /* Change class, but since delta == 0 denotes absolute 0, correct. */ 832 if (CheckOSError(DosSetPriority((pid < 0) 833 ? PRTYS_PROCESSTREE : PRTYS_PROCESS, 834 priors[(32 - val) >> 5] + 1, 835 0, 836 abs(pid)))) 837 return -1; 838 if ( ((32 - val) % 32) == 0 ) return 0; 839 return CheckOSError(DosSetPriority((pid < 0) 840 ? PRTYS_PROCESSTREE : PRTYS_PROCESS, 841 0, 842 (32 - val) % 32, 843 abs(pid))) 844 ? -1 : 0; 845 } 846 } 847 848 int 849 getpriority(int which /* ignored */, int pid) 850 { 851 ULONG ret; 852 853 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ 854 ret = sys_prio(pid); 855 if (ret == PRIO_ERR) { 856 return -1; 857 } 858 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF); 859 } 860 861 /*****************************************************************************/ 862 /* spawn */ 863 864 865 866 static Signal_t 867 spawn_sighandler(int sig) 868 { 869 /* Some programs do not arrange for the keyboard signals to be 870 delivered to them. We need to deliver the signal manually. */ 871 /* We may get a signal only if 872 a) kid does not receive keyboard signal: deliver it; 873 b) kid already died, and we get a signal. We may only hope 874 that the pid number was not reused. 875 */ 876 877 if (spawn_killed) 878 sig = SIGKILL; /* Try harder. */ 879 kill(spawn_pid, sig); 880 spawn_killed = 1; 881 } 882 883 static int 884 result(pTHX_ int flag, int pid) 885 { 886 int r, status; 887 Signal_t (*ihand)(); /* place to save signal during system() */ 888 Signal_t (*qhand)(); /* place to save signal during system() */ 889 #ifndef __EMX__ 890 RESULTCODES res; 891 int rpid; 892 #endif 893 894 if (pid < 0 || flag != 0) 895 return pid; 896 897 #ifdef __EMX__ 898 spawn_pid = pid; 899 spawn_killed = 0; 900 ihand = rsignal(SIGINT, &spawn_sighandler); 901 qhand = rsignal(SIGQUIT, &spawn_sighandler); 902 do { 903 r = wait4pid(pid, &status, 0); 904 } while (r == -1 && errno == EINTR); 905 rsignal(SIGINT, ihand); 906 rsignal(SIGQUIT, qhand); 907 908 PL_statusvalue = (U16)status; 909 if (r < 0) 910 return -1; 911 return status & 0xFFFF; 912 #else 913 ihand = rsignal(SIGINT, SIG_IGN); 914 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid); 915 rsignal(SIGINT, ihand); 916 PL_statusvalue = res.codeResult << 8 | res.codeTerminate; 917 if (r) 918 return -1; 919 return PL_statusvalue; 920 #endif 921 } 922 923 enum execf_t { 924 EXECF_SPAWN, 925 EXECF_EXEC, 926 EXECF_TRUEEXEC, 927 EXECF_SPAWN_NOWAIT, 928 EXECF_SPAWN_BYFLAG, 929 EXECF_SYNC 930 }; 931 932 static ULONG 933 file_type(char *path) 934 { 935 int rc; 936 ULONG apptype; 937 938 if (!(_emx_env & 0x200)) 939 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */ 940 if (CheckOSError(DosQueryAppType(path, &apptype))) { 941 switch (rc) { 942 case ERROR_FILE_NOT_FOUND: 943 case ERROR_PATH_NOT_FOUND: 944 return -1; 945 case ERROR_ACCESS_DENIED: /* Directory with this name found? */ 946 return -3; 947 default: /* Found, but not an 948 executable, or some other 949 read error. */ 950 return -2; 951 } 952 } 953 return apptype; 954 } 955 956 /* Spawn/exec a program, revert to shell if needed. */ 957 /* global PL_Argv[] contains arguments. */ 958 959 extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *, 960 EXCEPTIONREGISTRATIONRECORD *, 961 CONTEXTRECORD *, 962 void *); 963 964 int 965 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) 966 { 967 int trueflag = flag; 968 int rc, pass = 1; 969 char *real_name; 970 char const * args[4]; 971 static const char * const fargs[4] 972 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", }; 973 const char * const *argsp = fargs; 974 int nargs = 4; 975 int force_shell; 976 int new_stderr = -1, nostderr = 0; 977 int fl_stderr = 0; 978 STRLEN n_a; 979 char *buf; 980 PerlIO *file; 981 982 if (flag == P_WAIT) 983 flag = P_NOWAIT; 984 if (really && !*(real_name = SvPV(really, n_a))) 985 really = Nullsv; 986 987 retry: 988 if (strEQ(PL_Argv[0],"/bin/sh")) 989 PL_Argv[0] = PL_sh_path; 990 991 /* We should check PERL_SH* and PERLLIB_* as well? */ 992 if (!really || pass >= 2) 993 real_name = PL_Argv[0]; 994 if (real_name[0] != '/' && real_name[0] != '\\' 995 && !(real_name[0] && real_name[1] == ':' 996 && (real_name[2] == '/' || real_name[2] != '\\')) 997 ) /* will spawnvp use PATH? */ 998 TAINT_ENV(); /* testing IFS here is overkill, probably */ 999 1000 reread: 1001 force_shell = 0; 1002 if (_emx_env & 0x200) { /* OS/2. */ 1003 int type = file_type(real_name); 1004 type_again: 1005 if (type == -1) { /* Not found */ 1006 errno = ENOENT; 1007 rc = -1; 1008 goto do_script; 1009 } 1010 else if (type == -2) { /* Not an EXE */ 1011 errno = ENOEXEC; 1012 rc = -1; 1013 goto do_script; 1014 } 1015 else if (type == -3) { /* Is a directory? */ 1016 /* Special-case this */ 1017 char tbuf[512]; 1018 int l = strlen(real_name); 1019 1020 if (l + 5 <= sizeof tbuf) { 1021 strcpy(tbuf, real_name); 1022 strcpy(tbuf + l, ".exe"); 1023 type = file_type(tbuf); 1024 if (type >= -3) 1025 goto type_again; 1026 } 1027 1028 errno = ENOEXEC; 1029 rc = -1; 1030 goto do_script; 1031 } 1032 switch (type & 7) { 1033 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */ 1034 case FAPPTYP_WINDOWAPI: 1035 { /* Apparently, kids are started basing on startup type, not the morphed type */ 1036 if (os2_mytype != 3) { /* not PM */ 1037 if (flag == P_NOWAIT) 1038 flag = P_PM; 1039 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION && ckWARN(WARN_EXEC)) 1040 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d", 1041 flag, os2_mytype); 1042 } 1043 } 1044 break; 1045 case FAPPTYP_NOTWINDOWCOMPAT: 1046 { 1047 if (os2_mytype != 0) { /* not full screen */ 1048 if (flag == P_NOWAIT) 1049 flag = P_SESSION; 1050 else if ((flag & 7) != P_SESSION && ckWARN(WARN_EXEC)) 1051 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d", 1052 flag, os2_mytype); 1053 } 1054 } 1055 break; 1056 case FAPPTYP_NOTSPEC: 1057 /* Let the shell handle this... */ 1058 force_shell = 1; 1059 buf = ""; /* Pacify a warning */ 1060 file = 0; /* Pacify a warning */ 1061 goto doshell_args; 1062 break; 1063 } 1064 } 1065 1066 if (addflag) { 1067 addflag = 0; 1068 new_stderr = dup(2); /* Preserve stderr */ 1069 if (new_stderr == -1) { 1070 if (errno == EBADF) 1071 nostderr = 1; 1072 else { 1073 rc = -1; 1074 goto finish; 1075 } 1076 } else 1077 fl_stderr = fcntl(2, F_GETFD); 1078 rc = dup2(1,2); 1079 if (rc == -1) 1080 goto finish; 1081 fcntl(new_stderr, F_SETFD, FD_CLOEXEC); 1082 } 1083 1084 #if 0 1085 rc = result(aTHX_ trueflag, spawnvp(flag,real_name,PL_Argv)); 1086 #else 1087 if (execf == EXECF_TRUEEXEC) 1088 rc = execvp(real_name,PL_Argv); 1089 else if (execf == EXECF_EXEC) 1090 rc = spawnvp(trueflag | P_OVERLAY,real_name,PL_Argv); 1091 else if (execf == EXECF_SPAWN_NOWAIT) 1092 rc = spawnvp(flag,real_name,PL_Argv); 1093 else if (execf == EXECF_SYNC) 1094 rc = spawnvp(trueflag,real_name,PL_Argv); 1095 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */ 1096 rc = result(aTHX_ trueflag, 1097 spawnvp(flag,real_name,PL_Argv)); 1098 #endif 1099 if (rc < 0 && pass == 1) { 1100 do_script: 1101 if (real_name == PL_Argv[0]) { 1102 int err = errno; 1103 1104 if (err == ENOENT || err == ENOEXEC) { 1105 /* No such file, or is a script. */ 1106 /* Try adding script extensions to the file name, and 1107 search on PATH. */ 1108 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0); 1109 1110 if (scr) { 1111 char *s = 0, *s1; 1112 SV *scrsv = sv_2mortal(newSVpv(scr, 0)); 1113 SV *bufsv = sv_newmortal(); 1114 1115 Safefree(scr); 1116 scr = SvPV(scrsv, n_a); /* free()ed later */ 1117 1118 file = PerlIO_open(scr, "r"); 1119 PL_Argv[0] = scr; 1120 if (!file) 1121 goto panic_file; 1122 1123 buf = sv_gets(bufsv, file, 0 /* No append */); 1124 if (!buf) 1125 buf = ""; /* XXX Needed? */ 1126 if (!buf[0]) { /* Empty... */ 1127 PerlIO_close(file); 1128 /* Special case: maybe from -Zexe build, so 1129 there is an executable around (contrary to 1130 documentation, DosQueryAppType sometimes (?) 1131 does not append ".exe", so we could have 1132 reached this place). */ 1133 sv_catpv(scrsv, ".exe"); 1134 PL_Argv[0] = scr = SvPV(scrsv, n_a); /* Reload */ 1135 if (PerlLIO_stat(scr,&PL_statbuf) >= 0 1136 && !S_ISDIR(PL_statbuf.st_mode)) { /* Found */ 1137 real_name = scr; 1138 pass++; 1139 goto reread; 1140 } else { /* Restore */ 1141 SvCUR_set(scrsv, SvCUR(scrsv) - 4); 1142 *SvEND(scrsv) = 0; 1143 } 1144 } 1145 if (PerlIO_close(file) != 0) { /* Failure */ 1146 panic_file: 1147 if (ckWARN(WARN_EXEC)) 1148 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s", 1149 scr, Strerror(errno)); 1150 buf = ""; /* Not #! */ 1151 goto doshell_args; 1152 } 1153 if (buf[0] == '#') { 1154 if (buf[1] == '!') 1155 s = buf + 2; 1156 } else if (buf[0] == 'e') { 1157 if (strnEQ(buf, "extproc", 7) 1158 && isSPACE(buf[7])) 1159 s = buf + 8; 1160 } else if (buf[0] == 'E') { 1161 if (strnEQ(buf, "EXTPROC", 7) 1162 && isSPACE(buf[7])) 1163 s = buf + 8; 1164 } 1165 if (!s) { 1166 buf = ""; /* Not #! */ 1167 goto doshell_args; 1168 } 1169 1170 s1 = s; 1171 nargs = 0; 1172 argsp = args; 1173 while (1) { 1174 /* Do better than pdksh: allow a few args, 1175 strip trailing whitespace. */ 1176 while (isSPACE(*s)) 1177 s++; 1178 if (*s == 0) 1179 break; 1180 if (nargs == 4) { 1181 nargs = -1; 1182 break; 1183 } 1184 args[nargs++] = s; 1185 while (*s && !isSPACE(*s)) 1186 s++; 1187 if (*s == 0) 1188 break; 1189 *s++ = 0; 1190 } 1191 if (nargs == -1) { 1192 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"", 1193 s1 - buf, buf, scr); 1194 nargs = 4; 1195 argsp = fargs; 1196 } 1197 /* Can jump from far, buf/file invalid if force_shell: */ 1198 doshell_args: 1199 { 1200 char **a = PL_Argv; 1201 const char *exec_args[2]; 1202 1203 if (force_shell 1204 || (!buf[0] && file)) { /* File without magic */ 1205 /* In fact we tried all what pdksh would 1206 try. There is no point in calling 1207 pdksh, we may just emulate its logic. */ 1208 char *shell = getenv("EXECSHELL"); 1209 char *shell_opt = NULL; 1210 1211 if (!shell) { 1212 char *s; 1213 1214 shell_opt = "/c"; 1215 shell = getenv("OS2_SHELL"); 1216 if (inicmd) { /* No spaces at start! */ 1217 s = inicmd; 1218 while (*s && !isSPACE(*s)) { 1219 if (*s++ == '/') { 1220 inicmd = NULL; /* Cannot use */ 1221 break; 1222 } 1223 } 1224 } 1225 if (!inicmd) { 1226 s = PL_Argv[0]; 1227 while (*s) { 1228 /* Dosish shells will choke on slashes 1229 in paths, fortunately, this is 1230 important for zeroth arg only. */ 1231 if (*s == '/') 1232 *s = '\\'; 1233 s++; 1234 } 1235 } 1236 } 1237 /* If EXECSHELL is set, we do not set */ 1238 1239 if (!shell) 1240 shell = ((_emx_env & 0x200) 1241 ? "c:/os2/cmd.exe" 1242 : "c:/command.com"); 1243 nargs = shell_opt ? 2 : 1; /* shell file args */ 1244 exec_args[0] = shell; 1245 exec_args[1] = shell_opt; 1246 argsp = exec_args; 1247 if (nargs == 2 && inicmd) { 1248 /* Use the original cmd line */ 1249 /* XXXX This is good only until we refuse 1250 quoted arguments... */ 1251 PL_Argv[0] = inicmd; 1252 PL_Argv[1] = Nullch; 1253 } 1254 } else if (!buf[0] && inicmd) { /* No file */ 1255 /* Start with the original cmdline. */ 1256 /* XXXX This is good only until we refuse 1257 quoted arguments... */ 1258 1259 PL_Argv[0] = inicmd; 1260 PL_Argv[1] = Nullch; 1261 nargs = 2; /* shell -c */ 1262 } 1263 1264 while (a[1]) /* Get to the end */ 1265 a++; 1266 a++; /* Copy finil NULL too */ 1267 while (a >= PL_Argv) { 1268 *(a + nargs) = *a; /* PL_Argv was preallocated to be 1269 long enough. */ 1270 a--; 1271 } 1272 while (--nargs >= 0) /* XXXX Discard const... */ 1273 PL_Argv[nargs] = (char*)argsp[nargs]; 1274 /* Enable pathless exec if #! (as pdksh). */ 1275 pass = (buf[0] == '#' ? 2 : 3); 1276 goto retry; 1277 } 1278 } 1279 /* Not found: restore errno */ 1280 errno = err; 1281 } 1282 } else if (errno == ENOEXEC) { /* Cannot transfer `real_name' via shell. */ 1283 if (rc < 0 && ckWARN(WARN_EXEC)) 1284 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s script `%s' with ARGV[0] being `%s'", 1285 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) 1286 ? "spawn" : "exec"), 1287 real_name, PL_Argv[0]); 1288 goto warned; 1289 } else if (errno == ENOENT) { /* Cannot transfer `real_name' via shell. */ 1290 if (rc < 0 && ckWARN(WARN_EXEC)) 1291 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)", 1292 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) 1293 ? "spawn" : "exec"), 1294 real_name, PL_Argv[0]); 1295 goto warned; 1296 } 1297 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */ 1298 char *no_dir = strrchr(PL_Argv[0], '/'); 1299 1300 /* Do as pdksh port does: if not found with /, try without 1301 path. */ 1302 if (no_dir) { 1303 PL_Argv[0] = no_dir + 1; 1304 pass++; 1305 goto retry; 1306 } 1307 } 1308 if (rc < 0 && ckWARN(WARN_EXEC)) 1309 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n", 1310 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) 1311 ? "spawn" : "exec"), 1312 real_name, Strerror(errno)); 1313 warned: 1314 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT) 1315 && ((trueflag & 0xFF) == P_WAIT)) 1316 rc = -1; 1317 1318 finish: 1319 if (new_stderr != -1) { /* How can we use error codes? */ 1320 dup2(new_stderr, 2); 1321 close(new_stderr); 1322 fcntl(2, F_SETFD, fl_stderr); 1323 } else if (nostderr) 1324 close(2); 1325 return rc; 1326 } 1327 1328 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */ 1329 int 1330 do_spawn3(pTHX_ char *cmd, int execf, int flag) 1331 { 1332 register char **a; 1333 register char *s; 1334 char *shell, *copt, *news = NULL; 1335 int rc, seenspace = 0, mergestderr = 0; 1336 1337 #ifdef TRYSHELL 1338 if ((shell = getenv("EMXSHELL")) != NULL) 1339 copt = "-c"; 1340 else if ((shell = getenv("SHELL")) != NULL) 1341 copt = "-c"; 1342 else if ((shell = getenv("COMSPEC")) != NULL) 1343 copt = "/C"; 1344 else 1345 shell = "cmd.exe"; 1346 #else 1347 /* Consensus on perl5-porters is that it is _very_ important to 1348 have a shell which will not change between computers with the 1349 same architecture, to avoid "action on a distance". 1350 And to have simple build, this shell should be sh. */ 1351 shell = PL_sh_path; 1352 copt = "-c"; 1353 #endif 1354 1355 while (*cmd && isSPACE(*cmd)) 1356 cmd++; 1357 1358 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) { 1359 STRLEN l = strlen(PL_sh_path); 1360 1361 New(1302, news, strlen(cmd) - 7 + l + 1, char); 1362 strcpy(news, PL_sh_path); 1363 strcpy(news + l, cmd + 7); 1364 cmd = news; 1365 } 1366 1367 /* save an extra exec if possible */ 1368 /* see if there are shell metacharacters in it */ 1369 1370 if (*cmd == '.' && isSPACE(cmd[1])) 1371 goto doshell; 1372 1373 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) 1374 goto doshell; 1375 1376 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ 1377 if (*s == '=') 1378 goto doshell; 1379 1380 for (s = cmd; *s; s++) { 1381 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { 1382 if (*s == '\n' && s[1] == '\0') { 1383 *s = '\0'; 1384 break; 1385 } else if (*s == '\\' && !seenspace) { 1386 continue; /* Allow backslashes in names */ 1387 } else if (*s == '>' && s >= cmd + 3 1388 && s[-1] == '2' && s[1] == '&' && s[2] == '1' 1389 && isSPACE(s[-2]) ) { 1390 char *t = s + 3; 1391 1392 while (*t && isSPACE(*t)) 1393 t++; 1394 if (!*t) { 1395 s[-2] = '\0'; 1396 mergestderr = 1; 1397 break; /* Allow 2>&1 as the last thing */ 1398 } 1399 } 1400 /* We do not convert this to do_spawn_ve since shell 1401 should be smart enough to start itself gloriously. */ 1402 doshell: 1403 if (execf == EXECF_TRUEEXEC) 1404 rc = execl(shell,shell,copt,cmd,(char*)0); 1405 else if (execf == EXECF_EXEC) 1406 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0); 1407 else if (execf == EXECF_SPAWN_NOWAIT) 1408 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0); 1409 else if (execf == EXECF_SPAWN_BYFLAG) 1410 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0); 1411 else { 1412 /* In the ak code internal P_NOWAIT is P_WAIT ??? */ 1413 if (execf == EXECF_SYNC) 1414 rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0); 1415 else 1416 rc = result(aTHX_ P_WAIT, 1417 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); 1418 if (rc < 0 && ckWARN(WARN_EXEC)) 1419 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s", 1420 (execf == EXECF_SPAWN ? "spawn" : "exec"), 1421 shell, Strerror(errno)); 1422 if (rc < 0) 1423 rc = -1; 1424 } 1425 if (news) 1426 Safefree(news); 1427 return rc; 1428 } else if (*s == ' ' || *s == '\t') { 1429 seenspace = 1; 1430 } 1431 } 1432 1433 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */ 1434 New(1303,PL_Argv, (s - cmd + 11) / 2, char*); 1435 PL_Cmd = savepvn(cmd, s-cmd); 1436 a = PL_Argv; 1437 for (s = PL_Cmd; *s;) { 1438 while (*s && isSPACE(*s)) s++; 1439 if (*s) 1440 *(a++) = s; 1441 while (*s && !isSPACE(*s)) s++; 1442 if (*s) 1443 *s++ = '\0'; 1444 } 1445 *a = Nullch; 1446 if (PL_Argv[0]) 1447 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr); 1448 else 1449 rc = -1; 1450 if (news) 1451 Safefree(news); 1452 do_execfree(); 1453 return rc; 1454 } 1455 1456 /* Array spawn/exec. */ 1457 int 1458 os2_aspawn4(pTHX_ SV *really, register SV **vmark, register SV **vsp, int execing) 1459 { 1460 register SV **mark = (SV **)vmark; 1461 register SV **sp = (SV **)vsp; 1462 register char **a; 1463 int rc; 1464 int flag = P_WAIT, flag_set = 0; 1465 STRLEN n_a; 1466 1467 if (sp > mark) { 1468 New(1301,PL_Argv, sp - mark + 3, char*); 1469 a = PL_Argv; 1470 1471 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { 1472 ++mark; 1473 flag = SvIVx(*mark); 1474 flag_set = 1; 1475 1476 } 1477 1478 while (++mark <= sp) { 1479 if (*mark) 1480 *a++ = SvPVx(*mark, n_a); 1481 else 1482 *a++ = ""; 1483 } 1484 *a = Nullch; 1485 1486 if ( flag_set && (a == PL_Argv + 1) 1487 && !really && !execing ) { /* One arg? */ 1488 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag); 1489 } else 1490 rc = do_spawn_ve(aTHX_ really, flag, 1491 (execing ? EXECF_EXEC : EXECF_SPAWN), NULL, 0); 1492 } else 1493 rc = -1; 1494 do_execfree(); 1495 return rc; 1496 } 1497 1498 /* Array spawn. */ 1499 int 1500 os2_do_aspawn(pTHX_ SV *really, register SV **vmark, register SV **vsp) 1501 { 1502 return os2_aspawn4(aTHX_ really, vmark, vsp, 0); 1503 } 1504 1505 /* Array exec. */ 1506 bool 1507 Perl_do_aexec(pTHX_ SV* really, SV** vmark, SV** vsp) 1508 { 1509 return os2_aspawn4(aTHX_ really, vmark, vsp, 1); 1510 } 1511 1512 int 1513 os2_do_spawn(pTHX_ char *cmd) 1514 { 1515 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0); 1516 } 1517 1518 int 1519 do_spawn_nowait(pTHX_ char *cmd) 1520 { 1521 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0); 1522 } 1523 1524 bool 1525 Perl_do_exec(pTHX_ char *cmd) 1526 { 1527 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0); 1528 return FALSE; 1529 } 1530 1531 bool 1532 os2exec(pTHX_ char *cmd) 1533 { 1534 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0); 1535 } 1536 1537 PerlIO * 1538 my_syspopen(pTHX_ char *cmd, char *mode) 1539 { 1540 #ifndef USE_POPEN 1541 int p[2]; 1542 register I32 this, that, newfd; 1543 register I32 pid; 1544 SV *sv; 1545 int fh_fl = 0; /* Pacify the warning */ 1546 1547 /* `this' is what we use in the parent, `that' in the child. */ 1548 this = (*mode == 'w'); 1549 that = !this; 1550 if (PL_tainting) { 1551 taint_env(); 1552 taint_proper("Insecure %s%s", "EXEC"); 1553 } 1554 if (pipe(p) < 0) 1555 return Nullfp; 1556 /* Now we need to spawn the child. */ 1557 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */ 1558 int new = dup(p[this]); 1559 1560 if (new == -1) 1561 goto closepipes; 1562 close(p[this]); 1563 p[this] = new; 1564 } 1565 newfd = dup(*mode == 'r'); /* Preserve std* */ 1566 if (newfd == -1) { 1567 /* This cannot happen due to fh being bad after pipe(), since 1568 pipe() should have created fh 0 and 1 even if they were 1569 initially closed. But we closed p[this] before. */ 1570 if (errno != EBADF) { 1571 closepipes: 1572 close(p[0]); 1573 close(p[1]); 1574 return Nullfp; 1575 } 1576 } else 1577 fh_fl = fcntl(*mode == 'r', F_GETFD); 1578 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */ 1579 dup2(p[that], *mode == 'r'); 1580 close(p[that]); 1581 } 1582 /* Where is `this' and newfd now? */ 1583 fcntl(p[this], F_SETFD, FD_CLOEXEC); 1584 if (newfd != -1) 1585 fcntl(newfd, F_SETFD, FD_CLOEXEC); 1586 pid = do_spawn_nowait(aTHX_ cmd); 1587 if (newfd == -1) 1588 close(*mode == 'r'); /* It was closed initially */ 1589 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */ 1590 dup2(newfd, *mode == 'r'); /* Return std* back. */ 1591 close(newfd); 1592 fcntl(*mode == 'r', F_SETFD, fh_fl); 1593 } else 1594 fcntl(*mode == 'r', F_SETFD, fh_fl); 1595 if (p[that] == (*mode == 'r')) 1596 close(p[that]); 1597 if (pid == -1) { 1598 close(p[this]); 1599 return Nullfp; 1600 } 1601 if (p[that] < p[this]) { /* Make fh as small as possible */ 1602 dup2(p[this], p[that]); 1603 close(p[this]); 1604 p[this] = p[that]; 1605 } 1606 sv = *av_fetch(PL_fdpid,p[this],TRUE); 1607 (void)SvUPGRADE(sv,SVt_IV); 1608 SvIVX(sv) = pid; 1609 PL_forkprocess = pid; 1610 return PerlIO_fdopen(p[this], mode); 1611 1612 #else /* USE_POPEN */ 1613 1614 PerlIO *res; 1615 SV *sv; 1616 1617 # ifdef TRYSHELL 1618 res = popen(cmd, mode); 1619 # else 1620 char *shell = getenv("EMXSHELL"); 1621 1622 my_setenv("EMXSHELL", PL_sh_path); 1623 res = popen(cmd, mode); 1624 my_setenv("EMXSHELL", shell); 1625 # endif 1626 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE); 1627 (void)SvUPGRADE(sv,SVt_IV); 1628 SvIVX(sv) = -1; /* A cooky. */ 1629 return res; 1630 1631 #endif /* USE_POPEN */ 1632 1633 } 1634 1635 /******************************************************************/ 1636 1637 #ifndef HAS_FORK 1638 int 1639 fork(void) 1640 { 1641 Perl_croak_nocontext(PL_no_func, "Unsupported function fork"); 1642 errno = EINVAL; 1643 return -1; 1644 } 1645 #endif 1646 1647 /*******************************************************************/ 1648 /* not implemented in EMX 0.9d */ 1649 1650 char * ctermid(char *s) { return 0; } 1651 1652 #ifdef MYTTYNAME /* was not in emx0.9a */ 1653 void * ttyname(x) { return 0; } 1654 #endif 1655 1656 /*****************************************************************************/ 1657 /* not implemented in C Set++ */ 1658 1659 #ifndef __EMX__ 1660 int setuid(x) { errno = EINVAL; return -1; } 1661 int setgid(x) { errno = EINVAL; return -1; } 1662 #endif 1663 1664 /*****************************************************************************/ 1665 /* stat() hack for char/block device */ 1666 1667 #if OS2_STAT_HACK 1668 1669 enum os2_stat_extra { /* EMX 0.9d fix 4 defines up to 0100000 */ 1670 os2_stat_archived = 0x1000000, /* 0100000000 */ 1671 os2_stat_hidden = 0x2000000, /* 0200000000 */ 1672 os2_stat_system = 0x4000000, /* 0400000000 */ 1673 os2_stat_force = 0x8000000, /* Do not ignore flags on chmod */ 1674 }; 1675 1676 #define OS2_STAT_SPECIAL (os2_stat_system | os2_stat_archived | os2_stat_hidden) 1677 1678 static void 1679 massage_os2_attr(struct stat *st) 1680 { 1681 if ( ((st->st_mode & S_IFMT) != S_IFREG 1682 && (st->st_mode & S_IFMT) != S_IFDIR) 1683 || !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM))) 1684 return; 1685 1686 if ( st->st_attr & FILE_ARCHIVED ) 1687 st->st_mode |= (os2_stat_archived | os2_stat_force); 1688 if ( st->st_attr & FILE_HIDDEN ) 1689 st->st_mode |= (os2_stat_hidden | os2_stat_force); 1690 if ( st->st_attr & FILE_SYSTEM ) 1691 st->st_mode |= (os2_stat_system | os2_stat_force); 1692 } 1693 1694 /* First attempt used DosQueryFSAttach which crashed the system when 1695 used with 5.001. Now just look for /dev/. */ 1696 int 1697 os2_stat(const char *name, struct stat *st) 1698 { 1699 static int ino = SHRT_MAX; 1700 STRLEN l = strlen(name); 1701 1702 if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0 1703 || ( stricmp(name + 5, "con") != 0 1704 && stricmp(name + 5, "tty") != 0 1705 && stricmp(name + 5, "nul") != 0 1706 && stricmp(name + 5, "null") != 0) ) { 1707 int s = stat(name, st); 1708 1709 if (s) 1710 return s; 1711 massage_os2_attr(st); 1712 return 0; 1713 } 1714 1715 memset(st, 0, sizeof *st); 1716 st->st_mode = S_IFCHR|0666; 1717 MUTEX_LOCK(&perlos2_state_mutex); 1718 st->st_ino = (ino-- & 0x7FFF); 1719 MUTEX_UNLOCK(&perlos2_state_mutex); 1720 st->st_nlink = 1; 1721 return 0; 1722 } 1723 1724 int 1725 os2_fstat(int handle, struct stat *st) 1726 { 1727 int s = fstat(handle, st); 1728 1729 if (s) 1730 return s; 1731 massage_os2_attr(st); 1732 return 0; 1733 } 1734 1735 #undef chmod 1736 int 1737 os2_chmod (const char *name, int pmode) /* Modelled after EMX src/lib/io/chmod.c */ 1738 { 1739 int attr, rc; 1740 1741 if (!(pmode & os2_stat_force)) 1742 return chmod(name, pmode); 1743 1744 attr = __chmod (name, 0, 0); /* Get attributes */ 1745 if (attr < 0) 1746 return -1; 1747 if (pmode & S_IWRITE) 1748 attr &= ~FILE_READONLY; 1749 else 1750 attr |= FILE_READONLY; 1751 /* New logic */ 1752 attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM); 1753 1754 if ( pmode & os2_stat_archived ) 1755 attr |= FILE_ARCHIVED; 1756 if ( pmode & os2_stat_hidden ) 1757 attr |= FILE_HIDDEN; 1758 if ( pmode & os2_stat_system ) 1759 attr |= FILE_SYSTEM; 1760 1761 rc = __chmod (name, 1, attr); 1762 if (rc >= 0) rc = 0; 1763 return rc; 1764 } 1765 1766 #endif 1767 1768 #ifdef USE_PERL_SBRK 1769 1770 /* SBRK() emulation, mostly moved to malloc.c. */ 1771 1772 void * 1773 sys_alloc(int size) { 1774 void *got; 1775 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE); 1776 1777 if (rc == ERROR_NOT_ENOUGH_MEMORY) { 1778 return (void *) -1; 1779 } else if ( rc ) 1780 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc); 1781 return got; 1782 } 1783 1784 #endif /* USE_PERL_SBRK */ 1785 1786 /* tmp path */ 1787 1788 const char *tmppath = TMPPATH1; 1789 1790 void 1791 settmppath() 1792 { 1793 char *p = getenv("TMP"), *tpath; 1794 int len; 1795 1796 if (!p) p = getenv("TEMP"); 1797 if (!p) p = getenv("TMPDIR"); 1798 if (!p) return; 1799 len = strlen(p); 1800 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2); 1801 if (tpath) { 1802 strcpy(tpath, p); 1803 tpath[len] = '/'; 1804 strcpy(tpath + len + 1, TMPPATH1); 1805 tmppath = tpath; 1806 } 1807 } 1808 1809 #include "XSUB.h" 1810 1811 XS(XS_File__Copy_syscopy) 1812 { 1813 dXSARGS; 1814 if (items < 2 || items > 3) 1815 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)"); 1816 { 1817 STRLEN n_a; 1818 char * src = (char *)SvPV(ST(0),n_a); 1819 char * dst = (char *)SvPV(ST(1),n_a); 1820 U32 flag; 1821 int RETVAL, rc; 1822 dXSTARG; 1823 1824 if (items < 3) 1825 flag = 0; 1826 else { 1827 flag = (unsigned long)SvIV(ST(2)); 1828 } 1829 1830 RETVAL = !CheckOSError(DosCopy(src, dst, flag)); 1831 XSprePUSH; PUSHi((IV)RETVAL); 1832 } 1833 XSRETURN(1); 1834 } 1835 1836 /* APIRET APIENTRY DosReplaceModule (PCSZ pszOld, PCSZ pszNew, PCSZ pszBackup); */ 1837 1838 DeclOSFuncByORD(ULONG,replaceModule,ORD_DosReplaceModule, 1839 (char *old, char *new, char *backup), (old, new, backup)) 1840 1841 XS(XS_OS2_replaceModule); /* prototype to pass -Wmissing-prototypes */ 1842 XS(XS_OS2_replaceModule) 1843 { 1844 dXSARGS; 1845 if (items < 1 || items > 3) 1846 Perl_croak(aTHX_ "Usage: OS2::replaceModule(target [, source [, backup]])"); 1847 { 1848 char * target = (char *)SvPV_nolen(ST(0)); 1849 char * source = (items < 2) ? Nullch : (char *)SvPV_nolen(ST(1)); 1850 char * backup = (items < 3) ? Nullch : (char *)SvPV_nolen(ST(2)); 1851 1852 if (!replaceModule(target, source, backup)) 1853 croak_with_os2error("replaceModule() error"); 1854 } 1855 XSRETURN_EMPTY; 1856 } 1857 1858 /* APIRET APIENTRY DosPerfSysCall(ULONG ulCommand, ULONG ulParm1, 1859 ULONG ulParm2, ULONG ulParm3); */ 1860 1861 DeclOSFuncByORD(ULONG,perfSysCall,ORD_DosPerfSysCall, 1862 (ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3), 1863 (ulCommand, ulParm1, ulParm2, ulParm3)) 1864 1865 #ifndef CMD_KI_RDCNT 1866 # define CMD_KI_RDCNT 0x63 1867 #endif 1868 #ifndef CMD_KI_GETQTY 1869 # define CMD_KI_GETQTY 0x41 1870 #endif 1871 #ifndef QSV_NUMPROCESSORS 1872 # define QSV_NUMPROCESSORS 26 1873 #endif 1874 1875 typedef unsigned long long myCPUUTIL[4]; /* time/idle/busy/intr */ 1876 1877 /* 1878 NO_OUTPUT ULONG 1879 perfSysCall(ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3) 1880 PREINIT: 1881 ULONG rc; 1882 POSTCALL: 1883 if (!RETVAL) 1884 croak_with_os2error("perfSysCall() error"); 1885 */ 1886 1887 static int 1888 numprocessors(void) 1889 { 1890 ULONG res; 1891 1892 if (DosQuerySysInfo(QSV_NUMPROCESSORS, QSV_NUMPROCESSORS, (PVOID)&res, sizeof(res))) 1893 return 1; /* Old system? */ 1894 return res; 1895 } 1896 1897 XS(XS_OS2_perfSysCall); /* prototype to pass -Wmissing-prototypes */ 1898 XS(XS_OS2_perfSysCall) 1899 { 1900 dXSARGS; 1901 if (items < 0 || items > 4) 1902 Perl_croak(aTHX_ "Usage: OS2::perfSysCall(ulCommand = CMD_KI_RDCNT, ulParm1= 0, ulParm2= 0, ulParm3= 0)"); 1903 SP -= items; 1904 { 1905 dXSTARG; 1906 ULONG RETVAL, ulCommand, ulParm1, ulParm2, ulParm3, res; 1907 myCPUUTIL u[64]; 1908 int total = 0, tot2 = 0; 1909 1910 if (items < 1) 1911 ulCommand = CMD_KI_RDCNT; 1912 else { 1913 ulCommand = (ULONG)SvUV(ST(0)); 1914 } 1915 1916 if (items < 2) { 1917 total = (ulCommand == CMD_KI_RDCNT ? numprocessors() : 0); 1918 ulParm1 = (total ? (ULONG)u : 0); 1919 1920 if (total > C_ARRAY_LENGTH(u)) 1921 croak("Unexpected number of processors: %d", total); 1922 } else { 1923 ulParm1 = (ULONG)SvUV(ST(1)); 1924 } 1925 1926 if (items < 3) { 1927 tot2 = (ulCommand == CMD_KI_GETQTY); 1928 ulParm2 = (tot2 ? (ULONG)&res : 0); 1929 } else { 1930 ulParm2 = (ULONG)SvUV(ST(2)); 1931 } 1932 1933 if (items < 4) 1934 ulParm3 = 0; 1935 else { 1936 ulParm3 = (ULONG)SvUV(ST(3)); 1937 } 1938 1939 RETVAL = perfSysCall(ulCommand, ulParm1, ulParm2, ulParm3); 1940 if (!RETVAL) 1941 croak_with_os2error("perfSysCall() error"); 1942 if (total) { 1943 int i,j; 1944 1945 if (GIMME_V != G_ARRAY) { 1946 PUSHn(u[0][0]); /* Total ticks on the first processor */ 1947 XSRETURN(1); 1948 } 1949 for (i=0; i < total; i++) 1950 for (j=0; j < 4; j++) 1951 PUSHs(sv_2mortal(newSVnv(u[i][j]))); 1952 XSRETURN(4*total); 1953 } 1954 if (tot2) { 1955 PUSHu(res); 1956 XSRETURN(1); 1957 } 1958 } 1959 XSRETURN_EMPTY; 1960 } 1961 1962 #define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */ 1963 #include "patchlevel.h" 1964 #undef PERL_PATCHLEVEL_H_IMPLICIT 1965 1966 char * 1967 mod2fname(pTHX_ SV *sv) 1968 { 1969 int pos = 6, len, avlen; 1970 unsigned int sum = 0; 1971 char *s; 1972 STRLEN n_a; 1973 1974 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname"); 1975 sv = SvRV(sv); 1976 if (SvTYPE(sv) != SVt_PVAV) 1977 Perl_croak_nocontext("Not array reference given to mod2fname"); 1978 1979 avlen = av_len((AV*)sv); 1980 if (avlen < 0) 1981 Perl_croak_nocontext("Empty array reference given to mod2fname"); 1982 1983 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); 1984 strncpy(fname, s, 8); 1985 len = strlen(s); 1986 if (len < 6) pos = len; 1987 while (*s) { 1988 sum = 33 * sum + *(s++); /* Checksumming first chars to 1989 * get the capitalization into c.s. */ 1990 } 1991 avlen --; 1992 while (avlen >= 0) { 1993 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); 1994 while (*s) { 1995 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */ 1996 } 1997 avlen --; 1998 } 1999 /* We always load modules as *specific* DLLs, and with the full name. 2000 When loading a specific DLL by its full name, one cannot get a 2001 different DLL, even if a DLL with the same basename is loaded already. 2002 Thus there is no need to include the version into the mangling scheme. */ 2003 #if 0 2004 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */ 2005 #else 2006 # ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */ 2007 # define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2) 2008 # endif 2009 sum += COMPATIBLE_VERSION_SUM; 2010 #endif 2011 fname[pos] = 'A' + (sum % 26); 2012 fname[pos + 1] = 'A' + (sum / 26 % 26); 2013 fname[pos + 2] = '\0'; 2014 return (char *)fname; 2015 } 2016 2017 XS(XS_DynaLoader_mod2fname) 2018 { 2019 dXSARGS; 2020 if (items != 1) 2021 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)"); 2022 { 2023 SV * sv = ST(0); 2024 char * RETVAL; 2025 dXSTARG; 2026 2027 RETVAL = mod2fname(aTHX_ sv); 2028 sv_setpv(TARG, RETVAL); 2029 XSprePUSH; PUSHTARG; 2030 } 2031 XSRETURN(1); 2032 } 2033 2034 char * 2035 os2error(int rc) 2036 { 2037 dTHX; 2038 ULONG len; 2039 char *s; 2040 int number = SvTRUE(get_sv("OS2::nsyserror", TRUE)); 2041 2042 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */ 2043 if (rc == 0) 2044 return ""; 2045 if (number) { 2046 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc); 2047 s = os2error_buf + strlen(os2error_buf); 2048 } else 2049 s = os2error_buf; 2050 if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf), 2051 rc, "OSO001.MSG", &len)) { 2052 char *name = ""; 2053 2054 if (!number) { 2055 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc); 2056 s = os2error_buf + strlen(os2error_buf); 2057 } 2058 switch (rc) { 2059 case PMERR_INVALID_HWND: 2060 name = "PMERR_INVALID_HWND"; 2061 break; 2062 case PMERR_INVALID_HMQ: 2063 name = "PMERR_INVALID_HMQ"; 2064 break; 2065 case PMERR_CALL_FROM_WRONG_THREAD: 2066 name = "PMERR_CALL_FROM_WRONG_THREAD"; 2067 break; 2068 case PMERR_NO_MSG_QUEUE: 2069 name = "PMERR_NO_MSG_QUEUE"; 2070 break; 2071 case PMERR_NOT_IN_A_PM_SESSION: 2072 name = "PMERR_NOT_IN_A_PM_SESSION"; 2073 break; 2074 } 2075 sprintf(s, "%s%s[No description found in OSO001.MSG]", 2076 name, (*name ? "=" : "")); 2077 } else { 2078 s[len] = '\0'; 2079 if (len && s[len - 1] == '\n') 2080 s[--len] = 0; 2081 if (len && s[len - 1] == '\r') 2082 s[--len] = 0; 2083 if (len && s[len - 1] == '.') 2084 s[--len] = 0; 2085 if (len >= 10 && number && strnEQ(s, os2error_buf, 7) 2086 && s[7] == ':' && s[8] == ' ') 2087 /* Some messages start with SYSdddd:, some not */ 2088 Move(s + 9, s, (len -= 9) + 1, char); 2089 } 2090 return os2error_buf; 2091 } 2092 2093 void 2094 ResetWinError(void) 2095 { 2096 WinError_2_Perl_rc; 2097 } 2098 2099 void 2100 CroakWinError(int die, char *name) 2101 { 2102 FillWinError; 2103 if (die && Perl_rc) { 2104 dTHX; 2105 2106 Perl_croak(aTHX_ "%s: %s", (name ? name : "Win* API call"), os2error(Perl_rc)); 2107 } 2108 } 2109 2110 char * 2111 os2_execname(pTHX) 2112 { 2113 char buf[300], *p, *o = PL_origargv[0], ok = 1; 2114 2115 if (_execname(buf, sizeof buf) != 0) 2116 return o; 2117 p = buf; 2118 while (*p) { 2119 if (*p == '\\') 2120 *p = '/'; 2121 if (*p == '/') { 2122 if (ok && *o != '/' && *o != '\\') 2123 ok = 0; 2124 } else if (ok && tolower(*o) != tolower(*p)) 2125 ok = 0; 2126 p++; 2127 o++; 2128 } 2129 if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */ 2130 strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */ 2131 p = buf; 2132 while (*p) { 2133 if (*p == '\\') 2134 *p = '/'; 2135 p++; 2136 } 2137 } 2138 p = savepv(buf); 2139 SAVEFREEPV(p); 2140 return p; 2141 } 2142 2143 char * 2144 perllib_mangle(char *s, unsigned int l) 2145 { 2146 if (!newp && !notfound) { 2147 newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION) 2148 STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION) 2149 "_PREFIX"); 2150 if (!newp) 2151 newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION) 2152 STRINGIFY(PERL_VERSION) "_PREFIX"); 2153 if (!newp) 2154 newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX"); 2155 if (!newp) 2156 newp = getenv("PERLLIB_PREFIX"); 2157 if (newp) { 2158 char *s; 2159 2160 oldp = newp; 2161 while (*newp && !isSPACE(*newp) && *newp != ';') { 2162 newp++; oldl++; /* Skip digits. */ 2163 } 2164 while (*newp && (isSPACE(*newp) || *newp == ';')) { 2165 newp++; /* Skip whitespace. */ 2166 } 2167 newl = strlen(newp); 2168 if (newl == 0 || oldl == 0) { 2169 Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); 2170 } 2171 strcpy(mangle_ret, newp); 2172 s = mangle_ret; 2173 while (*s) { 2174 if (*s == '\\') *s = '/'; 2175 s++; 2176 } 2177 } else { 2178 notfound = 1; 2179 } 2180 } 2181 if (!newp) { 2182 return s; 2183 } 2184 if (l == 0) { 2185 l = strlen(s); 2186 } 2187 if (l < oldl || strnicmp(oldp, s, oldl) != 0) { 2188 return s; 2189 } 2190 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) { 2191 Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); 2192 } 2193 strcpy(mangle_ret + newl, s + oldl); 2194 return mangle_ret; 2195 } 2196 2197 unsigned long 2198 Perl_hab_GET() /* Needed if perl.h cannot be included */ 2199 { 2200 return perl_hab_GET(); 2201 } 2202 2203 static void 2204 Create_HMQ(int serve, char *message) /* Assumes morphing */ 2205 { 2206 unsigned fpflag = _control87(0,0); 2207 2208 init_PMWIN_entries(); 2209 /* 64 messages if before OS/2 3.0, ignored otherwise */ 2210 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64); 2211 if (!Perl_hmq) { 2212 dTHX; 2213 2214 SAVEINT(rmq_cnt); /* Allow catch()ing. */ 2215 if (rmq_cnt++) 2216 _exit(188); /* Panic can try to create a window. */ 2217 CroakWinError(1, message ? message : "Cannot create a message queue"); 2218 } 2219 if (serve != -1) 2220 (*PMWIN_entries.CancelShutdown)(Perl_hmq, !serve); 2221 /* We may have loaded some modules */ 2222 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */ 2223 } 2224 2225 #define REGISTERMQ_WILL_SERVE 1 2226 #define REGISTERMQ_IMEDIATE_UNMORPH 2 2227 2228 HMQ 2229 Perl_Register_MQ(int serve) 2230 { 2231 if (Perl_hmq_refcnt <= 0) { 2232 PPIB pib; 2233 PTIB tib; 2234 2235 Perl_hmq_refcnt = 0; /* Be extra safe */ 2236 DosGetInfoBlocks(&tib, &pib); 2237 if (!Perl_morph_refcnt) { 2238 Perl_os2_initial_mode = pib->pib_ultype; 2239 /* Try morphing into a PM application. */ 2240 if (pib->pib_ultype != 3) /* 2 is VIO */ 2241 pib->pib_ultype = 3; /* 3 is PM */ 2242 } 2243 Create_HMQ(-1, /* We do CancelShutdown ourselves */ 2244 "Cannot create a message queue, or morph to a PM application"); 2245 if ((serve & REGISTERMQ_IMEDIATE_UNMORPH)) { 2246 if (!Perl_morph_refcnt && Perl_os2_initial_mode != 3) 2247 pib->pib_ultype = Perl_os2_initial_mode; 2248 } 2249 } 2250 if (serve & REGISTERMQ_WILL_SERVE) { 2251 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */ 2252 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */ 2253 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0); 2254 Perl_hmq_servers++; 2255 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */ 2256 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); 2257 Perl_hmq_refcnt++; 2258 if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH)) 2259 Perl_morph_refcnt++; 2260 return Perl_hmq; 2261 } 2262 2263 int 2264 Perl_Serve_Messages(int force) 2265 { 2266 int cnt = 0; 2267 QMSG msg; 2268 2269 if (Perl_hmq_servers > 0 && !force) 2270 return 0; 2271 if (Perl_hmq_refcnt <= 0) 2272 Perl_croak_nocontext("No message queue"); 2273 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) { 2274 cnt++; 2275 if (msg.msg == WM_QUIT) 2276 Perl_croak_nocontext("QUITing..."); 2277 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); 2278 } 2279 return cnt; 2280 } 2281 2282 int 2283 Perl_Process_Messages(int force, I32 *cntp) 2284 { 2285 QMSG msg; 2286 2287 if (Perl_hmq_servers > 0 && !force) 2288 return 0; 2289 if (Perl_hmq_refcnt <= 0) 2290 Perl_croak_nocontext("No message queue"); 2291 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) { 2292 if (cntp) 2293 (*cntp)++; 2294 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); 2295 if (msg.msg == WM_DESTROY) 2296 return -1; 2297 if (msg.msg == WM_CREATE) 2298 return +1; 2299 } 2300 Perl_croak_nocontext("QUITing..."); 2301 } 2302 2303 void 2304 Perl_Deregister_MQ(int serve) 2305 { 2306 if (serve & REGISTERMQ_WILL_SERVE) 2307 Perl_hmq_servers--; 2308 2309 if (--Perl_hmq_refcnt <= 0) { 2310 unsigned fpflag = _control87(0,0); 2311 2312 init_PMWIN_entries(); /* To be extra safe */ 2313 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq); 2314 Perl_hmq = 0; 2315 /* We may have (un)loaded some modules */ 2316 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */ 2317 } else if ((serve & REGISTERMQ_WILL_SERVE) && Perl_hmq_servers <= 0) 2318 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); /* Last server exited */ 2319 if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH) && (--Perl_morph_refcnt <= 0)) { 2320 /* Try morphing back from a PM application. */ 2321 PPIB pib; 2322 PTIB tib; 2323 2324 DosGetInfoBlocks(&tib, &pib); 2325 if (pib->pib_ultype == 3) /* 3 is PM */ 2326 pib->pib_ultype = Perl_os2_initial_mode; 2327 else 2328 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM", 2329 pib->pib_ultype); 2330 } 2331 } 2332 2333 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \ 2334 && ((path)[2] == '/' || (path)[2] == '\\')) 2335 #define sys_is_rooted _fnisabs 2336 #define sys_is_relative _fnisrel 2337 #define current_drive _getdrive 2338 2339 #undef chdir /* Was _chdir2. */ 2340 #define sys_chdir(p) (chdir(p) == 0) 2341 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d))) 2342 2343 XS(XS_OS2_Error) 2344 { 2345 dXSARGS; 2346 if (items != 2) 2347 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)"); 2348 { 2349 int arg1 = SvIV(ST(0)); 2350 int arg2 = SvIV(ST(1)); 2351 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR) 2352 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION)); 2353 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0)); 2354 unsigned long rc; 2355 2356 if (CheckOSError(DosError(a))) 2357 Perl_croak_nocontext("DosError(%d) failed: %s", a, os2error(Perl_rc)); 2358 ST(0) = sv_newmortal(); 2359 if (DOS_harderr_state >= 0) 2360 sv_setiv(ST(0), DOS_harderr_state); 2361 DOS_harderr_state = RETVAL; 2362 } 2363 XSRETURN(1); 2364 } 2365 2366 XS(XS_OS2_Errors2Drive) 2367 { 2368 dXSARGS; 2369 if (items != 1) 2370 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)"); 2371 { 2372 STRLEN n_a; 2373 SV *sv = ST(0); 2374 int suppress = SvOK(sv); 2375 char *s = suppress ? SvPV(sv, n_a) : NULL; 2376 char drive = (s ? *s : 0); 2377 unsigned long rc; 2378 2379 if (suppress && !isALPHA(drive)) 2380 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive); 2381 if (CheckOSError(DosSuppressPopUps((suppress 2382 ? SPU_ENABLESUPPRESSION 2383 : SPU_DISABLESUPPRESSION), 2384 drive))) 2385 Perl_croak_nocontext("DosSuppressPopUps(%c) failed: %s", drive, 2386 os2error(Perl_rc)); 2387 ST(0) = sv_newmortal(); 2388 if (DOS_suppression_state > 0) 2389 sv_setpvn(ST(0), &DOS_suppression_state, 1); 2390 else if (DOS_suppression_state == 0) 2391 sv_setpvn(ST(0), "", 0); 2392 DOS_suppression_state = drive; 2393 } 2394 XSRETURN(1); 2395 } 2396 2397 ULONG (*pDosTmrQueryFreq) (PULONG); 2398 ULONG (*pDosTmrQueryTime) (unsigned long long *); 2399 2400 XS(XS_OS2_Timer) 2401 { 2402 dXSARGS; 2403 static ULONG freq; 2404 unsigned long long count; 2405 ULONG rc; 2406 2407 if (items != 0) 2408 Perl_croak_nocontext("Usage: OS2::Timer()"); 2409 if (!freq) { 2410 *(PFN*)&pDosTmrQueryFreq = loadByOrdinal(ORD_DosTmrQueryFreq, 0); 2411 *(PFN*)&pDosTmrQueryTime = loadByOrdinal(ORD_DosTmrQueryTime, 0); 2412 MUTEX_LOCK(&perlos2_state_mutex); 2413 if (!freq) 2414 if (CheckOSError(pDosTmrQueryFreq(&freq))) 2415 croak_with_os2error("DosTmrQueryFreq"); 2416 MUTEX_UNLOCK(&perlos2_state_mutex); 2417 } 2418 if (CheckOSError(pDosTmrQueryTime(&count))) 2419 croak_with_os2error("DosTmrQueryTime"); 2420 { 2421 dXSTARG; 2422 2423 XSprePUSH; PUSHn(((NV)count)/freq); 2424 } 2425 XSRETURN(1); 2426 } 2427 2428 static const char * const dc_fields[] = { 2429 "FAMILY", 2430 "IO_CAPS", 2431 "TECHNOLOGY", 2432 "DRIVER_VERSION", 2433 "WIDTH", 2434 "HEIGHT", 2435 "WIDTH_IN_CHARS", 2436 "HEIGHT_IN_CHARS", 2437 "HORIZONTAL_RESOLUTION", 2438 "VERTICAL_RESOLUTION", 2439 "CHAR_WIDTH", 2440 "CHAR_HEIGHT", 2441 "SMALL_CHAR_WIDTH", 2442 "SMALL_CHAR_HEIGHT", 2443 "COLORS", 2444 "COLOR_PLANES", 2445 "COLOR_BITCOUNT", 2446 "COLOR_TABLE_SUPPORT", 2447 "MOUSE_BUTTONS", 2448 "FOREGROUND_MIX_SUPPORT", 2449 "BACKGROUND_MIX_SUPPORT", 2450 "VIO_LOADABLE_FONTS", 2451 "WINDOW_BYTE_ALIGNMENT", 2452 "BITMAP_FORMATS", 2453 "RASTER_CAPS", 2454 "MARKER_HEIGHT", 2455 "MARKER_WIDTH", 2456 "DEVICE_FONTS", 2457 "GRAPHICS_SUBSET", 2458 "GRAPHICS_VERSION", 2459 "GRAPHICS_VECTOR_SUBSET", 2460 "DEVICE_WINDOWING", 2461 "ADDITIONAL_GRAPHICS", 2462 "PHYS_COLORS", 2463 "COLOR_INDEX", 2464 "GRAPHICS_CHAR_WIDTH", 2465 "GRAPHICS_CHAR_HEIGHT", 2466 "HORIZONTAL_FONT_RES", 2467 "VERTICAL_FONT_RES", 2468 "DEVICE_FONT_SIM", 2469 "LINEWIDTH_THICK", 2470 "DEVICE_POLYSET_POINTS", 2471 }; 2472 2473 enum { 2474 DevCap_dc, DevCap_hwnd 2475 }; 2476 2477 HDC (*pWinOpenWindowDC) (HWND hwnd); 2478 HMF (*pDevCloseDC) (HDC hdc); 2479 HDC (*pDevOpenDC) (HAB hab, LONG lType, PCSZ pszToken, LONG lCount, 2480 PDEVOPENDATA pdopData, HDC hdcComp); 2481 BOOL (*pDevQueryCaps) (HDC hdc, LONG lStart, LONG lCount, PLONG alArray); 2482 2483 2484 XS(XS_OS2_DevCap) 2485 { 2486 dXSARGS; 2487 if (items > 2) 2488 Perl_croak_nocontext("Usage: OS2::DevCap()"); 2489 { 2490 /* Device Capabilities Data Buffer (10 extra w.r.t. Warp 4.5) */ 2491 LONG si[CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1]; 2492 int i = 0, j = 0, how = DevCap_dc; 2493 HDC hScreenDC; 2494 DEVOPENSTRUC doStruc= {0L, (PSZ)"DISPLAY", NULL, 0L, 0L, 0L, 0L, 0L, 0L}; 2495 ULONG rc1 = NO_ERROR; 2496 HWND hwnd; 2497 static volatile int devcap_loaded; 2498 2499 if (!devcap_loaded) { 2500 *(PFN*)&pWinOpenWindowDC = loadByOrdinal(ORD_WinOpenWindowDC, 0); 2501 *(PFN*)&pDevOpenDC = loadByOrdinal(ORD_DevOpenDC, 0); 2502 *(PFN*)&pDevCloseDC = loadByOrdinal(ORD_DevCloseDC, 0); 2503 *(PFN*)&pDevQueryCaps = loadByOrdinal(ORD_DevQueryCaps, 0); 2504 devcap_loaded = 1; 2505 } 2506 2507 if (items >= 2) 2508 how = SvIV(ST(1)); 2509 if (!items) { /* Get device contents from PM */ 2510 hScreenDC = pDevOpenDC(perl_hab_GET(), OD_MEMORY, (PSZ)"*", 0, 2511 (PDEVOPENDATA)&doStruc, NULLHANDLE); 2512 if (CheckWinError(hScreenDC)) 2513 croak_with_os2error("DevOpenDC() failed"); 2514 } else if (how == DevCap_dc) 2515 hScreenDC = (HDC)SvIV(ST(0)); 2516 else { /* DevCap_hwnd */ 2517 if (!Perl_hmq) 2518 Perl_croak(aTHX_ "Getting a window's device context without a message queue would lock PM"); 2519 hwnd = (HWND)SvIV(ST(0)); 2520 hScreenDC = pWinOpenWindowDC(hwnd); /* No need to DevCloseDC() */ 2521 if (CheckWinError(hScreenDC)) 2522 croak_with_os2error("WinOpenWindowDC() failed"); 2523 } 2524 if (CheckWinError(pDevQueryCaps(hScreenDC, 2525 CAPS_FAMILY, /* W3 documented caps */ 2526 CAPS_DEVICE_POLYSET_POINTS 2527 - CAPS_FAMILY + 1, 2528 si))) 2529 rc1 = Perl_rc; 2530 if (!items && CheckWinError(pDevCloseDC(hScreenDC))) 2531 Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc)); 2532 if (rc1) 2533 Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed"); 2534 EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1)); 2535 while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) { 2536 ST(j) = sv_newmortal(); 2537 sv_setpv(ST(j++), dc_fields[i]); 2538 ST(j) = sv_newmortal(); 2539 sv_setiv(ST(j++), si[i]); 2540 i++; 2541 } 2542 } 2543 XSRETURN(2 * (CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1)); 2544 } 2545 2546 LONG (*pWinQuerySysValue) (HWND hwndDesktop, LONG iSysValue); 2547 BOOL (*pWinSetSysValue) (HWND hwndDesktop, LONG iSysValue, LONG lValue); 2548 2549 const char * const sv_keys[] = { 2550 "SWAPBUTTON", 2551 "DBLCLKTIME", 2552 "CXDBLCLK", 2553 "CYDBLCLK", 2554 "CXSIZEBORDER", 2555 "CYSIZEBORDER", 2556 "ALARM", 2557 "7", 2558 "8", 2559 "CURSORRATE", 2560 "FIRSTSCROLLRATE", 2561 "SCROLLRATE", 2562 "NUMBEREDLISTS", 2563 "WARNINGFREQ", 2564 "NOTEFREQ", 2565 "ERRORFREQ", 2566 "WARNINGDURATION", 2567 "NOTEDURATION", 2568 "ERRORDURATION", 2569 "19", 2570 "CXSCREEN", 2571 "CYSCREEN", 2572 "CXVSCROLL", 2573 "CYHSCROLL", 2574 "CYVSCROLLARROW", 2575 "CXHSCROLLARROW", 2576 "CXBORDER", 2577 "CYBORDER", 2578 "CXDLGFRAME", 2579 "CYDLGFRAME", 2580 "CYTITLEBAR", 2581 "CYVSLIDER", 2582 "CXHSLIDER", 2583 "CXMINMAXBUTTON", 2584 "CYMINMAXBUTTON", 2585 "CYMENU", 2586 "CXFULLSCREEN", 2587 "CYFULLSCREEN", 2588 "CXICON", 2589 "CYICON", 2590 "CXPOINTER", 2591 "CYPOINTER", 2592 "DEBUG", 2593 "CPOINTERBUTTONS", 2594 "POINTERLEVEL", 2595 "CURSORLEVEL", 2596 "TRACKRECTLEVEL", 2597 "CTIMERS", 2598 "MOUSEPRESENT", 2599 "CXALIGN", 2600 "CYALIGN", 2601 "DESKTOPWORKAREAYTOP", 2602 "DESKTOPWORKAREAYBOTTOM", 2603 "DESKTOPWORKAREAXRIGHT", 2604 "DESKTOPWORKAREAXLEFT", 2605 "55", 2606 "NOTRESERVED", 2607 "EXTRAKEYBEEP", 2608 "SETLIGHTS", 2609 "INSERTMODE", 2610 "60", 2611 "61", 2612 "62", 2613 "63", 2614 "MENUROLLDOWNDELAY", 2615 "MENUROLLUPDELAY", 2616 "ALTMNEMONIC", 2617 "TASKLISTMOUSEACCESS", 2618 "CXICONTEXTWIDTH", 2619 "CICONTEXTLINES", 2620 "CHORDTIME", 2621 "CXCHORD", 2622 "CYCHORD", 2623 "CXMOTIONSTART", 2624 "CYMOTIONSTART", 2625 "BEGINDRAG", 2626 "ENDDRAG", 2627 "SINGLESELECT", 2628 "OPEN", 2629 "CONTEXTMENU", 2630 "CONTEXTHELP", 2631 "TEXTEDIT", 2632 "BEGINSELECT", 2633 "ENDSELECT", 2634 "BEGINDRAGKB", 2635 "ENDDRAGKB", 2636 "SELECTKB", 2637 "OPENKB", 2638 "CONTEXTMENUKB", 2639 "CONTEXTHELPKB", 2640 "TEXTEDITKB", 2641 "BEGINSELECTKB", 2642 "ENDSELECTKB", 2643 "ANIMATION", 2644 "ANIMATIONSPEED", 2645 "MONOICONS", 2646 "KBDALTERED", 2647 "PRINTSCREEN", /* 97, the last one on one of the DDK header */ 2648 "LOCKSTARTINPUT", 2649 "DYNAMICDRAG", 2650 "100", 2651 "101", 2652 "102", 2653 "103", 2654 "104", 2655 "105", 2656 "106", 2657 "107", 2658 /* "CSYSVALUES",*/ 2659 /* In recent DDK the limit is 108 */ 2660 }; 2661 2662 XS(XS_OS2_SysValues) 2663 { 2664 dXSARGS; 2665 if (items > 2) 2666 Perl_croak_nocontext("Usage: OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP)"); 2667 { 2668 int i = 0, j = 0, which = -1; 2669 HWND hwnd = HWND_DESKTOP; 2670 static volatile int sv_loaded; 2671 LONG RETVAL; 2672 2673 if (!sv_loaded) { 2674 *(PFN*)&pWinQuerySysValue = loadByOrdinal(ORD_WinQuerySysValue, 0); 2675 sv_loaded = 1; 2676 } 2677 2678 if (items == 2) 2679 hwnd = (HWND)SvIV(ST(1)); 2680 if (items >= 1) 2681 which = (int)SvIV(ST(0)); 2682 if (which == -1) { 2683 EXTEND(SP,2*C_ARRAY_LENGTH(sv_keys)); 2684 while (i < C_ARRAY_LENGTH(sv_keys)) { 2685 ResetWinError(); 2686 RETVAL = pWinQuerySysValue(hwnd, i); 2687 if ( !RETVAL 2688 && !(sv_keys[i][0] >= '0' && sv_keys[i][0] <= '9' 2689 && i <= SV_PRINTSCREEN) ) { 2690 FillWinError; 2691 if (Perl_rc) { 2692 if (i > SV_PRINTSCREEN) 2693 break; /* May be not present on older systems */ 2694 croak_with_os2error("SysValues():"); 2695 } 2696 2697 } 2698 ST(j) = sv_newmortal(); 2699 sv_setpv(ST(j++), sv_keys[i]); 2700 ST(j) = sv_newmortal(); 2701 sv_setiv(ST(j++), RETVAL); 2702 i++; 2703 } 2704 XSRETURN(2 * i); 2705 } else { 2706 dXSTARG; 2707 2708 ResetWinError(); 2709 RETVAL = pWinQuerySysValue(hwnd, which); 2710 if (!RETVAL) { 2711 FillWinError; 2712 if (Perl_rc) 2713 croak_with_os2error("SysValues():"); 2714 } 2715 XSprePUSH; PUSHi((IV)RETVAL); 2716 } 2717 } 2718 } 2719 2720 XS(XS_OS2_SysValues_set) 2721 { 2722 dXSARGS; 2723 if (items < 2 || items > 3) 2724 Perl_croak_nocontext("Usage: OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP)"); 2725 { 2726 int which = (int)SvIV(ST(0)); 2727 LONG val = (LONG)SvIV(ST(1)); 2728 HWND hwnd = HWND_DESKTOP; 2729 static volatile int svs_loaded; 2730 2731 if (!svs_loaded) { 2732 *(PFN*)&pWinSetSysValue = loadByOrdinal(ORD_WinSetSysValue, 0); 2733 svs_loaded = 1; 2734 } 2735 2736 if (items == 3) 2737 hwnd = (HWND)SvIV(ST(2)); 2738 if (CheckWinError(pWinSetSysValue(hwnd, which, val))) 2739 croak_with_os2error("SysValues_set()"); 2740 } 2741 XSRETURN_EMPTY; 2742 } 2743 2744 #define QSV_MAX_WARP3 QSV_MAX_COMP_LENGTH 2745 2746 static const char * const si_fields[] = { 2747 "MAX_PATH_LENGTH", 2748 "MAX_TEXT_SESSIONS", 2749 "MAX_PM_SESSIONS", 2750 "MAX_VDM_SESSIONS", 2751 "BOOT_DRIVE", 2752 "DYN_PRI_VARIATION", 2753 "MAX_WAIT", 2754 "MIN_SLICE", 2755 "MAX_SLICE", 2756 "PAGE_SIZE", 2757 "VERSION_MAJOR", 2758 "VERSION_MINOR", 2759 "VERSION_REVISION", 2760 "MS_COUNT", 2761 "TIME_LOW", 2762 "TIME_HIGH", 2763 "TOTPHYSMEM", 2764 "TOTRESMEM", 2765 "TOTAVAILMEM", 2766 "MAXPRMEM", 2767 "MAXSHMEM", 2768 "TIMER_INTERVAL", 2769 "MAX_COMP_LENGTH", 2770 "FOREGROUND_FS_SESSION", 2771 "FOREGROUND_PROCESS", /* Warp 3 toolkit defines up to this */ 2772 "NUMPROCESSORS", 2773 "MAXHPRMEM", 2774 "MAXHSHMEM", 2775 "MAXPROCESSES", 2776 "VIRTUALADDRESSLIMIT", 2777 "INT10ENABLED", /* From $TOOLKIT-ddk\DDK\video\rel\os2c\include\base\os2\bsedos.h */ 2778 }; 2779 2780 XS(XS_OS2_SysInfo) 2781 { 2782 dXSARGS; 2783 if (items != 0) 2784 Perl_croak_nocontext("Usage: OS2::SysInfo()"); 2785 { 2786 /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */ 2787 ULONG si[C_ARRAY_LENGTH(si_fields) + 10]; 2788 APIRET rc = NO_ERROR; /* Return code */ 2789 int i = 0, j = 0, last = QSV_MAX_WARP3; 2790 2791 if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */ 2792 last, /* info for Warp 3 */ 2793 (PVOID)si, 2794 sizeof(si)))) 2795 croak_with_os2error("DosQuerySysInfo() failed"); 2796 while (last++ <= C_ARRAY_LENGTH(si)) { 2797 if (CheckOSError(DosQuerySysInfo(last, last, /* One entry only */ 2798 (PVOID)(si+last-1), 2799 sizeof(*si)))) { 2800 if (Perl_rc != ERROR_INVALID_PARAMETER) 2801 croak_with_os2error("DosQuerySysInfo() failed"); 2802 break; 2803 } 2804 } 2805 last--; 2806 EXTEND(SP,2*last); 2807 while (i < last) { 2808 ST(j) = sv_newmortal(); 2809 sv_setpv(ST(j++), si_fields[i]); 2810 ST(j) = sv_newmortal(); 2811 sv_setiv(ST(j++), si[i]); 2812 i++; 2813 } 2814 XSRETURN(2 * last); 2815 } 2816 } 2817 2818 XS(XS_OS2_SysInfoFor) 2819 { 2820 dXSARGS; 2821 int count = (items == 2 ? (int)SvIV(ST(1)) : 1); 2822 2823 if (items < 1 || items > 2) 2824 Perl_croak_nocontext("Usage: OS2::SysInfoFor(id[,count])"); 2825 { 2826 /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */ 2827 ULONG si[C_ARRAY_LENGTH(si_fields) + 10]; 2828 APIRET rc = NO_ERROR; /* Return code */ 2829 int i = 0; 2830 int start = (int)SvIV(ST(0)); 2831 2832 if (count > C_ARRAY_LENGTH(si) || count <= 0) 2833 Perl_croak(aTHX_ "unexpected count %d for OS2::SysInfoFor()", count); 2834 if (CheckOSError(DosQuerySysInfo(start, 2835 start + count - 1, 2836 (PVOID)si, 2837 sizeof(si)))) 2838 croak_with_os2error("DosQuerySysInfo() failed"); 2839 EXTEND(SP,count); 2840 while (i < count) { 2841 ST(i) = sv_newmortal(); 2842 sv_setiv(ST(i), si[i]); 2843 i++; 2844 } 2845 } 2846 XSRETURN(count); 2847 } 2848 2849 XS(XS_OS2_BootDrive) 2850 { 2851 dXSARGS; 2852 if (items != 0) 2853 Perl_croak_nocontext("Usage: OS2::BootDrive()"); 2854 { 2855 ULONG si[1] = {0}; /* System Information Data Buffer */ 2856 APIRET rc = NO_ERROR; /* Return code */ 2857 char c; 2858 dXSTARG; 2859 2860 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE, 2861 (PVOID)si, sizeof(si)))) 2862 croak_with_os2error("DosQuerySysInfo() failed"); 2863 c = 'a' - 1 + si[0]; 2864 sv_setpvn(TARG, &c, 1); 2865 XSprePUSH; PUSHTARG; 2866 } 2867 XSRETURN(1); 2868 } 2869 2870 XS(XS_OS2_Beep) 2871 { 2872 dXSARGS; 2873 if (items > 2) /* Defaults as for WinAlarm(ERROR) */ 2874 Perl_croak_nocontext("Usage: OS2::Beep(freq = 440, ms = 100)"); 2875 { 2876 ULONG freq = (items > 0 ? (ULONG)SvUV(ST(0)) : 440); 2877 ULONG ms = (items > 1 ? (ULONG)SvUV(ST(1)) : 100); 2878 ULONG rc; 2879 2880 if (CheckOSError(DosBeep(freq, ms))) 2881 croak_with_os2error("SysValues_set()"); 2882 } 2883 XSRETURN_EMPTY; 2884 } 2885 2886 2887 2888 XS(XS_OS2_MorphPM) 2889 { 2890 dXSARGS; 2891 if (items != 1) 2892 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)"); 2893 { 2894 bool serve = SvOK(ST(0)); 2895 unsigned long pmq = perl_hmq_GET(serve); 2896 dXSTARG; 2897 2898 XSprePUSH; PUSHi((IV)pmq); 2899 } 2900 XSRETURN(1); 2901 } 2902 2903 XS(XS_OS2_UnMorphPM) 2904 { 2905 dXSARGS; 2906 if (items != 1) 2907 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)"); 2908 { 2909 bool serve = SvOK(ST(0)); 2910 2911 perl_hmq_UNSET(serve); 2912 } 2913 XSRETURN(0); 2914 } 2915 2916 XS(XS_OS2_Serve_Messages) 2917 { 2918 dXSARGS; 2919 if (items != 1) 2920 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)"); 2921 { 2922 bool force = SvOK(ST(0)); 2923 unsigned long cnt = Perl_Serve_Messages(force); 2924 dXSTARG; 2925 2926 XSprePUSH; PUSHi((IV)cnt); 2927 } 2928 XSRETURN(1); 2929 } 2930 2931 XS(XS_OS2_Process_Messages) 2932 { 2933 dXSARGS; 2934 if (items < 1 || items > 2) 2935 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])"); 2936 { 2937 bool force = SvOK(ST(0)); 2938 unsigned long cnt; 2939 dXSTARG; 2940 2941 if (items == 2) { 2942 I32 cntr; 2943 SV *sv = ST(1); 2944 2945 (void)SvIV(sv); /* Force SvIVX */ 2946 if (!SvIOK(sv)) 2947 Perl_croak_nocontext("Can't upgrade count to IV"); 2948 cntr = SvIVX(sv); 2949 cnt = Perl_Process_Messages(force, &cntr); 2950 SvIVX(sv) = cntr; 2951 } else { 2952 cnt = Perl_Process_Messages(force, NULL); 2953 } 2954 XSprePUSH; PUSHi((IV)cnt); 2955 } 2956 XSRETURN(1); 2957 } 2958 2959 XS(XS_Cwd_current_drive) 2960 { 2961 dXSARGS; 2962 if (items != 0) 2963 Perl_croak_nocontext("Usage: Cwd::current_drive()"); 2964 { 2965 char RETVAL; 2966 dXSTARG; 2967 2968 RETVAL = current_drive(); 2969 sv_setpvn(TARG, (char *)&RETVAL, 1); 2970 XSprePUSH; PUSHTARG; 2971 } 2972 XSRETURN(1); 2973 } 2974 2975 XS(XS_Cwd_sys_chdir) 2976 { 2977 dXSARGS; 2978 if (items != 1) 2979 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)"); 2980 { 2981 STRLEN n_a; 2982 char * path = (char *)SvPV(ST(0),n_a); 2983 bool RETVAL; 2984 2985 RETVAL = sys_chdir(path); 2986 ST(0) = boolSV(RETVAL); 2987 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 2988 } 2989 XSRETURN(1); 2990 } 2991 2992 XS(XS_Cwd_change_drive) 2993 { 2994 dXSARGS; 2995 if (items != 1) 2996 Perl_croak_nocontext("Usage: Cwd::change_drive(d)"); 2997 { 2998 STRLEN n_a; 2999 char d = (char)*SvPV(ST(0),n_a); 3000 bool RETVAL; 3001 3002 RETVAL = change_drive(d); 3003 ST(0) = boolSV(RETVAL); 3004 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 3005 } 3006 XSRETURN(1); 3007 } 3008 3009 XS(XS_Cwd_sys_is_absolute) 3010 { 3011 dXSARGS; 3012 if (items != 1) 3013 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)"); 3014 { 3015 STRLEN n_a; 3016 char * path = (char *)SvPV(ST(0),n_a); 3017 bool RETVAL; 3018 3019 RETVAL = sys_is_absolute(path); 3020 ST(0) = boolSV(RETVAL); 3021 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 3022 } 3023 XSRETURN(1); 3024 } 3025 3026 XS(XS_Cwd_sys_is_rooted) 3027 { 3028 dXSARGS; 3029 if (items != 1) 3030 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)"); 3031 { 3032 STRLEN n_a; 3033 char * path = (char *)SvPV(ST(0),n_a); 3034 bool RETVAL; 3035 3036 RETVAL = sys_is_rooted(path); 3037 ST(0) = boolSV(RETVAL); 3038 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 3039 } 3040 XSRETURN(1); 3041 } 3042 3043 XS(XS_Cwd_sys_is_relative) 3044 { 3045 dXSARGS; 3046 if (items != 1) 3047 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)"); 3048 { 3049 STRLEN n_a; 3050 char * path = (char *)SvPV(ST(0),n_a); 3051 bool RETVAL; 3052 3053 RETVAL = sys_is_relative(path); 3054 ST(0) = boolSV(RETVAL); 3055 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 3056 } 3057 XSRETURN(1); 3058 } 3059 3060 XS(XS_Cwd_sys_cwd) 3061 { 3062 dXSARGS; 3063 if (items != 0) 3064 Perl_croak_nocontext("Usage: Cwd::sys_cwd()"); 3065 { 3066 char p[MAXPATHLEN]; 3067 char * RETVAL; 3068 3069 /* Can't use TARG, since tainting behaves differently */ 3070 RETVAL = _getcwd2(p, MAXPATHLEN); 3071 ST(0) = sv_newmortal(); 3072 sv_setpv(ST(0), RETVAL); 3073 #ifndef INCOMPLETE_TAINTS 3074 SvTAINTED_on(ST(0)); 3075 #endif 3076 } 3077 XSRETURN(1); 3078 } 3079 3080 XS(XS_Cwd_sys_abspath) 3081 { 3082 dXSARGS; 3083 if (items > 2) 3084 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path = '.', dir = NULL)"); 3085 { 3086 STRLEN n_a; 3087 char * path = items ? (char *)SvPV(ST(0),n_a) : "."; 3088 char * dir, *s, *t, *e; 3089 char p[MAXPATHLEN]; 3090 char * RETVAL; 3091 int l; 3092 SV *sv; 3093 3094 if (items < 2) 3095 dir = NULL; 3096 else { 3097 dir = (char *)SvPV(ST(1),n_a); 3098 } 3099 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) { 3100 path += 2; 3101 } 3102 if (dir == NULL) { 3103 if (_abspath(p, path, MAXPATHLEN) == 0) { 3104 RETVAL = p; 3105 } else { 3106 RETVAL = NULL; 3107 } 3108 } else { 3109 /* Absolute with drive: */ 3110 if ( sys_is_absolute(path) ) { 3111 if (_abspath(p, path, MAXPATHLEN) == 0) { 3112 RETVAL = p; 3113 } else { 3114 RETVAL = NULL; 3115 } 3116 } else if (path[0] == '/' || path[0] == '\\') { 3117 /* Rooted, but maybe on different drive. */ 3118 if (isALPHA(dir[0]) && dir[1] == ':' ) { 3119 char p1[MAXPATHLEN]; 3120 3121 /* Need to prepend the drive. */ 3122 p1[0] = dir[0]; 3123 p1[1] = dir[1]; 3124 Copy(path, p1 + 2, strlen(path) + 1, char); 3125 RETVAL = p; 3126 if (_abspath(p, p1, MAXPATHLEN) == 0) { 3127 RETVAL = p; 3128 } else { 3129 RETVAL = NULL; 3130 } 3131 } else if (_abspath(p, path, MAXPATHLEN) == 0) { 3132 RETVAL = p; 3133 } else { 3134 RETVAL = NULL; 3135 } 3136 } else { 3137 /* Either path is relative, or starts with a drive letter. */ 3138 /* If the path starts with a drive letter, then dir is 3139 relevant only if 3140 a/b) it is absolute/x:relative on the same drive. 3141 c) path is on current drive, and dir is rooted 3142 In all the cases it is safe to drop the drive part 3143 of the path. */ 3144 if ( !sys_is_relative(path) ) { 3145 if ( ( ( sys_is_absolute(dir) 3146 || (isALPHA(dir[0]) && dir[1] == ':' 3147 && strnicmp(dir, path,1) == 0)) 3148 && strnicmp(dir, path,1) == 0) 3149 || ( !(isALPHA(dir[0]) && dir[1] == ':') 3150 && toupper(path[0]) == current_drive())) { 3151 path += 2; 3152 } else if (_abspath(p, path, MAXPATHLEN) == 0) { 3153 RETVAL = p; goto done; 3154 } else { 3155 RETVAL = NULL; goto done; 3156 } 3157 } 3158 { 3159 /* Need to prepend the absolute path of dir. */ 3160 char p1[MAXPATHLEN]; 3161 3162 if (_abspath(p1, dir, MAXPATHLEN) == 0) { 3163 int l = strlen(p1); 3164 3165 if (p1[ l - 1 ] != '/') { 3166 p1[ l ] = '/'; 3167 l++; 3168 } 3169 Copy(path, p1 + l, strlen(path) + 1, char); 3170 if (_abspath(p, p1, MAXPATHLEN) == 0) { 3171 RETVAL = p; 3172 } else { 3173 RETVAL = NULL; 3174 } 3175 } else { 3176 RETVAL = NULL; 3177 } 3178 } 3179 done: 3180 } 3181 } 3182 if (!RETVAL) 3183 XSRETURN_EMPTY; 3184 /* Backslashes are already converted to slashes. */ 3185 /* Remove trailing slashes */ 3186 l = strlen(RETVAL); 3187 while (l > 0 && RETVAL[l-1] == '/') 3188 l--; 3189 ST(0) = sv_newmortal(); 3190 sv_setpvn( sv = (SV*)ST(0), RETVAL, l); 3191 /* Remove duplicate slashes, skipping the first three, which 3192 may be parts of a server-based path */ 3193 s = t = 3 + SvPV_force(sv, n_a); 3194 e = SvEND(sv); 3195 /* Do not worry about multibyte chars here, this would contradict the 3196 eventual UTFization, and currently most other places break too... */ 3197 while (s < e) { 3198 if (s[0] == t[-1] && s[0] == '/') 3199 s++; /* Skip duplicate / */ 3200 else 3201 *t++ = *s++; 3202 } 3203 if (t < e) { 3204 *t = 0; 3205 SvCUR_set(sv, t - SvPVX(sv)); 3206 } 3207 #ifndef INCOMPLETE_TAINTS 3208 if (!items) 3209 SvTAINTED_on(ST(0)); 3210 #endif 3211 } 3212 XSRETURN(1); 3213 } 3214 typedef APIRET (*PELP)(PSZ path, ULONG type); 3215 3216 /* Kernels after 2000/09/15 understand this too: */ 3217 #ifndef LIBPATHSTRICT 3218 # define LIBPATHSTRICT 3 3219 #endif 3220 3221 APIRET 3222 ExtLIBPATH(ULONG ord, PSZ path, IV type) 3223 { 3224 ULONG what; 3225 PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */ 3226 3227 if (type > 0) 3228 what = END_LIBPATH; 3229 else if (type == 0) 3230 what = BEGIN_LIBPATH; 3231 else 3232 what = LIBPATHSTRICT; 3233 return (*(PELP)f)(path, what); 3234 } 3235 3236 #define extLibpath(to,type) \ 3237 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) ) 3238 3239 #define extLibpath_set(p,type) \ 3240 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type)))) 3241 3242 XS(XS_Cwd_extLibpath) 3243 { 3244 dXSARGS; 3245 if (items < 0 || items > 1) 3246 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)"); 3247 { 3248 IV type; 3249 char to[1024]; 3250 U32 rc; 3251 char * RETVAL; 3252 dXSTARG; 3253 3254 if (items < 1) 3255 type = 0; 3256 else { 3257 type = SvIV(ST(0)); 3258 } 3259 3260 to[0] = 1; to[1] = 0; /* Sometimes no error reported */ 3261 RETVAL = extLibpath(to, type); 3262 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0) 3263 Perl_croak_nocontext("panic Cwd::extLibpath parameter"); 3264 sv_setpv(TARG, RETVAL); 3265 XSprePUSH; PUSHTARG; 3266 } 3267 XSRETURN(1); 3268 } 3269 3270 XS(XS_Cwd_extLibpath_set) 3271 { 3272 dXSARGS; 3273 if (items < 1 || items > 2) 3274 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)"); 3275 { 3276 STRLEN n_a; 3277 char * s = (char *)SvPV(ST(0),n_a); 3278 IV type; 3279 U32 rc; 3280 bool RETVAL; 3281 3282 if (items < 2) 3283 type = 0; 3284 else { 3285 type = SvIV(ST(1)); 3286 } 3287 3288 RETVAL = extLibpath_set(s, type); 3289 ST(0) = boolSV(RETVAL); 3290 if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); 3291 } 3292 XSRETURN(1); 3293 } 3294 3295 /* Input: Address, BufLen 3296 APIRET APIENTRY 3297 DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf, 3298 ULONG * Offset, ULONG Address); 3299 */ 3300 3301 DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP, 3302 (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf, 3303 ULONG * Offset, ULONG Address), 3304 (hmod, obj, BufLen, Buf, Offset, Address)) 3305 3306 enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full, 3307 mod_name_C_function = 0x100, mod_name_HMODULE = 0x200}; 3308 3309 static SV* 3310 module_name_at(void *pp, enum module_name_how how) 3311 { 3312 dTHX; 3313 char buf[MAXPATHLEN]; 3314 char *p = buf; 3315 HMODULE mod; 3316 ULONG obj, offset, rc, addr = (ULONG)pp; 3317 3318 if (how & mod_name_HMODULE) { 3319 if ((how & ~mod_name_HMODULE) == mod_name_shortname) 3320 Perl_croak(aTHX_ "Can't get short module name from a handle"); 3321 mod = (HMODULE)pp; 3322 how &= ~mod_name_HMODULE; 3323 } else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr)) 3324 return &PL_sv_undef; 3325 if (how == mod_name_handle) 3326 return newSVuv(mod); 3327 /* Full name... */ 3328 if ( how != mod_name_shortname 3329 && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) ) 3330 return &PL_sv_undef; 3331 while (*p) { 3332 if (*p == '\\') 3333 *p = '/'; 3334 p++; 3335 } 3336 return newSVpv(buf, 0); 3337 } 3338 3339 static SV* 3340 module_name_of_cv(SV *cv, enum module_name_how how) 3341 { 3342 if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) { 3343 dTHX; 3344 3345 if (how & mod_name_C_function) 3346 return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function); 3347 else if (how & mod_name_HMODULE) 3348 return module_name_at((void*)SvIV(cv), how); 3349 Perl_croak(aTHX_ "Not an XSUB reference"); 3350 } 3351 return module_name_at(CvXSUB(SvRV(cv)), how); 3352 } 3353 3354 /* Find module name to which *this* subroutine is compiled */ 3355 #define module_name(how) module_name_at(&module_name_at, how) 3356 3357 XS(XS_OS2_DLLname) 3358 { 3359 dXSARGS; 3360 if (items > 2) 3361 Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )"); 3362 { 3363 SV * RETVAL; 3364 int how; 3365 3366 if (items < 1) 3367 how = mod_name_full; 3368 else { 3369 how = (int)SvIV(ST(0)); 3370 } 3371 if (items < 2) 3372 RETVAL = module_name(how); 3373 else 3374 RETVAL = module_name_of_cv(ST(1), how); 3375 ST(0) = RETVAL; 3376 sv_2mortal(ST(0)); 3377 } 3378 XSRETURN(1); 3379 } 3380 3381 DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo, 3382 (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum), 3383 (r1, r2, buf, szbuf, fnum)) 3384 3385 XS(XS_OS2__headerInfo) 3386 { 3387 dXSARGS; 3388 if (items > 4 || items < 2) 3389 Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])"); 3390 { 3391 ULONG req = (ULONG)SvIV(ST(0)); 3392 STRLEN size = (STRLEN)SvIV(ST(1)), n_a; 3393 ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0); 3394 ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0); 3395 3396 if (size <= 0) 3397 Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size); 3398 ST(0) = newSVpvn("",0); 3399 SvGROW(ST(0), size + 1); 3400 sv_2mortal(ST(0)); 3401 3402 if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req)) 3403 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", 3404 req, size, handle, offset, os2error(Perl_rc)); 3405 SvCUR_set(ST(0), size); 3406 *SvEND(ST(0)) = 0; 3407 } 3408 XSRETURN(1); 3409 } 3410 3411 #define DQHI_QUERYLIBPATHSIZE 4 3412 #define DQHI_QUERYLIBPATH 5 3413 3414 XS(XS_OS2_libPath) 3415 { 3416 dXSARGS; 3417 if (items != 0) 3418 Perl_croak(aTHX_ "Usage: OS2::libPath()"); 3419 { 3420 ULONG size; 3421 STRLEN n_a; 3422 3423 if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size), 3424 DQHI_QUERYLIBPATHSIZE)) 3425 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", 3426 DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0, 3427 os2error(Perl_rc)); 3428 ST(0) = newSVpvn("",0); 3429 SvGROW(ST(0), size + 1); 3430 sv_2mortal(ST(0)); 3431 3432 /* We should be careful: apparently, this entry point does not 3433 pay attention to the size argument, so may overwrite 3434 unrelated data! */ 3435 if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size, 3436 DQHI_QUERYLIBPATH)) 3437 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", 3438 DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc)); 3439 SvCUR_set(ST(0), size); 3440 *SvEND(ST(0)) = 0; 3441 } 3442 XSRETURN(1); 3443 } 3444 3445 #define get_control87() _control87(0,0) 3446 #define set_control87 _control87 3447 3448 XS(XS_OS2__control87) 3449 { 3450 dXSARGS; 3451 if (items != 2) 3452 Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)"); 3453 { 3454 unsigned new = (unsigned)SvIV(ST(0)); 3455 unsigned mask = (unsigned)SvIV(ST(1)); 3456 unsigned RETVAL; 3457 dXSTARG; 3458 3459 RETVAL = _control87(new, mask); 3460 XSprePUSH; PUSHi((IV)RETVAL); 3461 } 3462 XSRETURN(1); 3463 } 3464 3465 XS(XS_OS2_mytype) 3466 { 3467 dXSARGS; 3468 int which = 0; 3469 3470 if (items < 0 || items > 1) 3471 Perl_croak(aTHX_ "Usage: OS2::mytype([which])"); 3472 if (items == 1) 3473 which = (int)SvIV(ST(0)); 3474 { 3475 unsigned RETVAL; 3476 dXSTARG; 3477 3478 switch (which) { 3479 case 0: 3480 RETVAL = os2_mytype; /* Reset after fork */ 3481 break; 3482 case 1: 3483 RETVAL = os2_mytype_ini; /* Before any fork */ 3484 break; 3485 case 2: 3486 RETVAL = Perl_os2_initial_mode; /* Before first morphing */ 3487 break; 3488 case 3: 3489 RETVAL = my_type(); /* Morphed type */ 3490 break; 3491 default: 3492 Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which); 3493 } 3494 XSprePUSH; PUSHi((IV)RETVAL); 3495 } 3496 XSRETURN(1); 3497 } 3498 3499 3500 XS(XS_OS2_mytype_set) 3501 { 3502 dXSARGS; 3503 int type; 3504 3505 if (items == 1) 3506 type = (int)SvIV(ST(0)); 3507 else 3508 Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)"); 3509 my_type_set(type); 3510 XSRETURN_EMPTY; 3511 } 3512 3513 3514 XS(XS_OS2_get_control87) 3515 { 3516 dXSARGS; 3517 if (items != 0) 3518 Perl_croak(aTHX_ "Usage: OS2::get_control87()"); 3519 { 3520 unsigned RETVAL; 3521 dXSTARG; 3522 3523 RETVAL = get_control87(); 3524 XSprePUSH; PUSHi((IV)RETVAL); 3525 } 3526 XSRETURN(1); 3527 } 3528 3529 3530 XS(XS_OS2_set_control87) 3531 { 3532 dXSARGS; 3533 if (items < 0 || items > 2) 3534 Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)"); 3535 { 3536 unsigned new; 3537 unsigned mask; 3538 unsigned RETVAL; 3539 dXSTARG; 3540 3541 if (items < 1) 3542 new = MCW_EM; 3543 else { 3544 new = (unsigned)SvIV(ST(0)); 3545 } 3546 3547 if (items < 2) 3548 mask = MCW_EM; 3549 else { 3550 mask = (unsigned)SvIV(ST(1)); 3551 } 3552 3553 RETVAL = set_control87(new, mask); 3554 XSprePUSH; PUSHi((IV)RETVAL); 3555 } 3556 XSRETURN(1); 3557 } 3558 3559 XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */ 3560 { 3561 dXSARGS; 3562 if (items < 0 || items > 1) 3563 Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)"); 3564 { 3565 LONG delta; 3566 ULONG RETVAL, rc; 3567 dXSTARG; 3568 3569 if (items < 1) 3570 delta = 0; 3571 else 3572 delta = (LONG)SvIV(ST(0)); 3573 3574 if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL))) 3575 croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error"); 3576 XSprePUSH; PUSHu((UV)RETVAL); 3577 } 3578 XSRETURN(1); 3579 } 3580 3581 int 3582 Xs_OS2_init(pTHX) 3583 { 3584 char *file = __FILE__; 3585 { 3586 GV *gv; 3587 3588 if (_emx_env & 0x200) { /* OS/2 */ 3589 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); 3590 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); 3591 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file); 3592 } 3593 newXS("OS2::Error", XS_OS2_Error, file); 3594 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file); 3595 newXS("OS2::SysInfo", XS_OS2_SysInfo, file); 3596 newXSproto("OS2::DevCap", XS_OS2_DevCap, file, ";$$"); 3597 newXSproto("OS2::SysInfoFor", XS_OS2_SysInfoFor, file, "$;$"); 3598 newXS("OS2::BootDrive", XS_OS2_BootDrive, file); 3599 newXS("OS2::MorphPM", XS_OS2_MorphPM, file); 3600 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file); 3601 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file); 3602 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file); 3603 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file); 3604 newXS("Cwd::current_drive", XS_Cwd_current_drive, file); 3605 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file); 3606 newXS("Cwd::change_drive", XS_Cwd_change_drive, file); 3607 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file); 3608 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file); 3609 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file); 3610 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file); 3611 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file); 3612 newXS("OS2::replaceModule", XS_OS2_replaceModule, file); 3613 newXS("OS2::perfSysCall", XS_OS2_perfSysCall, file); 3614 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$"); 3615 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, ""); 3616 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$"); 3617 newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$"); 3618 newXSproto("OS2::mytype", XS_OS2_mytype, file, ";$"); 3619 newXSproto("OS2::mytype_set", XS_OS2_mytype_set, file, "$"); 3620 newXSproto("OS2::_headerInfo", XS_OS2__headerInfo, file, "$$;$$"); 3621 newXSproto("OS2::libPath", XS_OS2_libPath, file, ""); 3622 newXSproto("OS2::Timer", XS_OS2_Timer, file, ""); 3623 newXSproto("OS2::incrMaxFHandles", XS_OS2_incrMaxFHandles, file, ";$"); 3624 newXSproto("OS2::SysValues", XS_OS2_SysValues, file, ";$$"); 3625 newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$"); 3626 newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$"); 3627 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); 3628 GvMULTI_on(gv); 3629 #ifdef PERL_IS_AOUT 3630 sv_setiv(GvSV(gv), 1); 3631 #endif 3632 gv = gv_fetchpv("OS2::is_static", TRUE, SVt_PV); 3633 GvMULTI_on(gv); 3634 #ifdef PERL_IS_AOUT 3635 sv_setiv(GvSV(gv), 1); 3636 #endif 3637 gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV); 3638 GvMULTI_on(gv); 3639 sv_setiv(GvSV(gv), exe_is_aout()); 3640 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV); 3641 GvMULTI_on(gv); 3642 sv_setiv(GvSV(gv), _emx_rev); 3643 sv_setpv(GvSV(gv), _emx_vprt); 3644 SvIOK_on(GvSV(gv)); 3645 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV); 3646 GvMULTI_on(gv); 3647 sv_setiv(GvSV(gv), _emx_env); 3648 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV); 3649 GvMULTI_on(gv); 3650 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor); 3651 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV); 3652 GvMULTI_on(gv); 3653 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */ 3654 } 3655 return 0; 3656 } 3657 3658 extern void _emx_init(void*); 3659 3660 static void jmp_out_of_atexit(void); 3661 3662 #define FORCE_EMX_INIT_CONTRACT_ARGV 1 3663 #define FORCE_EMX_INIT_INSTALL_ATEXIT 2 3664 3665 static void 3666 my_emx_init(void *layout) { 3667 static volatile void *old_esp = 0; /* Cannot be on stack! */ 3668 3669 /* Can't just call emx_init(), since it moves the stack pointer */ 3670 /* It also busts a lot of registers, so be extra careful */ 3671 __asm__( "pushf\n" 3672 "pusha\n" 3673 "movl %%esp, %1\n" 3674 "push %0\n" 3675 "call __emx_init\n" 3676 "movl %1, %%esp\n" 3677 "popa\n" 3678 "popf\n" : : "r" (layout), "m" (old_esp) ); 3679 } 3680 3681 struct layout_table_t { 3682 ULONG text_base; 3683 ULONG text_end; 3684 ULONG data_base; 3685 ULONG data_end; 3686 ULONG bss_base; 3687 ULONG bss_end; 3688 ULONG heap_base; 3689 ULONG heap_end; 3690 ULONG heap_brk; 3691 ULONG heap_off; 3692 ULONG os2_dll; 3693 ULONG stack_base; 3694 ULONG stack_end; 3695 ULONG flags; 3696 ULONG reserved[2]; 3697 char options[64]; 3698 }; 3699 3700 static ULONG 3701 my_os_version() { 3702 static ULONG osv_res; /* Cannot be on stack! */ 3703 3704 /* Can't just call __os_version(), since it does not follow C 3705 calling convention: it busts a lot of registers, so be extra careful */ 3706 __asm__( "pushf\n" 3707 "pusha\n" 3708 "call ___os_version\n" 3709 "movl %%eax, %0\n" 3710 "popa\n" 3711 "popf\n" : "=m" (osv_res) ); 3712 3713 return osv_res; 3714 } 3715 3716 static void 3717 force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags) 3718 { 3719 /* Calling emx_init() will bust the top of stack: it installs an 3720 exception handler and puts argv data there. */ 3721 char *oldarg, *oldenv; 3722 void *oldstackend, *oldstack; 3723 PPIB pib; 3724 PTIB tib; 3725 ULONG rc, error = 0, out; 3726 char buf[512]; 3727 static struct layout_table_t layout_table; 3728 struct { 3729 char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */ 3730 double alignment1; 3731 EXCEPTIONREGISTRATIONRECORD xreg; 3732 } *newstack; 3733 char *s; 3734 3735 layout_table.os2_dll = (ULONG)&os2_dll_fake; 3736 layout_table.flags = 0x02000002; /* flags: application, OMF */ 3737 3738 DosGetInfoBlocks(&tib, &pib); 3739 oldarg = pib->pib_pchcmd; 3740 oldenv = pib->pib_pchenv; 3741 oldstack = tib->tib_pstack; 3742 oldstackend = tib->tib_pstacklimit; 3743 3744 /* Minimize the damage to the stack via reducing the size of argv. */ 3745 if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) { 3746 pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */ 3747 pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */ 3748 } 3749 3750 newstack = alloca(sizeof(*newstack)); 3751 /* Emulate the stack probe */ 3752 s = ((char*)newstack) + sizeof(*newstack); 3753 while (s > (char*)newstack) { 3754 s[-1] = 0; 3755 s -= 4096; 3756 } 3757 3758 /* Reassigning stack is documented to work */ 3759 tib->tib_pstack = (void*)newstack; 3760 tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack)); 3761 3762 /* Can't just call emx_init(), since it moves the stack pointer */ 3763 my_emx_init((void*)&layout_table); 3764 3765 /* Remove the exception handler, cannot use it - too low on the stack. 3766 Check whether it is inside the new stack. */ 3767 buf[0] = 0; 3768 if (tib->tib_pexchain >= tib->tib_pstacklimit 3769 || tib->tib_pexchain < tib->tib_pstack) { 3770 error = 1; 3771 sprintf(buf, 3772 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n", 3773 (unsigned long)tib->tib_pstack, 3774 (unsigned long)tib->tib_pexchain, 3775 (unsigned long)tib->tib_pstacklimit); 3776 goto finish; 3777 } 3778 if (tib->tib_pexchain != &(newstack->xreg)) { 3779 sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n", 3780 (unsigned long)tib->tib_pexchain, 3781 (unsigned long)&(newstack->xreg)); 3782 } 3783 rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain); 3784 if (rc) 3785 sprintf(buf + strlen(buf), 3786 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc); 3787 3788 if (preg) { 3789 /* ExceptionRecords should be on stack, in a correct order. Sigh... */ 3790 preg->prev_structure = 0; 3791 preg->ExceptionHandler = _emx_exception; 3792 rc = DosSetExceptionHandler(preg); 3793 if (rc) { 3794 sprintf(buf + strlen(buf), 3795 "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc); 3796 DosWrite(2, buf, strlen(buf), &out); 3797 emx_exception_init = 1; /* Do it around spawn*() calls */ 3798 } 3799 } else 3800 emx_exception_init = 1; /* Do it around spawn*() calls */ 3801 3802 finish: 3803 /* Restore the damage */ 3804 pib->pib_pchcmd = oldarg; 3805 pib->pib_pchcmd = oldenv; 3806 tib->tib_pstacklimit = oldstackend; 3807 tib->tib_pstack = oldstack; 3808 emx_runtime_init = 1; 3809 if (buf[0]) 3810 DosWrite(2, buf, strlen(buf), &out); 3811 if (error) 3812 exit(56); 3813 } 3814 3815 static void 3816 jmp_out_of_atexit(void) 3817 { 3818 if (longjmp_at_exit) 3819 longjmp(at_exit_buf, 1); 3820 } 3821 3822 extern void _CRT_term(void); 3823 3824 void 3825 Perl_OS2_term(void **p, int exitstatus, int flags) 3826 { 3827 if (!emx_runtime_secondary) 3828 return; 3829 3830 /* The principal executable is not running the same CRTL, so there 3831 is nobody to shutdown *this* CRTL except us... */ 3832 if (flags & FORCE_EMX_DEINIT_EXIT) { 3833 if (p && !emx_exception_init) 3834 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p); 3835 /* Do not run the executable's CRTL's termination routines */ 3836 exit(exitstatus); /* Run at-exit, flush buffers, etc */ 3837 } 3838 /* Run at-exit list, and jump out at the end */ 3839 if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) { 3840 longjmp_at_exit = 1; 3841 exit(exitstatus); /* The first pass through "if" */ 3842 } 3843 3844 /* Get here if we managed to jump out of exit(), or did not run atexit. */ 3845 longjmp_at_exit = 0; /* Maybe exit() is called again? */ 3846 #if 0 /* _atexit_n is not exported */ 3847 if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT) 3848 _atexit_n = 0; /* Remove the atexit() handlers */ 3849 #endif 3850 /* Will segfault on program termination if we leave this dangling... */ 3851 if (p && !emx_exception_init) 3852 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p); 3853 /* Typically there is no need to do this, done from _DLL_InitTerm() */ 3854 if (flags & FORCE_EMX_DEINIT_CRT_TERM) 3855 _CRT_term(); /* Flush buffers, etc. */ 3856 /* Now it is a good time to call exit() in the caller's CRTL... */ 3857 } 3858 3859 #include <emx/startup.h> 3860 3861 extern ULONG __os_version(); /* See system.doc */ 3862 3863 void 3864 check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg) 3865 { 3866 ULONG v_crt, v_emx, count = 0, rc, rc1, maybe_inited = 0; 3867 static HMTX hmtx_emx_init = NULLHANDLE; 3868 static int emx_init_done = 0; 3869 3870 /* If _environ is not set, this code sits in a DLL which 3871 uses a CRT DLL which not compatible with the executable's 3872 CRT library. Some parts of the DLL are not initialized. 3873 */ 3874 if (_environ != NULL) 3875 return; /* Properly initialized */ 3876 3877 /* It is not DOS, so we may use OS/2 API now */ 3878 /* Some data we manipulate is static; protect ourselves from 3879 calling the same API from a different thread. */ 3880 DosEnterMustComplete(&count); 3881 3882 rc1 = DosEnterCritSec(); 3883 if (!hmtx_emx_init) 3884 rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/ 3885 else 3886 maybe_inited = 1; 3887 3888 if (rc != NO_ERROR) 3889 hmtx_emx_init = NULLHANDLE; 3890 3891 if (rc1 == NO_ERROR) 3892 DosExitCritSec(); 3893 DosExitMustComplete(&count); 3894 3895 while (maybe_inited) { /* Other thread did or is doing the same now */ 3896 if (emx_init_done) 3897 return; 3898 rc = DosRequestMutexSem(hmtx_emx_init, 3899 (ULONG) SEM_INDEFINITE_WAIT); /* Timeout (none) */ 3900 if (rc == ERROR_INTERRUPT) 3901 continue; 3902 if (rc != NO_ERROR) { 3903 char buf[80]; 3904 ULONG out; 3905 3906 sprintf(buf, 3907 "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc); 3908 DosWrite(2, buf, strlen(buf), &out); 3909 return; 3910 } 3911 DosReleaseMutexSem(hmtx_emx_init); 3912 return; 3913 } 3914 3915 /* If the executable does not use EMX.DLL, EMX.DLL is not completely 3916 initialized either. Uninitialized EMX.DLL returns 0 in the low 3917 nibble of __os_version(). */ 3918 v_emx = my_os_version(); 3919 3920 /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL 3921 (=>_CRT_init=>_entry2) via a call to __os_version(), then 3922 reset when the EXE initialization code calls _text=>_init=>_entry2. 3923 The first time they are wrongly set to 0; the second time the 3924 EXE initialization code had already called emx_init=>initialize1 3925 which correctly set version_major, version_minor used by 3926 __os_version(). */ 3927 v_crt = (_osmajor | _osminor); 3928 3929 if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */ 3930 force_init_emx_runtime( preg, 3931 FORCE_EMX_INIT_CONTRACT_ARGV 3932 | FORCE_EMX_INIT_INSTALL_ATEXIT ); 3933 emx_wasnt_initialized = 1; 3934 /* Update CRTL data basing on now-valid EMX runtime data */ 3935 if (!v_crt) { /* The only wrong data are the versions. */ 3936 v_emx = my_os_version(); /* *Now* it works */ 3937 *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */ 3938 *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF; 3939 } 3940 } 3941 emx_runtime_secondary = 1; 3942 /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */ 3943 atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */ 3944 3945 if (env == NULL) { /* Fetch from the process info block */ 3946 int c = 0; 3947 PPIB pib; 3948 PTIB tib; 3949 char *e, **ep; 3950 3951 DosGetInfoBlocks(&tib, &pib); 3952 e = pib->pib_pchenv; 3953 while (*e) { /* Get count */ 3954 c++; 3955 e = e + strlen(e) + 1; 3956 } 3957 New(1307, env, c + 1, char*); 3958 ep = env; 3959 e = pib->pib_pchenv; 3960 while (c--) { 3961 *ep++ = e; 3962 e = e + strlen(e) + 1; 3963 } 3964 *ep = NULL; 3965 } 3966 _environ = _org_environ = env; 3967 emx_init_done = 1; 3968 if (hmtx_emx_init) 3969 DosReleaseMutexSem(hmtx_emx_init); 3970 } 3971 3972 #define ENTRY_POINT 0x10000 3973 3974 static int 3975 exe_is_aout(void) 3976 { 3977 struct layout_table_t *layout; 3978 if (emx_wasnt_initialized) 3979 return 0; 3980 /* Now we know that the principal executable is an EMX application 3981 - unless somebody did already play with delayed initialization... */ 3982 /* With EMX applications to determine whether it is AOUT one needs 3983 to examine the start of the executable to find "layout" */ 3984 if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */ 3985 || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */ 3986 || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */ 3987 || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */ 3988 return 0; /* ! EMX executable */ 3989 /* Fix alignment */ 3990 Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*); 3991 return !(layout->flags & 2); 3992 } 3993 3994 void 3995 Perl_OS2_init(char **env) 3996 { 3997 Perl_OS2_init3(env, 0, 0); 3998 } 3999 4000 void 4001 Perl_OS2_init3(char **env, void **preg, int flags) 4002 { 4003 char *shell; 4004 4005 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY); 4006 MALLOC_INIT; 4007 4008 check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg); 4009 4010 settmppath(); 4011 OS2_Perl_data.xs_init = &Xs_OS2_init; 4012 if ( (shell = getenv("PERL_SH_DRIVE")) ) { 4013 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char); 4014 strcpy(PL_sh_path, SH_PATH); 4015 PL_sh_path[0] = shell[0]; 4016 } else if ( (shell = getenv("PERL_SH_DIR")) ) { 4017 int l = strlen(shell), i; 4018 if (shell[l-1] == '/' || shell[l-1] == '\\') { 4019 l--; 4020 } 4021 New(1304, PL_sh_path, l + 8, char); 4022 strncpy(PL_sh_path, shell, l); 4023 strcpy(PL_sh_path + l, "/sh.exe"); 4024 for (i = 0; i < l; i++) { 4025 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/'; 4026 } 4027 } 4028 #if defined(USE_5005THREADS) || defined(USE_ITHREADS) 4029 MUTEX_INIT(&start_thread_mutex); 4030 MUTEX_INIT(&perlos2_state_mutex); 4031 #endif 4032 os2_mytype = my_type(); /* Do it before morphing. Needed? */ 4033 os2_mytype_ini = os2_mytype; 4034 Perl_os2_initial_mode = -1; /* Uninit */ 4035 /* Some DLLs reset FP flags on load. We may have been linked with them */ 4036 _control87(MCW_EM, MCW_EM); 4037 } 4038 4039 int 4040 fd_ok(int fd) 4041 { 4042 static ULONG max_fh = 0; 4043 4044 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */ 4045 if (fd >= max_fh) { /* Renew */ 4046 LONG delta = 0; 4047 4048 if (DosSetRelMaxFH(&delta, &max_fh)) /* Assume it OK??? */ 4049 return 1; 4050 } 4051 return fd < max_fh; 4052 } 4053 4054 /* Kernels up to Oct 2003 trap on (invalid) dup(max_fh); [off-by-one + double fault]. */ 4055 int 4056 dup2(int from, int to) 4057 { 4058 if (fd_ok(from < to ? to : from)) 4059 return _dup2(from, to); 4060 errno = EBADF; 4061 return -1; 4062 } 4063 4064 int 4065 dup(int from) 4066 { 4067 if (fd_ok(from)) 4068 return _dup(from); 4069 errno = EBADF; 4070 return -1; 4071 } 4072 4073 #undef tmpnam 4074 #undef tmpfile 4075 4076 char * 4077 my_tmpnam (char *str) 4078 { 4079 char *p = getenv("TMP"), *tpath; 4080 4081 if (!p) p = getenv("TEMP"); 4082 tpath = tempnam(p, "pltmp"); 4083 if (str && tpath) { 4084 strcpy(str, tpath); 4085 return str; 4086 } 4087 return tpath; 4088 } 4089 4090 FILE * 4091 my_tmpfile () 4092 { 4093 struct stat s; 4094 4095 stat(".", &s); 4096 if (s.st_mode & S_IWOTH) { 4097 return tmpfile(); 4098 } 4099 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but 4100 grants TMP. */ 4101 } 4102 4103 #undef rmdir 4104 4105 /* EMX flavors do not tolerate trailing slashes. t/op/mkdir.t has many 4106 trailing slashes, so we need to support this as well. */ 4107 4108 int 4109 my_rmdir (__const__ char *s) 4110 { 4111 char b[MAXPATHLEN]; 4112 char *buf = b; 4113 STRLEN l = strlen(s); 4114 int rc; 4115 4116 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */ 4117 if (l >= sizeof b) 4118 New(1305, buf, l + 1, char); 4119 strcpy(buf,s); 4120 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\')) 4121 l--; 4122 buf[l] = 0; 4123 s = buf; 4124 } 4125 rc = rmdir(s); 4126 if (b != buf) 4127 Safefree(buf); 4128 return rc; 4129 } 4130 4131 #undef mkdir 4132 4133 int 4134 my_mkdir (__const__ char *s, long perm) 4135 { 4136 char b[MAXPATHLEN]; 4137 char *buf = b; 4138 STRLEN l = strlen(s); 4139 int rc; 4140 4141 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */ 4142 if (l >= sizeof b) 4143 New(1305, buf, l + 1, char); 4144 strcpy(buf,s); 4145 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\')) 4146 l--; 4147 buf[l] = 0; 4148 s = buf; 4149 } 4150 rc = mkdir(s, perm); 4151 if (b != buf) 4152 Safefree(buf); 4153 return rc; 4154 } 4155 4156 #undef flock 4157 4158 /* This code was contributed by Rocco Caputo. */ 4159 int 4160 my_flock(int handle, int o) 4161 { 4162 FILELOCK rNull, rFull; 4163 ULONG timeout, handle_type, flag_word; 4164 APIRET rc; 4165 int blocking, shared; 4166 static int use_my_flock = -1; 4167 4168 if (use_my_flock == -1) { 4169 MUTEX_LOCK(&perlos2_state_mutex); 4170 if (use_my_flock == -1) { 4171 char *s = getenv("USE_PERL_FLOCK"); 4172 if (s) 4173 use_my_flock = atoi(s); 4174 else 4175 use_my_flock = 1; 4176 } 4177 MUTEX_UNLOCK(&perlos2_state_mutex); 4178 } 4179 if (!(_emx_env & 0x200) || !use_my_flock) 4180 return flock(handle, o); /* Delegate to EMX. */ 4181 4182 /* is this a file? */ 4183 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) || 4184 (handle_type & 0xFF)) 4185 { 4186 errno = EBADF; 4187 return -1; 4188 } 4189 /* set lock/unlock ranges */ 4190 rNull.lOffset = rNull.lRange = rFull.lOffset = 0; 4191 rFull.lRange = 0x7FFFFFFF; 4192 /* set timeout for blocking */ 4193 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1; 4194 /* shared or exclusive? */ 4195 shared = (o & LOCK_SH) ? 1 : 0; 4196 /* do not block the unlock */ 4197 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) { 4198 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared); 4199 switch (rc) { 4200 case 0: 4201 errno = 0; 4202 return 0; 4203 case ERROR_INVALID_HANDLE: 4204 errno = EBADF; 4205 return -1; 4206 case ERROR_SHARING_BUFFER_EXCEEDED: 4207 errno = ENOLCK; 4208 return -1; 4209 case ERROR_LOCK_VIOLATION: 4210 break; /* not an error */ 4211 case ERROR_INVALID_PARAMETER: 4212 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: 4213 case ERROR_READ_LOCKS_NOT_SUPPORTED: 4214 errno = EINVAL; 4215 return -1; 4216 case ERROR_INTERRUPT: 4217 errno = EINTR; 4218 return -1; 4219 default: 4220 errno = EINVAL; 4221 return -1; 4222 } 4223 } 4224 /* lock may block */ 4225 if (o & (LOCK_SH | LOCK_EX)) { 4226 /* for blocking operations */ 4227 for (;;) { 4228 rc = 4229 DosSetFileLocks( 4230 handle, 4231 &rNull, 4232 &rFull, 4233 timeout, 4234 shared 4235 ); 4236 switch (rc) { 4237 case 0: 4238 errno = 0; 4239 return 0; 4240 case ERROR_INVALID_HANDLE: 4241 errno = EBADF; 4242 return -1; 4243 case ERROR_SHARING_BUFFER_EXCEEDED: 4244 errno = ENOLCK; 4245 return -1; 4246 case ERROR_LOCK_VIOLATION: 4247 if (!blocking) { 4248 errno = EWOULDBLOCK; 4249 return -1; 4250 } 4251 break; 4252 case ERROR_INVALID_PARAMETER: 4253 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: 4254 case ERROR_READ_LOCKS_NOT_SUPPORTED: 4255 errno = EINVAL; 4256 return -1; 4257 case ERROR_INTERRUPT: 4258 errno = EINTR; 4259 return -1; 4260 default: 4261 errno = EINVAL; 4262 return -1; 4263 } 4264 /* give away timeslice */ 4265 DosSleep(1); 4266 } 4267 } 4268 4269 errno = 0; 4270 return 0; 4271 } 4272 4273 static int 4274 use_my_pwent(void) 4275 { 4276 if (_my_pwent == -1) { 4277 char *s = getenv("USE_PERL_PWENT"); 4278 if (s) 4279 _my_pwent = atoi(s); 4280 else 4281 _my_pwent = 1; 4282 } 4283 return _my_pwent; 4284 } 4285 4286 #undef setpwent 4287 #undef getpwent 4288 #undef endpwent 4289 4290 void 4291 my_setpwent(void) 4292 { 4293 if (!use_my_pwent()) { 4294 setpwent(); /* Delegate to EMX. */ 4295 return; 4296 } 4297 pwent_cnt = 0; 4298 } 4299 4300 void 4301 my_endpwent(void) 4302 { 4303 if (!use_my_pwent()) { 4304 endpwent(); /* Delegate to EMX. */ 4305 return; 4306 } 4307 } 4308 4309 struct passwd * 4310 my_getpwent (void) 4311 { 4312 if (!use_my_pwent()) 4313 return getpwent(); /* Delegate to EMX. */ 4314 if (pwent_cnt++) 4315 return 0; /* Return one entry only */ 4316 return getpwuid(0); 4317 } 4318 4319 void 4320 setgrent(void) 4321 { 4322 grent_cnt = 0; 4323 } 4324 4325 void 4326 endgrent(void) 4327 { 4328 } 4329 4330 struct group * 4331 getgrent (void) 4332 { 4333 if (grent_cnt++) 4334 return 0; /* Return one entry only */ 4335 return getgrgid(0); 4336 } 4337 4338 #undef getpwuid 4339 #undef getpwnam 4340 4341 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */ 4342 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK"; 4343 4344 static struct passwd * 4345 passw_wrap(struct passwd *p) 4346 { 4347 char *s; 4348 4349 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */ 4350 return p; 4351 pw = *p; 4352 s = getenv("PW_PASSWD"); 4353 if (!s) 4354 s = (char*)pw_p; /* Make match impossible */ 4355 4356 pw.pw_passwd = s; 4357 return &pw; 4358 } 4359 4360 struct passwd * 4361 my_getpwuid (uid_t id) 4362 { 4363 return passw_wrap(getpwuid(id)); 4364 } 4365 4366 struct passwd * 4367 my_getpwnam (__const__ char *n) 4368 { 4369 return passw_wrap(getpwnam(n)); 4370 } 4371 4372 char * 4373 gcvt_os2 (double value, int digits, char *buffer) 4374 { 4375 double absv = value > 0 ? value : -value; 4376 /* EMX implementation is lousy between 0.1 and 0.0001 (uses exponents below 4377 0.1), 1-digit stuff is ok below 0.001; multi-digit below 0.0001. */ 4378 int buggy; 4379 4380 absv *= 10000; 4381 buggy = (absv < 1000 && (absv >= 10 || (absv > 1 && floor(absv) != absv))); 4382 4383 if (buggy) { 4384 char pat[12]; 4385 4386 sprintf(pat, "%%.%dg", digits); 4387 sprintf(buffer, pat, value); 4388 return buffer; 4389 } 4390 return gcvt (value, digits, buffer); 4391 } 4392 4393 #undef fork 4394 int fork_with_resources() 4395 { 4396 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC) 4397 dTHX; 4398 void *ctx = PERL_GET_CONTEXT; 4399 #endif 4400 unsigned fpflag = _control87(0,0); 4401 int rc = fork(); 4402 4403 if (rc == 0) { /* child */ 4404 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC) 4405 ALLOC_THREAD_KEY; /* Acquire the thread-local memory */ 4406 PERL_SET_CONTEXT(ctx); /* Reinit the thread-local memory */ 4407 #endif 4408 4409 { /* Reload loaded-on-demand DLLs */ 4410 struct dll_handle_t *dlls = dll_handles; 4411 4412 while (dlls->modname) { 4413 char dllname[260], fail[260]; 4414 ULONG rc; 4415 4416 if (!dlls->handle) { /* Was not loaded */ 4417 dlls++; 4418 continue; 4419 } 4420 /* It was loaded in the parent. We need to reload it. */ 4421 4422 rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname); 4423 if (rc) { 4424 Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx", 4425 dlls->modname, (int)dlls->handle, rc, rc); 4426 dlls++; 4427 continue; 4428 } 4429 rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle); 4430 if (rc) 4431 Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'", 4432 dllname, fail); 4433 dlls++; 4434 } 4435 } 4436 4437 { /* Support message queue etc. */ 4438 os2_mytype = my_type(); 4439 /* Apparently, subprocesses (in particular, fork()) do not 4440 inherit the morphed state, so os2_mytype is the same as 4441 os2_mytype_ini. */ 4442 4443 if (Perl_os2_initial_mode != -1 4444 && Perl_os2_initial_mode != os2_mytype) { 4445 /* XXXX ??? */ 4446 } 4447 } 4448 if (Perl_HAB_set) 4449 (void)_obtain_Perl_HAB; 4450 if (Perl_hmq_refcnt) { 4451 if (my_type() != 3) 4452 my_type_set(3); 4453 Create_HMQ(Perl_hmq_servers != 0, 4454 "Cannot create a message queue on fork"); 4455 } 4456 4457 /* We may have loaded some modules */ 4458 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */ 4459 } 4460 return rc; 4461 } 4462 4463