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