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