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