3 #define INCL_DOSFILEMGR
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
14 #include <emx/syscalls.h>
16 #include <sys/uflags.h>
19 * Various Unix compatibility functions for OS/2
30 #define PERLIO_NOT_STDIO 0
36 croak_with_os2error(char *s)
38 Perl_croak_nocontext("%s: %s", s, os2error(Perl_rc));
41 struct PMWIN_entries_t PMWIN_entries;
43 /*****************************************************************************/
44 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
52 static struct dll_handle_t dll_handles[] = {
78 #define doscalls_handle (dll_handles[dll_handle_doscalls])
79 #define tcp_handle (dll_handles[dll_handle_tcp32dll])
80 #define pmwin_handle (dll_handles[dll_handle_pmwin])
81 #define rexx_handle (dll_handles[dll_handle_rexx])
82 #define rexxapi_handle (dll_handles[dll_handle_rexxapi])
83 #define sesmgr_handle (dll_handles[dll_handle_sesmgr])
84 #define pmshapi_handle (dll_handles[dll_handle_pmshapi])
85 #define pmwp_handle (dll_handles[dll_handle_pmwp])
86 #define pmgpi_handle (dll_handles[dll_handle_pmgpi])
88 /* The following local-scope data is not yet included:
89 fargs.140 // const => OK
90 ino.165 // locked - and the access is almost cosmetic
91 layout_table.260 // startup only, locked
92 osv_res.257 // startup only, locked
93 old_esp.254 // startup only, locked
94 priors // const ==> OK
95 use_my_flock.283 // locked
96 emx_init_done.268 // locked
98 hmtx_emx_init.267 // THIS is the lock for startup
99 perlos2_state_mutex // THIS is the lock for all the rest
101 perlos2_state // see below
103 /* The following global-scope data is not yet included:
105 pthreads_states // const now?
107 thread_join_count // protected
108 thread_join_data // protected
113 Perl_OS2_init3() - should it be protected?
115 OS2_Perl_data_t OS2_Perl_data;
117 static struct perlos2_state_t {
118 int po2__my_pwent; /* = -1; */
119 int po2_DOS_harderr_state; /* = -1; */
120 signed char po2_DOS_suppression_state; /* = -1; */
121 PFN po2_ExtFCN[ORD_NENTRIES]; /* Labeled by ord ORD_*. */
122 /* struct PMWIN_entries_t po2_PMWIN_entries; */
124 int po2_emx_wasnt_initialized;
136 char po2_mangle_ret[STATIC_FILE_LENGTH+1];
137 ULONG po2_os2_dll_fake;
138 ULONG po2_os2_mytype;
139 ULONG po2_os2_mytype_ini;
140 int po2_pidtid_lookup;
141 struct passwd po2_pw;
144 char po2_pthreads_state_buf[80];
145 char po2_os2error_buf[300];
146 /* There is no big sense to make it thread-specific, since signals
147 are delivered to thread 1 only. XXXX Maybe make it into an array? */
149 int po2_spawn_killed;
151 jmp_buf po2_at_exit_buf;
152 int po2_longjmp_at_exit;
153 int po2_emx_runtime_init; /* If 1, we need to manually init it */
154 int po2_emx_exception_init; /* If 1, we need to manually set it */
155 int po2_emx_runtime_secondary;
158 -1, /* po2__my_pwent */
159 -1, /* po2_DOS_harderr_state */
160 -1, /* po2_DOS_suppression_state */
163 #define Perl_po2() (&perlos2_state)
165 #define ExtFCN (Perl_po2()->po2_ExtFCN)
166 /* #define PMWIN_entries (Perl_po2()->po2_PMWIN_entries) */
167 #define emx_wasnt_initialized (Perl_po2()->po2_emx_wasnt_initialized)
168 #define fname (Perl_po2()->po2_fname)
169 #define rmq_cnt (Perl_po2()->po2_rmq_cnt)
170 #define grent_cnt (Perl_po2()->po2_grent_cnt)
171 #define newp (Perl_po2()->po2_newp)
172 #define oldp (Perl_po2()->po2_oldp)
173 #define newl (Perl_po2()->po2_newl)
174 #define oldl (Perl_po2()->po2_oldl)
175 #define notfound (Perl_po2()->po2_notfound)
176 #define mangle_ret (Perl_po2()->po2_mangle_ret)
177 #define os2_dll_fake (Perl_po2()->po2_os2_dll_fake)
178 #define os2_mytype (Perl_po2()->po2_os2_mytype)
179 #define os2_mytype_ini (Perl_po2()->po2_os2_mytype_ini)
180 #define pidtid_lookup (Perl_po2()->po2_pidtid_lookup)
181 #define pw (Perl_po2()->po2_pw)
182 #define pwent_cnt (Perl_po2()->po2_pwent_cnt)
183 #define _my_pwent (Perl_po2()->po2__my_pwent)
184 #define pthreads_state_buf (Perl_po2()->po2_pthreads_state_buf)
185 #define os2error_buf (Perl_po2()->po2_os2error_buf)
186 /* There is no big sense to make it thread-specific, since signals
187 are delivered to thread 1 only. XXXX Maybe make it into an array? */
188 #define spawn_pid (Perl_po2()->po2_spawn_pid)
189 #define spawn_killed (Perl_po2()->po2_spawn_killed)
190 #define DOS_harderr_state (Perl_po2()->po2_DOS_harderr_state)
191 #define DOS_suppression_state (Perl_po2()->po2_DOS_suppression_state)
193 #define at_exit_buf (Perl_po2()->po2_at_exit_buf)
194 #define longjmp_at_exit (Perl_po2()->po2_longjmp_at_exit)
195 #define emx_runtime_init (Perl_po2()->po2_emx_runtime_init)
196 #define emx_exception_init (Perl_po2()->po2_emx_exception_init)
197 #define emx_runtime_secondary (Perl_po2()->po2_emx_runtime_secondary)
199 const Perl_PFN * const pExtFCN = (Perl_po2()->po2_ExtFCN);
202 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
204 typedef void (*emx_startroutine)(void *);
205 typedef void* (*pthreads_startroutine)(void *);
207 enum pthreads_state {
208 pthreads_st_none = 0,
211 pthreads_st_detached,
214 pthreads_st_exited_waited,
216 const char * const pthreads_states[] = {
223 "exited, then waited on",
226 enum pthread_exists { pthread_not_existant = -0xff };
229 pthreads_state_string(enum pthreads_state state)
231 if (state < 0 || state >= sizeof(pthreads_states)/sizeof(*pthreads_states)) {
232 snprintf(pthreads_state_buf, sizeof(pthreads_state_buf),
233 "unknown thread state %d", (int)state);
234 return pthreads_state_buf;
236 return pthreads_states[state];
242 enum pthreads_state state;
245 thread_join_t *thread_join_data;
246 int thread_join_count;
247 perl_mutex start_thread_mutex;
248 static perl_mutex perlos2_state_mutex;
252 pthread_join(perl_os_thread tid, void **status)
254 MUTEX_LOCK(&start_thread_mutex);
255 if (tid < 1 || tid >= thread_join_count) {
256 MUTEX_UNLOCK(&start_thread_mutex);
257 if (tid != pthread_not_existant)
258 Perl_croak_nocontext("panic: join with a thread with strange ordinal %d", (int)tid);
259 Perl_warn_nocontext("panic: join with a thread which could not start");
263 switch (thread_join_data[tid].state) {
264 case pthreads_st_exited:
265 thread_join_data[tid].state = pthreads_st_exited_waited;
266 *status = thread_join_data[tid].status;
267 MUTEX_UNLOCK(&start_thread_mutex);
268 COND_SIGNAL(&thread_join_data[tid].cond);
270 case pthreads_st_waited:
271 MUTEX_UNLOCK(&start_thread_mutex);
272 Perl_croak_nocontext("join with a thread with a waiter");
274 case pthreads_st_norun:
276 int state = (int)thread_join_data[tid].status;
278 thread_join_data[tid].state = pthreads_st_none;
279 MUTEX_UNLOCK(&start_thread_mutex);
280 Perl_croak_nocontext("panic: join with a thread which could not run"
281 " due to attempt of tid reuse (state='%s')",
282 pthreads_state_string(state));
285 case pthreads_st_run:
289 thread_join_data[tid].state = pthreads_st_waited;
290 thread_join_data[tid].status = (void *)status;
291 COND_INIT(&thread_join_data[tid].cond);
292 cond = thread_join_data[tid].cond;
293 COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
295 MUTEX_UNLOCK(&start_thread_mutex);
299 MUTEX_UNLOCK(&start_thread_mutex);
300 Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'",
301 pthreads_state_string(thread_join_data[tid].state));
308 pthreads_startroutine sub;
314 a) Since we temporarily usurp the caller interp, so malloc() may
315 use it to decide on debugging the call;
316 b) Since *args is on the caller's stack.
319 pthread_startit(void *arg1)
321 /* Thread is already started, we need to transfer control only */
322 pthr_startit args = *(pthr_startit *)arg1;
323 int tid = pthread_self();
328 /* Can't croak, the setjmp() is not in scope... */
331 snprintf(buf, sizeof(buf),
332 "panic: thread with strange ordinal %d created\n\r", tid);
333 write(2,buf,strlen(buf));
334 MUTEX_UNLOCK(&start_thread_mutex);
337 /* Until args.sub resets it, makes debugging Perl_malloc() work: */
339 if (tid >= thread_join_count) {
340 int oc = thread_join_count;
342 thread_join_count = tid + 5 + tid/5;
343 if (thread_join_data) {
344 Renew(thread_join_data, thread_join_count, thread_join_t);
345 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
347 Newz(1323, thread_join_data, thread_join_count, thread_join_t);
350 if (thread_join_data[tid].state != pthreads_st_none) {
351 /* Can't croak, the setjmp() is not in scope... */
354 snprintf(buf, sizeof(buf),
355 "panic: attempt to reuse thread id %d (state='%s')\n\r",
356 tid, pthreads_state_string(thread_join_data[tid].state));
357 write(2,buf,strlen(buf));
358 thread_join_data[tid].status = (void*)thread_join_data[tid].state;
359 thread_join_data[tid].state = pthreads_st_norun;
360 MUTEX_UNLOCK(&start_thread_mutex);
363 thread_join_data[tid].state = pthreads_st_run;
364 /* Now that we copied/updated the guys, we may release the caller... */
365 MUTEX_UNLOCK(&start_thread_mutex);
366 rc = (*args.sub)(args.arg);
367 MUTEX_LOCK(&start_thread_mutex);
368 switch (thread_join_data[tid].state) {
369 case pthreads_st_waited:
370 COND_SIGNAL(&thread_join_data[tid].cond);
371 thread_join_data[tid].state = pthreads_st_none;
372 *((void**)thread_join_data[tid].status) = rc;
374 case pthreads_st_detached:
375 thread_join_data[tid].state = pthreads_st_none;
377 case pthreads_st_run:
378 /* Somebody can wait on us; cannot exit, since OS can reuse the tid
379 and our waiter will get somebody else's status. */
380 thread_join_data[tid].state = pthreads_st_exited;
381 thread_join_data[tid].status = rc;
382 COND_INIT(&thread_join_data[tid].cond);
383 COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
384 COND_DESTROY(&thread_join_data[tid].cond);
385 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
388 state = thread_join_data[tid].state;
389 MUTEX_UNLOCK(&start_thread_mutex);
390 Perl_croak_nocontext("panic: unexpected thread state on exit: '%s'",
391 pthreads_state_string(state));
393 MUTEX_UNLOCK(&start_thread_mutex);
397 pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr,
398 void *(*start_routine)(void*), void *arg)
403 args.sub = (void*)start_routine;
405 args.ctx = PERL_GET_CONTEXT;
407 MUTEX_LOCK(&start_thread_mutex);
408 /* Test suite creates 31 extra threads;
409 on machine without shared-memory-hogs this stack sizeis OK with 31: */
410 *tidp = _beginthread(pthread_startit, /*stack*/ NULL,
411 /*stacksize*/ 4*1024*1024, (void*)&args);
413 *tidp = pthread_not_existant;
414 MUTEX_UNLOCK(&start_thread_mutex);
417 MUTEX_LOCK(&start_thread_mutex); /* Wait for init to proceed */
418 MUTEX_UNLOCK(&start_thread_mutex);
423 pthread_detach(perl_os_thread tid)
425 MUTEX_LOCK(&start_thread_mutex);
426 if (tid < 1 || tid >= thread_join_count) {
427 MUTEX_UNLOCK(&start_thread_mutex);
428 if (tid != pthread_not_existant)
429 Perl_croak_nocontext("panic: detach of a thread with strange ordinal %d", (int)tid);
430 Perl_warn_nocontext("detach of a thread which could not start");
433 switch (thread_join_data[tid].state) {
434 case pthreads_st_waited:
435 MUTEX_UNLOCK(&start_thread_mutex);
436 Perl_croak_nocontext("detach on a thread with a waiter");
438 case pthreads_st_run:
439 thread_join_data[tid].state = pthreads_st_detached;
440 MUTEX_UNLOCK(&start_thread_mutex);
442 case pthreads_st_exited:
443 MUTEX_UNLOCK(&start_thread_mutex);
444 COND_SIGNAL(&thread_join_data[tid].cond);
446 case pthreads_st_detached:
447 MUTEX_UNLOCK(&start_thread_mutex);
448 Perl_warn_nocontext("detach on an already detached thread");
450 case pthreads_st_norun:
452 int state = (int)thread_join_data[tid].status;
454 thread_join_data[tid].state = pthreads_st_none;
455 MUTEX_UNLOCK(&start_thread_mutex);
456 Perl_croak_nocontext("panic: detaching thread which could not run"
457 " due to attempt of tid reuse (state='%s')",
458 pthreads_state_string(state));
462 MUTEX_UNLOCK(&start_thread_mutex);
463 Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'",
464 pthreads_state_string(thread_join_data[tid].state));
470 /* This is a very bastardized version; may be OK due to edge trigger of Wait */
472 os2_cond_wait(perl_cond *c, perl_mutex *m)
476 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
477 Perl_rc = rc, croak_with_os2error("panic: COND_WAIT-reset");
478 if (m) MUTEX_UNLOCK(m);
479 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
480 && (rc != ERROR_INTERRUPT))
481 croak_with_os2error("panic: COND_WAIT");
482 if (rc == ERROR_INTERRUPT)
484 if (m) MUTEX_LOCK(m);
489 static int exe_is_aout(void);
491 /* This should match enum entries_ordinals defined in os2ish.h. */
492 static const struct {
493 struct dll_handle_t *dll;
494 const char *entryname;
497 {&doscalls_handle, NULL, 874}, /* DosQueryExtLibpath */
498 {&doscalls_handle, NULL, 873}, /* DosSetExtLibpath */
499 {&doscalls_handle, NULL, 460}, /* DosVerifyPidTid */
500 {&tcp_handle, "SETHOSTENT", 0},
501 {&tcp_handle, "SETNETENT" , 0},
502 {&tcp_handle, "SETPROTOENT", 0},
503 {&tcp_handle, "SETSERVENT", 0},
504 {&tcp_handle, "GETHOSTENT", 0},
505 {&tcp_handle, "GETNETENT" , 0},
506 {&tcp_handle, "GETPROTOENT", 0},
507 {&tcp_handle, "GETSERVENT", 0},
508 {&tcp_handle, "ENDHOSTENT", 0},
509 {&tcp_handle, "ENDNETENT", 0},
510 {&tcp_handle, "ENDPROTOENT", 0},
511 {&tcp_handle, "ENDSERVENT", 0},
512 {&pmwin_handle, NULL, 763}, /* WinInitialize */
513 {&pmwin_handle, NULL, 716}, /* WinCreateMsgQueue */
514 {&pmwin_handle, NULL, 726}, /* WinDestroyMsgQueue */
515 {&pmwin_handle, NULL, 918}, /* WinPeekMsg */
516 {&pmwin_handle, NULL, 915}, /* WinGetMsg */
517 {&pmwin_handle, NULL, 912}, /* WinDispatchMsg */
518 {&pmwin_handle, NULL, 753}, /* WinGetLastError */
519 {&pmwin_handle, NULL, 705}, /* WinCancelShutdown */
520 /* These are needed in extensions.
521 How to protect PMSHAPI: it comes through EMX functions? */
522 {&rexx_handle, "RexxStart", 0},
523 {&rexx_handle, "RexxVariablePool", 0},
524 {&rexxapi_handle, "RexxRegisterFunctionExe", 0},
525 {&rexxapi_handle, "RexxDeregisterFunction", 0},
526 {&sesmgr_handle, "DOSSMSETTITLE", 0}, /* Would not work runtime-loaded */
527 {&pmshapi_handle, "PRF32QUERYPROFILESIZE", 0},
528 {&pmshapi_handle, "PRF32OPENPROFILE", 0},
529 {&pmshapi_handle, "PRF32CLOSEPROFILE", 0},
530 {&pmshapi_handle, "PRF32QUERYPROFILE", 0},
531 {&pmshapi_handle, "PRF32RESET", 0},
532 {&pmshapi_handle, "PRF32QUERYPROFILEDATA", 0},
533 {&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0},
535 /* At least some of these do not work by name, since they need
536 WIN32 instead of WIN... */
538 These were generated with
539 nm I:\emx\lib\os2.a | fgrep -f API-list | grep = > API-list-entries
540 perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( ORD_$1,)" API-list-entries > API-list-ORD_
541 perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( {${2}_handle, NULL, $3},\t\t/* $1 */)" WinSwitch-API-list-entries >API-list-entry
543 {&pmshapi_handle, NULL, 123}, /* WinChangeSwitchEntry */
544 {&pmshapi_handle, NULL, 124}, /* WinQuerySwitchEntry */
545 {&pmshapi_handle, NULL, 125}, /* WinQuerySwitchHandle */
546 {&pmshapi_handle, NULL, 126}, /* WinQuerySwitchList */
547 {&pmshapi_handle, NULL, 131}, /* WinSwitchToProgram */
548 {&pmwin_handle, NULL, 702}, /* WinBeginEnumWindows */
549 {&pmwin_handle, NULL, 737}, /* WinEndEnumWindows */
550 {&pmwin_handle, NULL, 740}, /* WinEnumDlgItem */
551 {&pmwin_handle, NULL, 756}, /* WinGetNextWindow */
552 {&pmwin_handle, NULL, 768}, /* WinIsChild */
553 {&pmwin_handle, NULL, 799}, /* WinQueryActiveWindow */
554 {&pmwin_handle, NULL, 805}, /* WinQueryClassName */
555 {&pmwin_handle, NULL, 817}, /* WinQueryFocus */
556 {&pmwin_handle, NULL, 834}, /* WinQueryWindow */
557 {&pmwin_handle, NULL, 837}, /* WinQueryWindowPos */
558 {&pmwin_handle, NULL, 838}, /* WinQueryWindowProcess */
559 {&pmwin_handle, NULL, 841}, /* WinQueryWindowText */
560 {&pmwin_handle, NULL, 842}, /* WinQueryWindowTextLength */
561 {&pmwin_handle, NULL, 860}, /* WinSetFocus */
562 {&pmwin_handle, NULL, 875}, /* WinSetWindowPos */
563 {&pmwin_handle, NULL, 877}, /* WinSetWindowText */
564 {&pmwin_handle, NULL, 883}, /* WinShowWindow */
565 {&pmwin_handle, NULL, 772}, /* WinIsWindow */
566 {&pmwin_handle, NULL, 899}, /* WinWindowFromId */
567 {&pmwin_handle, NULL, 900}, /* WinWindowFromPoint */
568 {&pmwin_handle, NULL, 919}, /* WinPostMsg */
569 {&pmwin_handle, NULL, 735}, /* WinEnableWindow */
570 {&pmwin_handle, NULL, 736}, /* WinEnableWindowUpdate */
571 {&pmwin_handle, NULL, 773}, /* WinIsWindowEnabled */
572 {&pmwin_handle, NULL, 774}, /* WinIsWindowShowing */
573 {&pmwin_handle, NULL, 775}, /* WinIsWindowVisible */
574 {&pmwin_handle, NULL, 839}, /* WinQueryWindowPtr */
575 {&pmwin_handle, NULL, 843}, /* WinQueryWindowULong */
576 {&pmwin_handle, NULL, 844}, /* WinQueryWindowUShort */
577 {&pmwin_handle, NULL, 874}, /* WinSetWindowBits */
578 {&pmwin_handle, NULL, 876}, /* WinSetWindowPtr */
579 {&pmwin_handle, NULL, 878}, /* WinSetWindowULong */
580 {&pmwin_handle, NULL, 879}, /* WinSetWindowUShort */
581 {&pmwin_handle, NULL, 813}, /* WinQueryDesktopWindow */
582 {&pmwin_handle, NULL, 851}, /* WinSetActiveWindow */
583 {&doscalls_handle, NULL, 360}, /* DosQueryModFromEIP */
584 {&doscalls_handle, NULL, 582}, /* Dos32QueryHeaderInfo */
585 {&doscalls_handle, NULL, 362}, /* DosTmrQueryFreq */
586 {&doscalls_handle, NULL, 363}, /* DosTmrQueryTime */
587 {&pmwp_handle, NULL, 262}, /* WinQueryActiveDesktopPathname */
588 {&pmwin_handle, NULL, 765}, /* WinInvalidateRect */
589 {&pmwin_handle, NULL, 906}, /* WinCreateFrameControl */
590 {&pmwin_handle, NULL, 807}, /* WinQueryClipbrdFmtInfo */
591 {&pmwin_handle, NULL, 808}, /* WinQueryClipbrdOwner */
592 {&pmwin_handle, NULL, 809}, /* WinQueryClipbrdViewer */
593 {&pmwin_handle, NULL, 806}, /* WinQueryClipbrdData */
594 {&pmwin_handle, NULL, 793}, /* WinOpenClipbrd */
595 {&pmwin_handle, NULL, 707}, /* WinCloseClipbrd */
596 {&pmwin_handle, NULL, 854}, /* WinSetClipbrdData */
597 {&pmwin_handle, NULL, 855}, /* WinSetClipbrdOwner */
598 {&pmwin_handle, NULL, 856}, /* WinSetClipbrdViewer */
599 {&pmwin_handle, NULL, 739}, /* WinEnumClipbrdFmts */
600 {&pmwin_handle, NULL, 733}, /* WinEmptyClipbrd */
601 {&pmwin_handle, NULL, 700}, /* WinAddAtom */
602 {&pmwin_handle, NULL, 744}, /* WinFindAtom */
603 {&pmwin_handle, NULL, 721}, /* WinDeleteAtom */
604 {&pmwin_handle, NULL, 803}, /* WinQueryAtomUsage */
605 {&pmwin_handle, NULL, 802}, /* WinQueryAtomName */
606 {&pmwin_handle, NULL, 801}, /* WinQueryAtomLength */
607 {&pmwin_handle, NULL, 830}, /* WinQuerySystemAtomTable */
608 {&pmwin_handle, NULL, 714}, /* WinCreateAtomTable */
609 {&pmwin_handle, NULL, 724}, /* WinDestroyAtomTable */
610 {&pmwin_handle, NULL, 794}, /* WinOpenWindowDC */
611 {&pmgpi_handle, NULL, 610}, /* DevOpenDC */
612 {&pmgpi_handle, NULL, 606}, /* DevQueryCaps */
613 {&pmgpi_handle, NULL, 604}, /* DevCloseDC */
614 {&pmwin_handle, NULL, 789}, /* WinMessageBox */
615 {&pmwin_handle, NULL, 1015}, /* WinMessageBox2 */
616 {&pmwin_handle, NULL, 829}, /* WinQuerySysValue */
617 {&pmwin_handle, NULL, 873}, /* WinSetSysValue */
618 {&pmwin_handle, NULL, 701}, /* WinAlarm */
619 {&pmwin_handle, NULL, 745}, /* WinFlashWindow */
620 {&pmwin_handle, NULL, 780}, /* WinLoadPointer */
621 {&pmwin_handle, NULL, 828}, /* WinQuerySysPointer */
622 {&doscalls_handle, NULL, 417}, /* DosReplaceModule */
626 loadModule(const char *modname, int fail)
628 HMODULE h = (HMODULE)dlopen(modname, 0);
631 Perl_croak_nocontext("Error loading module '%s': %s",
636 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
645 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
646 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
649 return (pib->pib_ultype);
653 my_type_set(int type)
659 if (!(_emx_env & 0x200))
660 Perl_croak_nocontext("Can't set type on DOS"); /* not OS/2. */
661 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
662 croak_with_os2error("Error getting info blocks");
663 pib->pib_ultype = type;
667 loadByOrdinal(enum entries_ordinals ord, int fail)
669 if (sizeof(loadOrdinals)/sizeof(loadOrdinals[0]) != ORD_NENTRIES)
670 Perl_croak_nocontext(
671 "Wrong size of loadOrdinals array: expected %d, actual %d",
672 sizeof(loadOrdinals)/sizeof(loadOrdinals[0]), ORD_NENTRIES);
673 if (ExtFCN[ord] == NULL) {
677 if (!loadOrdinals[ord].dll->handle) {
678 if (loadOrdinals[ord].dll->requires_pm && my_type() < 2) { /* FS */
679 char *s = getenv("PERL_ASIF_PM");
681 if (!s || !atoi(s)) {
682 /* The module will not function well without PM.
683 The usual way to detect PM is the existence of the mutex
684 \SEM32\PMDRAG.SEM. */
687 if (CheckOSError(DosOpenMutexSem("\\SEM32\\PMDRAG.SEM",
689 Perl_croak_nocontext("Looks like we have no PM; will not load DLL %s without $ENV{PERL_ASIF_PM}",
690 loadOrdinals[ord].dll->modname);
691 DosCloseMutexSem(hMtx);
694 MUTEX_LOCK(&perlos2_state_mutex);
695 loadOrdinals[ord].dll->handle
696 = loadModule(loadOrdinals[ord].dll->modname, fail);
697 MUTEX_UNLOCK(&perlos2_state_mutex);
699 if (!loadOrdinals[ord].dll->handle)
700 return 0; /* Possible with FAIL==0 only */
701 if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle,
702 loadOrdinals[ord].entrypoint,
703 loadOrdinals[ord].entryname,&fcn))) {
704 char buf[20], *s = (char*)loadOrdinals[ord].entryname;
709 sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint);
710 Perl_croak_nocontext(
711 "This version of OS/2 does not support %s.%s",
712 loadOrdinals[ord].dll->modname, s);
716 if ((long)ExtFCN[ord] == -1)
717 Perl_croak_nocontext("panic queryaddr");
722 init_PMWIN_entries(void)
726 for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++)
727 ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1);
730 /*****************************************************/
731 /* socket forwarders without linking with tcpip DLLs */
733 DeclFuncByORD(struct hostent *, gethostent, ORD_GETHOSTENT, (void), ())
734 DeclFuncByORD(struct netent *, getnetent, ORD_GETNETENT, (void), ())
735 DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ())
736 DeclFuncByORD(struct servent *, getservent, ORD_GETSERVENT, (void), ())
738 DeclVoidFuncByORD(sethostent, ORD_SETHOSTENT, (int x), (x))
739 DeclVoidFuncByORD(setnetent, ORD_SETNETENT, (int x), (x))
740 DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x))
741 DeclVoidFuncByORD(setservent, ORD_SETSERVENT, (int x), (x))
743 DeclVoidFuncByORD(endhostent, ORD_ENDHOSTENT, (void), ())
744 DeclVoidFuncByORD(endnetent, ORD_ENDNETENT, (void), ())
745 DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ())
746 DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ())
749 static const signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
751 #define QSS_INI_BUFFER 1024
753 ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
756 get_sysinfo(ULONG pid, ULONG flags)
759 ULONG rc, buf_len = QSS_INI_BUFFER;
762 if (!pidtid_lookup) {
764 *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0);
766 if (pDosVerifyPidTid) { /* Warp3 or later */
767 /* Up to some fixpak QuerySysState() kills the system if a non-existent
769 if (CheckOSError(pDosVerifyPidTid(pid, 1)))
772 New(1322, pbuffer, buf_len, char);
773 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
774 rc = QuerySysState(flags, pid, pbuffer, buf_len);
775 while (rc == ERROR_BUFFER_OVERFLOW) {
776 Renew(pbuffer, buf_len *= 2, char);
777 rc = QuerySysState(flags, pid, pbuffer, buf_len);
784 psi = (PQTOPLEVEL)pbuffer;
785 if (psi && pid && psi->procdata && pid != psi->procdata->pid) {
787 Perl_croak_nocontext("panic: wrong pid in sysinfo");
792 #define PRIO_ERR 0x1111
802 psi = get_sysinfo(pid, QSS_PROCESS);
805 prio = psi->procdata->threads->priority;
811 setpriority(int which, int pid, int val)
813 ULONG rc, prio = sys_prio(pid);
815 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
816 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
817 /* Do not change class. */
818 return CheckOSError(DosSetPriority((pid < 0)
819 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
821 (32 - val) % 32 - (prio & 0xFF),
824 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
825 /* Documentation claims one can change both class and basevalue,
826 * but I find it wrong. */
827 /* Change class, but since delta == 0 denotes absolute 0, correct. */
828 if (CheckOSError(DosSetPriority((pid < 0)
829 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
830 priors[(32 - val) >> 5] + 1,
834 if ( ((32 - val) % 32) == 0 ) return 0;
835 return CheckOSError(DosSetPriority((pid < 0)
836 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
845 getpriority(int which /* ignored */, int pid)
849 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
851 if (ret == PRIO_ERR) {
854 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
857 /*****************************************************************************/
863 spawn_sighandler(int sig)
865 /* Some programs do not arrange for the keyboard signals to be
866 delivered to them. We need to deliver the signal manually. */
867 /* We may get a signal only if
868 a) kid does not receive keyboard signal: deliver it;
869 b) kid already died, and we get a signal. We may only hope
870 that the pid number was not reused.
874 sig = SIGKILL; /* Try harder. */
875 kill(spawn_pid, sig);
880 result(pTHX_ int flag, int pid)
883 Signal_t (*ihand)(); /* place to save signal during system() */
884 Signal_t (*qhand)(); /* place to save signal during system() */
890 if (pid < 0 || flag != 0)
896 ihand = rsignal(SIGINT, &spawn_sighandler);
897 qhand = rsignal(SIGQUIT, &spawn_sighandler);
899 r = wait4pid(pid, &status, 0);
900 } while (r == -1 && errno == EINTR);
901 rsignal(SIGINT, ihand);
902 rsignal(SIGQUIT, qhand);
904 PL_statusvalue = (U16)status;
907 return status & 0xFFFF;
909 ihand = rsignal(SIGINT, SIG_IGN);
910 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
911 rsignal(SIGINT, ihand);
912 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
915 return PL_statusvalue;
929 file_type(char *path)
934 if (!(_emx_env & 0x200))
935 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
936 if (CheckOSError(DosQueryAppType(path, &apptype))) {
938 case ERROR_FILE_NOT_FOUND:
939 case ERROR_PATH_NOT_FOUND:
941 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
943 default: /* Found, but not an
944 executable, or some other
952 /* Spawn/exec a program, revert to shell if needed. */
953 /* global PL_Argv[] contains arguments. */
955 extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
956 EXCEPTIONREGISTRATIONRECORD *,
961 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
966 char const * args[4];
967 static const char * const fargs[4]
968 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
969 const char * const *argsp = fargs;
972 int new_stderr = -1, nostderr = 0;
980 if (really && !*(real_name = SvPV(really, n_a)))
984 if (strEQ(PL_Argv[0],"/bin/sh"))
985 PL_Argv[0] = PL_sh_path;
987 /* We should check PERL_SH* and PERLLIB_* as well? */
988 if (!really || pass >= 2)
989 real_name = PL_Argv[0];
990 if (real_name[0] != '/' && real_name[0] != '\\'
991 && !(real_name[0] && real_name[1] == ':'
992 && (real_name[2] == '/' || real_name[2] != '\\'))
993 ) /* will spawnvp use PATH? */
994 TAINT_ENV(); /* testing IFS here is overkill, probably */
998 if (_emx_env & 0x200) { /* OS/2. */
999 int type = file_type(real_name);
1001 if (type == -1) { /* Not found */
1006 else if (type == -2) { /* Not an EXE */
1011 else if (type == -3) { /* Is a directory? */
1012 /* Special-case this */
1014 int l = strlen(real_name);
1016 if (l + 5 <= sizeof tbuf) {
1017 strcpy(tbuf, real_name);
1018 strcpy(tbuf + l, ".exe");
1019 type = file_type(tbuf);
1029 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
1030 case FAPPTYP_WINDOWAPI:
1031 { /* Apparently, kids are started basing on startup type, not the morphed type */
1032 if (os2_mytype != 3) { /* not PM */
1033 if (flag == P_NOWAIT)
1035 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
1036 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d",
1041 case FAPPTYP_NOTWINDOWCOMPAT:
1043 if (os2_mytype != 0) { /* not full screen */
1044 if (flag == P_NOWAIT)
1046 else if ((flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
1047 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d",
1052 case FAPPTYP_NOTSPEC:
1053 /* Let the shell handle this... */
1055 buf = ""; /* Pacify a warning */
1056 file = 0; /* Pacify a warning */
1064 new_stderr = dup(2); /* Preserve stderr */
1065 if (new_stderr == -1) {
1073 fl_stderr = fcntl(2, F_GETFD);
1077 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
1081 rc = result(aTHX_ trueflag, spawnvp(flag,real_name,PL_Argv));
1083 if (execf == EXECF_TRUEEXEC)
1084 rc = execvp(real_name,PL_Argv);
1085 else if (execf == EXECF_EXEC)
1086 rc = spawnvp(trueflag | P_OVERLAY,real_name,PL_Argv);
1087 else if (execf == EXECF_SPAWN_NOWAIT)
1088 rc = spawnvp(flag,real_name,PL_Argv);
1089 else if (execf == EXECF_SYNC)
1090 rc = spawnvp(trueflag,real_name,PL_Argv);
1091 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
1092 rc = result(aTHX_ trueflag,
1093 spawnvp(flag,real_name,PL_Argv));
1095 if (rc < 0 && pass == 1) {
1097 if (real_name == PL_Argv[0]) {
1100 if (err == ENOENT || err == ENOEXEC) {
1101 /* No such file, or is a script. */
1102 /* Try adding script extensions to the file name, and
1104 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
1108 SV *scrsv = sv_2mortal(newSVpv(scr, 0));
1109 SV *bufsv = sv_newmortal();
1112 scr = SvPV(scrsv, n_a); /* free()ed later */
1114 file = PerlIO_open(scr, "r");
1119 buf = sv_gets(bufsv, file, 0 /* No append */);
1121 buf = ""; /* XXX Needed? */
1122 if (!buf[0]) { /* Empty... */
1124 /* Special case: maybe from -Zexe build, so
1125 there is an executable around (contrary to
1126 documentation, DosQueryAppType sometimes (?)
1127 does not append ".exe", so we could have
1128 reached this place). */
1129 sv_catpv(scrsv, ".exe");
1130 scr = SvPV(scrsv, n_a); /* Reload */
1131 if (PerlLIO_stat(scr,&PL_statbuf) >= 0
1132 && !S_ISDIR(PL_statbuf.st_mode)) { /* Found */
1136 } else { /* Restore */
1137 SvCUR_set(scrsv, SvCUR(scrsv) - 4);
1141 if (PerlIO_close(file) != 0) { /* Failure */
1143 if (ckWARN(WARN_EXEC))
1144 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
1145 scr, Strerror(errno));
1146 buf = ""; /* Not #! */
1149 if (buf[0] == '#') {
1152 } else if (buf[0] == 'e') {
1153 if (strnEQ(buf, "extproc", 7)
1156 } else if (buf[0] == 'E') {
1157 if (strnEQ(buf, "EXTPROC", 7)
1162 buf = ""; /* Not #! */
1170 /* Do better than pdksh: allow a few args,
1171 strip trailing whitespace. */
1181 while (*s && !isSPACE(*s))
1188 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"",
1189 s1 - buf, buf, scr);
1193 /* Can jump from far, buf/file invalid if force_shell: */
1197 const char *exec_args[2];
1200 || (!buf[0] && file)) { /* File without magic */
1201 /* In fact we tried all what pdksh would
1202 try. There is no point in calling
1203 pdksh, we may just emulate its logic. */
1204 char *shell = getenv("EXECSHELL");
1205 char *shell_opt = NULL;
1211 shell = getenv("OS2_SHELL");
1212 if (inicmd) { /* No spaces at start! */
1214 while (*s && !isSPACE(*s)) {
1216 inicmd = NULL; /* Cannot use */
1224 /* Dosish shells will choke on slashes
1225 in paths, fortunately, this is
1226 important for zeroth arg only. */
1233 /* If EXECSHELL is set, we do not set */
1236 shell = ((_emx_env & 0x200)
1238 : "c:/command.com");
1239 nargs = shell_opt ? 2 : 1; /* shell file args */
1240 exec_args[0] = shell;
1241 exec_args[1] = shell_opt;
1243 if (nargs == 2 && inicmd) {
1244 /* Use the original cmd line */
1245 /* XXXX This is good only until we refuse
1246 quoted arguments... */
1247 PL_Argv[0] = inicmd;
1248 PL_Argv[1] = Nullch;
1250 } else if (!buf[0] && inicmd) { /* No file */
1251 /* Start with the original cmdline. */
1252 /* XXXX This is good only until we refuse
1253 quoted arguments... */
1255 PL_Argv[0] = inicmd;
1256 PL_Argv[1] = Nullch;
1257 nargs = 2; /* shell -c */
1260 while (a[1]) /* Get to the end */
1262 a++; /* Copy finil NULL too */
1263 while (a >= PL_Argv) {
1264 *(a + nargs) = *a; /* PL_Argv was preallocated to be
1268 while (--nargs >= 0) /* XXXX Discard const... */
1269 PL_Argv[nargs] = (char*)argsp[nargs];
1270 /* Enable pathless exec if #! (as pdksh). */
1271 pass = (buf[0] == '#' ? 2 : 3);
1275 /* Not found: restore errno */
1278 } else if (errno == ENOEXEC) { /* Cannot transfer `real_name' via shell. */
1279 if (rc < 0 && ckWARN(WARN_EXEC))
1280 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s script `%s' with ARGV[0] being `%s'",
1281 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1282 ? "spawn" : "exec"),
1283 real_name, PL_Argv[0]);
1285 } else if (errno == ENOENT) { /* Cannot transfer `real_name' via shell. */
1286 if (rc < 0 && ckWARN(WARN_EXEC))
1287 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)",
1288 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1289 ? "spawn" : "exec"),
1290 real_name, PL_Argv[0]);
1293 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
1294 char *no_dir = strrchr(PL_Argv[0], '/');
1296 /* Do as pdksh port does: if not found with /, try without
1299 PL_Argv[0] = no_dir + 1;
1304 if (rc < 0 && ckWARN(WARN_EXEC))
1305 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n",
1306 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1307 ? "spawn" : "exec"),
1308 real_name, Strerror(errno));
1310 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
1311 && ((trueflag & 0xFF) == P_WAIT))
1315 if (new_stderr != -1) { /* How can we use error codes? */
1316 dup2(new_stderr, 2);
1318 fcntl(2, F_SETFD, fl_stderr);
1319 } else if (nostderr)
1324 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
1326 do_spawn3(pTHX_ char *cmd, int execf, int flag)
1330 char *shell, *copt, *news = NULL;
1331 int rc, seenspace = 0, mergestderr = 0;
1334 if ((shell = getenv("EMXSHELL")) != NULL)
1336 else if ((shell = getenv("SHELL")) != NULL)
1338 else if ((shell = getenv("COMSPEC")) != NULL)
1343 /* Consensus on perl5-porters is that it is _very_ important to
1344 have a shell which will not change between computers with the
1345 same architecture, to avoid "action on a distance".
1346 And to have simple build, this shell should be sh. */
1351 while (*cmd && isSPACE(*cmd))
1354 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
1355 STRLEN l = strlen(PL_sh_path);
1357 New(1302, news, strlen(cmd) - 7 + l + 1, char);
1358 strcpy(news, PL_sh_path);
1359 strcpy(news + l, cmd + 7);
1363 /* save an extra exec if possible */
1364 /* see if there are shell metacharacters in it */
1366 if (*cmd == '.' && isSPACE(cmd[1]))
1369 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1372 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
1376 for (s = cmd; *s; s++) {
1377 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
1378 if (*s == '\n' && s[1] == '\0') {
1381 } else if (*s == '\\' && !seenspace) {
1382 continue; /* Allow backslashes in names */
1383 } else if (*s == '>' && s >= cmd + 3
1384 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
1385 && isSPACE(s[-2]) ) {
1388 while (*t && isSPACE(*t))
1393 break; /* Allow 2>&1 as the last thing */
1396 /* We do not convert this to do_spawn_ve since shell
1397 should be smart enough to start itself gloriously. */
1399 if (execf == EXECF_TRUEEXEC)
1400 rc = execl(shell,shell,copt,cmd,(char*)0);
1401 else if (execf == EXECF_EXEC)
1402 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
1403 else if (execf == EXECF_SPAWN_NOWAIT)
1404 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
1405 else if (execf == EXECF_SPAWN_BYFLAG)
1406 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
1408 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
1409 if (execf == EXECF_SYNC)
1410 rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0);
1412 rc = result(aTHX_ P_WAIT,
1413 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
1414 if (rc < 0 && ckWARN(WARN_EXEC))
1415 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
1416 (execf == EXECF_SPAWN ? "spawn" : "exec"),
1417 shell, Strerror(errno));
1424 } else if (*s == ' ' || *s == '\t') {
1429 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
1430 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
1431 PL_Cmd = savepvn(cmd, s-cmd);
1433 for (s = PL_Cmd; *s;) {
1434 while (*s && isSPACE(*s)) s++;
1437 while (*s && !isSPACE(*s)) s++;
1443 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
1452 /* Array spawn/exec. */
1454 os2_aspawn4(pTHX_ SV *really, register SV **vmark, register SV **vsp, int execing)
1456 register SV **mark = (SV **)vmark;
1457 register SV **sp = (SV **)vsp;
1460 int flag = P_WAIT, flag_set = 0;
1464 New(1301,PL_Argv, sp - mark + 3, char*);
1467 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
1469 flag = SvIVx(*mark);
1474 while (++mark <= sp) {
1476 *a++ = SvPVx(*mark, n_a);
1482 if ( flag_set && (a == PL_Argv + 1)
1483 && !really && !execing ) { /* One arg? */
1484 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
1486 rc = do_spawn_ve(aTHX_ really, flag,
1487 (execing ? EXECF_EXEC : EXECF_SPAWN), NULL, 0);
1496 os2_do_aspawn(pTHX_ SV *really, register SV **vmark, register SV **vsp)
1498 return os2_aspawn4(aTHX_ really, vmark, vsp, 0);
1503 Perl_do_aexec(pTHX_ SV* really, SV** vmark, SV** vsp)
1505 return os2_aspawn4(aTHX_ really, vmark, vsp, 1);
1509 os2_do_spawn(pTHX_ char *cmd)
1511 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
1515 do_spawn_nowait(pTHX_ char *cmd)
1517 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1521 Perl_do_exec(pTHX_ char *cmd)
1523 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1528 os2exec(pTHX_ char *cmd)
1530 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1534 my_syspopen(pTHX_ char *cmd, char *mode)
1538 register I32 this, that, newfd;
1541 int fh_fl = 0; /* Pacify the warning */
1543 /* `this' is what we use in the parent, `that' in the child. */
1544 this = (*mode == 'w');
1548 taint_proper("Insecure %s%s", "EXEC");
1552 /* Now we need to spawn the child. */
1553 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1554 int new = dup(p[this]);
1561 newfd = dup(*mode == 'r'); /* Preserve std* */
1563 /* This cannot happen due to fh being bad after pipe(), since
1564 pipe() should have created fh 0 and 1 even if they were
1565 initially closed. But we closed p[this] before. */
1566 if (errno != EBADF) {
1573 fh_fl = fcntl(*mode == 'r', F_GETFD);
1574 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1575 dup2(p[that], *mode == 'r');
1578 /* Where is `this' and newfd now? */
1579 fcntl(p[this], F_SETFD, FD_CLOEXEC);
1581 fcntl(newfd, F_SETFD, FD_CLOEXEC);
1582 pid = do_spawn_nowait(aTHX_ cmd);
1584 close(*mode == 'r'); /* It was closed initially */
1585 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1586 dup2(newfd, *mode == 'r'); /* Return std* back. */
1588 fcntl(*mode == 'r', F_SETFD, fh_fl);
1590 fcntl(*mode == 'r', F_SETFD, fh_fl);
1591 if (p[that] == (*mode == 'r'))
1597 if (p[that] < p[this]) { /* Make fh as small as possible */
1598 dup2(p[this], p[that]);
1602 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1603 (void)SvUPGRADE(sv,SVt_IV);
1605 PL_forkprocess = pid;
1606 return PerlIO_fdopen(p[this], mode);
1608 #else /* USE_POPEN */
1614 res = popen(cmd, mode);
1616 char *shell = getenv("EMXSHELL");
1618 my_setenv("EMXSHELL", PL_sh_path);
1619 res = popen(cmd, mode);
1620 my_setenv("EMXSHELL", shell);
1622 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1623 (void)SvUPGRADE(sv,SVt_IV);
1624 SvIVX(sv) = -1; /* A cooky. */
1627 #endif /* USE_POPEN */
1631 /******************************************************************/
1637 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1643 /*******************************************************************/
1644 /* not implemented in EMX 0.9d */
1646 char * ctermid(char *s) { return 0; }
1648 #ifdef MYTTYNAME /* was not in emx0.9a */
1649 void * ttyname(x) { return 0; }
1652 /*****************************************************************************/
1653 /* not implemented in C Set++ */
1656 int setuid(x) { errno = EINVAL; return -1; }
1657 int setgid(x) { errno = EINVAL; return -1; }
1660 /*****************************************************************************/
1661 /* stat() hack for char/block device */
1665 enum os2_stat_extra { /* EMX 0.9d fix 4 defines up to 0100000 */
1666 os2_stat_archived = 0x1000000, /* 0100000000 */
1667 os2_stat_hidden = 0x2000000, /* 0200000000 */
1668 os2_stat_system = 0x4000000, /* 0400000000 */
1669 os2_stat_force = 0x8000000, /* Do not ignore flags on chmod */
1672 #define OS2_STAT_SPECIAL (os2_stat_system | os2_stat_archived | os2_stat_hidden)
1675 massage_os2_attr(struct stat *st)
1677 if ( ((st->st_mode & S_IFMT) != S_IFREG
1678 && (st->st_mode & S_IFMT) != S_IFDIR)
1679 || !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM)))
1682 if ( st->st_attr & FILE_ARCHIVED )
1683 st->st_mode |= (os2_stat_archived | os2_stat_force);
1684 if ( st->st_attr & FILE_HIDDEN )
1685 st->st_mode |= (os2_stat_hidden | os2_stat_force);
1686 if ( st->st_attr & FILE_SYSTEM )
1687 st->st_mode |= (os2_stat_system | os2_stat_force);
1690 /* First attempt used DosQueryFSAttach which crashed the system when
1691 used with 5.001. Now just look for /dev/. */
1693 os2_stat(const char *name, struct stat *st)
1695 static int ino = SHRT_MAX;
1696 STRLEN l = strlen(name);
1698 if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0
1699 || ( stricmp(name + 5, "con") != 0
1700 && stricmp(name + 5, "tty") != 0
1701 && stricmp(name + 5, "nul") != 0
1702 && stricmp(name + 5, "null") != 0) ) {
1703 int s = stat(name, st);
1707 massage_os2_attr(st);
1711 memset(st, 0, sizeof *st);
1712 st->st_mode = S_IFCHR|0666;
1713 MUTEX_LOCK(&perlos2_state_mutex);
1714 st->st_ino = (ino-- & 0x7FFF);
1715 MUTEX_UNLOCK(&perlos2_state_mutex);
1721 os2_fstat(int handle, struct stat *st)
1723 int s = fstat(handle, st);
1727 massage_os2_attr(st);
1733 os2_chmod (const char *name, int pmode) /* Modelled after EMX src/lib/io/chmod.c */
1737 if (!(pmode & os2_stat_force))
1738 return chmod(name, pmode);
1740 attr = __chmod (name, 0, 0); /* Get attributes */
1743 if (pmode & S_IWRITE)
1744 attr &= ~FILE_READONLY;
1746 attr |= FILE_READONLY;
1748 attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM);
1750 if ( pmode & os2_stat_archived )
1751 attr |= FILE_ARCHIVED;
1752 if ( pmode & os2_stat_hidden )
1753 attr |= FILE_HIDDEN;
1754 if ( pmode & os2_stat_system )
1755 attr |= FILE_SYSTEM;
1757 rc = __chmod (name, 1, attr);
1758 if (rc >= 0) rc = 0;
1764 #ifdef USE_PERL_SBRK
1766 /* SBRK() emulation, mostly moved to malloc.c. */
1769 sys_alloc(int size) {
1771 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1773 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1776 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1780 #endif /* USE_PERL_SBRK */
1784 const char *tmppath = TMPPATH1;
1789 char *p = getenv("TMP"), *tpath;
1792 if (!p) p = getenv("TEMP");
1793 if (!p) p = getenv("TMPDIR");
1796 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1800 strcpy(tpath + len + 1, TMPPATH1);
1807 XS(XS_File__Copy_syscopy)
1810 if (items < 2 || items > 3)
1811 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1814 char * src = (char *)SvPV(ST(0),n_a);
1815 char * dst = (char *)SvPV(ST(1),n_a);
1823 flag = (unsigned long)SvIV(ST(2));
1826 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1827 XSprePUSH; PUSHi((IV)RETVAL);
1832 /* APIRET APIENTRY DosReplaceModule (PCSZ pszOld, PCSZ pszNew, PCSZ pszBackup); */
1834 DeclOSFuncByORD(ULONG,replaceModule,ORD_DosReplaceModule,
1835 (char *old, char *new, char *backup), (old, new, backup))
1837 XS(XS_OS2_replaceModule); /* prototype to pass -Wmissing-prototypes */
1838 XS(XS_OS2_replaceModule)
1841 if (items < 1 || items > 3)
1842 Perl_croak(aTHX_ "Usage: OS2::replaceModule(target [, source [, backup]])");
1844 char * target = (char *)SvPV_nolen(ST(0));
1845 char * source = (items < 2) ? Nullch : (char *)SvPV_nolen(ST(1));
1846 char * backup = (items < 3) ? Nullch : (char *)SvPV_nolen(ST(2));
1848 if (!replaceModule(target, source, backup))
1849 croak_with_os2error("replaceModule() error");
1855 #define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */
1856 #include "patchlevel.h"
1857 #undef PERL_PATCHLEVEL_H_IMPLICIT
1860 mod2fname(pTHX_ SV *sv)
1862 int pos = 6, len, avlen;
1863 unsigned int sum = 0;
1867 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1869 if (SvTYPE(sv) != SVt_PVAV)
1870 Perl_croak_nocontext("Not array reference given to mod2fname");
1872 avlen = av_len((AV*)sv);
1874 Perl_croak_nocontext("Empty array reference given to mod2fname");
1876 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1877 strncpy(fname, s, 8);
1879 if (len < 6) pos = len;
1881 sum = 33 * sum + *(s++); /* Checksumming first chars to
1882 * get the capitalization into c.s. */
1885 while (avlen >= 0) {
1886 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1888 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1892 /* We always load modules as *specific* DLLs, and with the full name.
1893 When loading a specific DLL by its full name, one cannot get a
1894 different DLL, even if a DLL with the same basename is loaded already.
1895 Thus there is no need to include the version into the mangling scheme. */
1897 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
1899 # ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
1900 # define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
1902 sum += COMPATIBLE_VERSION_SUM;
1904 fname[pos] = 'A' + (sum % 26);
1905 fname[pos + 1] = 'A' + (sum / 26 % 26);
1906 fname[pos + 2] = '\0';
1907 return (char *)fname;
1910 XS(XS_DynaLoader_mod2fname)
1914 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1920 RETVAL = mod2fname(aTHX_ sv);
1921 sv_setpv(TARG, RETVAL);
1922 XSprePUSH; PUSHTARG;
1933 int number = SvTRUE(get_sv("OS2::nsyserror", TRUE));
1935 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1939 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
1940 s = os2error_buf + strlen(os2error_buf);
1943 if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf),
1944 rc, "OSO001.MSG", &len)) {
1948 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
1949 s = os2error_buf + strlen(os2error_buf);
1952 case PMERR_INVALID_HWND:
1953 name = "PMERR_INVALID_HWND";
1955 case PMERR_INVALID_HMQ:
1956 name = "PMERR_INVALID_HMQ";
1958 case PMERR_CALL_FROM_WRONG_THREAD:
1959 name = "PMERR_CALL_FROM_WRONG_THREAD";
1961 case PMERR_NO_MSG_QUEUE:
1962 name = "PMERR_NO_MSG_QUEUE";
1964 case PMERR_NOT_IN_A_PM_SESSION:
1965 name = "PMERR_NOT_IN_A_PM_SESSION";
1968 sprintf(s, "%s%s[No description found in OSO001.MSG]",
1969 name, (*name ? "=" : ""));
1972 if (len && s[len - 1] == '\n')
1974 if (len && s[len - 1] == '\r')
1976 if (len && s[len - 1] == '.')
1978 if (len >= 10 && number && strnEQ(s, os2error_buf, 7)
1979 && s[7] == ':' && s[8] == ' ')
1980 /* Some messages start with SYSdddd:, some not */
1981 Move(s + 9, s, (len -= 9) + 1, char);
1983 return os2error_buf;
1993 CroakWinError(int die, char *name)
1996 if (die && Perl_rc) {
1999 Perl_croak(aTHX_ "%s: %s", (name ? name : "Win* API call"), os2error(Perl_rc));
2006 char buf[300], *p, *o = PL_origargv[0], ok = 1;
2008 if (_execname(buf, sizeof buf) != 0)
2015 if (ok && *o != '/' && *o != '\\')
2017 } else if (ok && tolower(*o) != tolower(*p))
2022 if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */
2023 strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */
2037 perllib_mangle(char *s, unsigned int l)
2039 if (!newp && !notfound) {
2040 newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION)
2041 STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION)
2044 newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION)
2045 STRINGIFY(PERL_VERSION) "_PREFIX");
2047 newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX");
2049 newp = getenv("PERLLIB_PREFIX");
2054 while (*newp && !isSPACE(*newp) && *newp != ';') {
2055 newp++; oldl++; /* Skip digits. */
2057 while (*newp && (isSPACE(*newp) || *newp == ';')) {
2058 newp++; /* Skip whitespace. */
2060 newl = strlen(newp);
2061 if (newl == 0 || oldl == 0) {
2062 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
2064 strcpy(mangle_ret, newp);
2067 if (*s == '\\') *s = '/';
2080 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
2083 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
2084 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
2086 strcpy(mangle_ret + newl, s + oldl);
2091 Perl_hab_GET() /* Needed if perl.h cannot be included */
2093 return perl_hab_GET();
2097 Create_HMQ(int serve, char *message) /* Assumes morphing */
2099 unsigned fpflag = _control87(0,0);
2101 init_PMWIN_entries();
2102 /* 64 messages if before OS/2 3.0, ignored otherwise */
2103 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
2107 SAVEINT(rmq_cnt); /* Allow catch()ing. */
2109 _exit(188); /* Panic can try to create a window. */
2110 CroakWinError(1, message ? message : "Cannot create a message queue");
2113 (*PMWIN_entries.CancelShutdown)(Perl_hmq, !serve);
2114 /* We may have loaded some modules */
2115 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
2118 #define REGISTERMQ_WILL_SERVE 1
2119 #define REGISTERMQ_IMEDIATE_UNMORPH 2
2122 Perl_Register_MQ(int serve)
2124 if (Perl_hmq_refcnt <= 0) {
2128 Perl_hmq_refcnt = 0; /* Be extra safe */
2129 DosGetInfoBlocks(&tib, &pib);
2130 if (!Perl_morph_refcnt) {
2131 Perl_os2_initial_mode = pib->pib_ultype;
2132 /* Try morphing into a PM application. */
2133 if (pib->pib_ultype != 3) /* 2 is VIO */
2134 pib->pib_ultype = 3; /* 3 is PM */
2136 Create_HMQ(-1, /* We do CancelShutdown ourselves */
2137 "Cannot create a message queue, or morph to a PM application");
2138 if ((serve & REGISTERMQ_IMEDIATE_UNMORPH)) {
2139 if (!Perl_morph_refcnt && Perl_os2_initial_mode != 3)
2140 pib->pib_ultype = Perl_os2_initial_mode;
2143 if (serve & REGISTERMQ_WILL_SERVE) {
2144 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
2145 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
2146 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
2148 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
2149 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
2151 if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH))
2152 Perl_morph_refcnt++;
2157 Perl_Serve_Messages(int force)
2162 if (Perl_hmq_servers > 0 && !force)
2164 if (Perl_hmq_refcnt <= 0)
2165 Perl_croak_nocontext("No message queue");
2166 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
2168 if (msg.msg == WM_QUIT)
2169 Perl_croak_nocontext("QUITing...");
2170 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
2176 Perl_Process_Messages(int force, I32 *cntp)
2180 if (Perl_hmq_servers > 0 && !force)
2182 if (Perl_hmq_refcnt <= 0)
2183 Perl_croak_nocontext("No message queue");
2184 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
2187 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
2188 if (msg.msg == WM_DESTROY)
2190 if (msg.msg == WM_CREATE)
2193 Perl_croak_nocontext("QUITing...");
2197 Perl_Deregister_MQ(int serve)
2199 if (serve & REGISTERMQ_WILL_SERVE)
2202 if (--Perl_hmq_refcnt <= 0) {
2203 unsigned fpflag = _control87(0,0);
2205 init_PMWIN_entries(); /* To be extra safe */
2206 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
2208 /* We may have (un)loaded some modules */
2209 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
2210 } else if ((serve & REGISTERMQ_WILL_SERVE) && Perl_hmq_servers <= 0)
2211 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); /* Last server exited */
2212 if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH) && (--Perl_morph_refcnt <= 0)) {
2213 /* Try morphing back from a PM application. */
2217 DosGetInfoBlocks(&tib, &pib);
2218 if (pib->pib_ultype == 3) /* 3 is PM */
2219 pib->pib_ultype = Perl_os2_initial_mode;
2221 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
2226 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
2227 && ((path)[2] == '/' || (path)[2] == '\\'))
2228 #define sys_is_rooted _fnisabs
2229 #define sys_is_relative _fnisrel
2230 #define current_drive _getdrive
2232 #undef chdir /* Was _chdir2. */
2233 #define sys_chdir(p) (chdir(p) == 0)
2234 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
2240 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
2242 int arg1 = SvIV(ST(0));
2243 int arg2 = SvIV(ST(1));
2244 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
2245 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
2246 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
2249 if (CheckOSError(DosError(a)))
2250 Perl_croak_nocontext("DosError(%d) failed: %s", a, os2error(Perl_rc));
2251 ST(0) = sv_newmortal();
2252 if (DOS_harderr_state >= 0)
2253 sv_setiv(ST(0), DOS_harderr_state);
2254 DOS_harderr_state = RETVAL;
2259 XS(XS_OS2_Errors2Drive)
2263 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
2267 int suppress = SvOK(sv);
2268 char *s = suppress ? SvPV(sv, n_a) : NULL;
2269 char drive = (s ? *s : 0);
2272 if (suppress && !isALPHA(drive))
2273 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
2274 if (CheckOSError(DosSuppressPopUps((suppress
2275 ? SPU_ENABLESUPPRESSION
2276 : SPU_DISABLESUPPRESSION),
2278 Perl_croak_nocontext("DosSuppressPopUps(%c) failed: %s", drive,
2280 ST(0) = sv_newmortal();
2281 if (DOS_suppression_state > 0)
2282 sv_setpvn(ST(0), &DOS_suppression_state, 1);
2283 else if (DOS_suppression_state == 0)
2284 sv_setpvn(ST(0), "", 0);
2285 DOS_suppression_state = drive;
2290 ULONG (*pDosTmrQueryFreq) (PULONG);
2291 ULONG (*pDosTmrQueryTime) (unsigned long long *);
2297 unsigned long long count;
2301 Perl_croak_nocontext("Usage: OS2::Timer()");
2303 *(PFN*)&pDosTmrQueryFreq = loadByOrdinal(ORD_DosTmrQueryFreq, 0);
2304 *(PFN*)&pDosTmrQueryTime = loadByOrdinal(ORD_DosTmrQueryTime, 0);
2305 MUTEX_LOCK(&perlos2_state_mutex);
2307 if (CheckOSError(pDosTmrQueryFreq(&freq)))
2308 croak_with_os2error("DosTmrQueryFreq");
2309 MUTEX_UNLOCK(&perlos2_state_mutex);
2311 if (CheckOSError(pDosTmrQueryTime(&count)))
2312 croak_with_os2error("DosTmrQueryTime");
2316 XSprePUSH; PUSHn(((NV)count)/freq);
2321 static const char * const dc_fields[] = {
2330 "HORIZONTAL_RESOLUTION",
2331 "VERTICAL_RESOLUTION",
2335 "SMALL_CHAR_HEIGHT",
2339 "COLOR_TABLE_SUPPORT",
2341 "FOREGROUND_MIX_SUPPORT",
2342 "BACKGROUND_MIX_SUPPORT",
2343 "VIO_LOADABLE_FONTS",
2344 "WINDOW_BYTE_ALIGNMENT",
2352 "GRAPHICS_VECTOR_SUBSET",
2354 "ADDITIONAL_GRAPHICS",
2357 "GRAPHICS_CHAR_WIDTH",
2358 "GRAPHICS_CHAR_HEIGHT",
2359 "HORIZONTAL_FONT_RES",
2360 "VERTICAL_FONT_RES",
2363 "DEVICE_POLYSET_POINTS",
2367 DevCap_dc, DevCap_hwnd
2370 HDC (*pWinOpenWindowDC) (HWND hwnd);
2371 HMF (*pDevCloseDC) (HDC hdc);
2372 HDC (*pDevOpenDC) (HAB hab, LONG lType, PCSZ pszToken, LONG lCount,
2373 PDEVOPENDATA pdopData, HDC hdcComp);
2374 BOOL (*pDevQueryCaps) (HDC hdc, LONG lStart, LONG lCount, PLONG alArray);
2381 Perl_croak_nocontext("Usage: OS2::DevCap()");
2383 /* Device Capabilities Data Buffer (10 extra w.r.t. Warp 4.5) */
2384 LONG si[CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1];
2385 int i = 0, j = 0, how = DevCap_dc;
2387 DEVOPENSTRUC doStruc= {0L, (PSZ)"DISPLAY", NULL, 0L, 0L, 0L, 0L, 0L, 0L};
2388 ULONG rc1 = NO_ERROR;
2390 static volatile int devcap_loaded;
2392 if (!devcap_loaded) {
2393 *(PFN*)&pWinOpenWindowDC = loadByOrdinal(ORD_WinOpenWindowDC, 0);
2394 *(PFN*)&pDevOpenDC = loadByOrdinal(ORD_DevOpenDC, 0);
2395 *(PFN*)&pDevCloseDC = loadByOrdinal(ORD_DevCloseDC, 0);
2396 *(PFN*)&pDevQueryCaps = loadByOrdinal(ORD_DevQueryCaps, 0);
2402 if (!items) { /* Get device contents from PM */
2403 hScreenDC = pDevOpenDC(perl_hab_GET(), OD_MEMORY, (PSZ)"*", 0,
2404 (PDEVOPENDATA)&doStruc, NULLHANDLE);
2405 if (CheckWinError(hScreenDC))
2406 croak_with_os2error("DevOpenDC() failed");
2407 } else if (how == DevCap_dc)
2408 hScreenDC = (HDC)SvIV(ST(0));
2409 else { /* DevCap_hwnd */
2411 Perl_croak(aTHX_ "Getting a window's device context without a message queue would lock PM");
2412 hwnd = (HWND)SvIV(ST(0));
2413 hScreenDC = pWinOpenWindowDC(hwnd); /* No need to DevCloseDC() */
2414 if (CheckWinError(hScreenDC))
2415 croak_with_os2error("WinOpenWindowDC() failed");
2417 if (CheckWinError(pDevQueryCaps(hScreenDC,
2418 CAPS_FAMILY, /* W3 documented caps */
2419 CAPS_DEVICE_POLYSET_POINTS
2423 if (!items && CheckWinError(pDevCloseDC(hScreenDC)))
2424 Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc));
2426 Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed");
2427 EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1));
2428 while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) {
2429 ST(j) = sv_newmortal();
2430 sv_setpv(ST(j++), dc_fields[i]);
2431 ST(j) = sv_newmortal();
2432 sv_setiv(ST(j++), si[i]);
2436 XSRETURN(2 * (CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1));
2439 LONG (*pWinQuerySysValue) (HWND hwndDesktop, LONG iSysValue);
2440 BOOL (*pWinSetSysValue) (HWND hwndDesktop, LONG iSysValue, LONG lValue);
2442 const char * const sv_keys[] = {
2494 "DESKTOPWORKAREAYTOP",
2495 "DESKTOPWORKAREAYBOTTOM",
2496 "DESKTOPWORKAREAXRIGHT",
2497 "DESKTOPWORKAREAXLEFT",
2507 "MENUROLLDOWNDELAY",
2510 "TASKLISTMOUSEACCESS",
2540 "PRINTSCREEN", /* 97, the last one on one of the DDK header */
2552 /* In recent DDK the limit is 108 */
2555 XS(XS_OS2_SysValues)
2559 Perl_croak_nocontext("Usage: OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP)");
2561 int i = 0, j = 0, which = -1;
2562 HWND hwnd = HWND_DESKTOP;
2563 static volatile int sv_loaded;
2567 *(PFN*)&pWinQuerySysValue = loadByOrdinal(ORD_WinQuerySysValue, 0);
2572 hwnd = (HWND)SvIV(ST(1));
2574 which = (int)SvIV(ST(0));
2576 EXTEND(SP,2*C_ARRAY_LENGTH(sv_keys));
2577 while (i < C_ARRAY_LENGTH(sv_keys)) {
2579 RETVAL = pWinQuerySysValue(hwnd, i);
2581 && !(sv_keys[i][0] >= '0' && sv_keys[i][0] <= '9'
2582 && i <= SV_PRINTSCREEN) ) {
2585 if (i > SV_PRINTSCREEN)
2586 break; /* May be not present on older systems */
2587 croak_with_os2error("SysValues():");
2591 ST(j) = sv_newmortal();
2592 sv_setpv(ST(j++), sv_keys[i]);
2593 ST(j) = sv_newmortal();
2594 sv_setiv(ST(j++), RETVAL);
2602 RETVAL = pWinQuerySysValue(hwnd, which);
2606 croak_with_os2error("SysValues():");
2608 XSprePUSH; PUSHi((IV)RETVAL);
2613 XS(XS_OS2_SysValues_set)
2616 if (items < 2 || items > 3)
2617 Perl_croak_nocontext("Usage: OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP)");
2619 int which = (int)SvIV(ST(0));
2620 LONG val = (LONG)SvIV(ST(1));
2621 HWND hwnd = HWND_DESKTOP;
2622 static volatile int svs_loaded;
2625 *(PFN*)&pWinSetSysValue = loadByOrdinal(ORD_WinSetSysValue, 0);
2630 hwnd = (HWND)SvIV(ST(2));
2631 if (CheckWinError(pWinSetSysValue(hwnd, which, val)))
2632 croak_with_os2error("SysValues_set()");
2637 #define QSV_MAX_WARP3 QSV_MAX_COMP_LENGTH
2639 static const char * const si_fields[] = {
2641 "MAX_TEXT_SESSIONS",
2645 "DYN_PRI_VARIATION",
2663 "FOREGROUND_FS_SESSION",
2664 "FOREGROUND_PROCESS", /* Warp 3 toolkit defines up to this */
2669 "VIRTUALADDRESSLIMIT",
2670 "INT10ENABLED", /* From $TOOLKIT-ddk\DDK\video\rel\os2c\include\base\os2\bsedos.h */
2677 Perl_croak_nocontext("Usage: OS2::SysInfo()");
2679 /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
2680 ULONG si[C_ARRAY_LENGTH(si_fields) + 10];
2681 APIRET rc = NO_ERROR; /* Return code */
2682 int i = 0, j = 0, last = QSV_MAX_WARP3;
2684 if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */
2685 last, /* info for Warp 3 */
2688 croak_with_os2error("DosQuerySysInfo() failed");
2689 while (last++ <= C_ARRAY_LENGTH(si)) {
2690 if (CheckOSError(DosQuerySysInfo(last, last, /* One entry only */
2693 if (Perl_rc != ERROR_INVALID_PARAMETER)
2694 croak_with_os2error("DosQuerySysInfo() failed");
2701 ST(j) = sv_newmortal();
2702 sv_setpv(ST(j++), si_fields[i]);
2703 ST(j) = sv_newmortal();
2704 sv_setiv(ST(j++), si[i]);
2711 XS(XS_OS2_SysInfoFor)
2714 int count = (items == 2 ? (int)SvIV(ST(1)) : 1);
2716 if (items < 1 || items > 2)
2717 Perl_croak_nocontext("Usage: OS2::SysInfoFor(id[,count])");
2719 /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
2720 ULONG si[C_ARRAY_LENGTH(si_fields) + 10];
2721 APIRET rc = NO_ERROR; /* Return code */
2723 int start = (int)SvIV(ST(0));
2725 if (count > C_ARRAY_LENGTH(si) || count <= 0)
2726 Perl_croak(aTHX_ "unexpected count %d for OS2::SysInfoFor()", count);
2727 if (CheckOSError(DosQuerySysInfo(start,
2731 croak_with_os2error("DosQuerySysInfo() failed");
2734 ST(i) = sv_newmortal();
2735 sv_setiv(ST(i), si[i]);
2742 XS(XS_OS2_BootDrive)
2746 Perl_croak_nocontext("Usage: OS2::BootDrive()");
2748 ULONG si[1] = {0}; /* System Information Data Buffer */
2749 APIRET rc = NO_ERROR; /* Return code */
2753 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
2754 (PVOID)si, sizeof(si))))
2755 croak_with_os2error("DosQuerySysInfo() failed");
2756 c = 'a' - 1 + si[0];
2757 sv_setpvn(TARG, &c, 1);
2758 XSprePUSH; PUSHTARG;
2766 if (items > 2) /* Defaults as for WinAlarm(ERROR) */
2767 Perl_croak_nocontext("Usage: OS2::Beep(freq = 440, ms = 100)");
2769 ULONG freq = (items > 0 ? (ULONG)SvUV(ST(0)) : 440);
2770 ULONG ms = (items > 1 ? (ULONG)SvUV(ST(1)) : 100);
2773 if (CheckOSError(DosBeep(freq, ms)))
2774 croak_with_os2error("SysValues_set()");
2785 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
2787 bool serve = SvOK(ST(0));
2788 unsigned long pmq = perl_hmq_GET(serve);
2791 XSprePUSH; PUSHi((IV)pmq);
2796 XS(XS_OS2_UnMorphPM)
2800 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
2802 bool serve = SvOK(ST(0));
2804 perl_hmq_UNSET(serve);
2809 XS(XS_OS2_Serve_Messages)
2813 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
2815 bool force = SvOK(ST(0));
2816 unsigned long cnt = Perl_Serve_Messages(force);
2819 XSprePUSH; PUSHi((IV)cnt);
2824 XS(XS_OS2_Process_Messages)
2827 if (items < 1 || items > 2)
2828 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
2830 bool force = SvOK(ST(0));
2838 (void)SvIV(sv); /* Force SvIVX */
2840 Perl_croak_nocontext("Can't upgrade count to IV");
2842 cnt = Perl_Process_Messages(force, &cntr);
2845 cnt = Perl_Process_Messages(force, NULL);
2847 XSprePUSH; PUSHi((IV)cnt);
2852 XS(XS_Cwd_current_drive)
2856 Perl_croak_nocontext("Usage: Cwd::current_drive()");
2861 RETVAL = current_drive();
2862 sv_setpvn(TARG, (char *)&RETVAL, 1);
2863 XSprePUSH; PUSHTARG;
2868 XS(XS_Cwd_sys_chdir)
2872 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
2875 char * path = (char *)SvPV(ST(0),n_a);
2878 RETVAL = sys_chdir(path);
2879 ST(0) = boolSV(RETVAL);
2880 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2885 XS(XS_Cwd_change_drive)
2889 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
2892 char d = (char)*SvPV(ST(0),n_a);
2895 RETVAL = change_drive(d);
2896 ST(0) = boolSV(RETVAL);
2897 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2902 XS(XS_Cwd_sys_is_absolute)
2906 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
2909 char * path = (char *)SvPV(ST(0),n_a);
2912 RETVAL = sys_is_absolute(path);
2913 ST(0) = boolSV(RETVAL);
2914 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2919 XS(XS_Cwd_sys_is_rooted)
2923 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
2926 char * path = (char *)SvPV(ST(0),n_a);
2929 RETVAL = sys_is_rooted(path);
2930 ST(0) = boolSV(RETVAL);
2931 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2936 XS(XS_Cwd_sys_is_relative)
2940 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
2943 char * path = (char *)SvPV(ST(0),n_a);
2946 RETVAL = sys_is_relative(path);
2947 ST(0) = boolSV(RETVAL);
2948 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2957 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
2962 /* Can't use TARG, since tainting behaves differently */
2963 RETVAL = _getcwd2(p, MAXPATHLEN);
2964 ST(0) = sv_newmortal();
2965 sv_setpv(ST(0), RETVAL);
2966 #ifndef INCOMPLETE_TAINTS
2967 SvTAINTED_on(ST(0));
2973 XS(XS_Cwd_sys_abspath)
2977 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path = '.', dir = NULL)");
2980 char * path = items ? (char *)SvPV(ST(0),n_a) : ".";
2981 char * dir, *s, *t, *e;
2990 dir = (char *)SvPV(ST(1),n_a);
2992 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
2996 if (_abspath(p, path, MAXPATHLEN) == 0) {
3002 /* Absolute with drive: */
3003 if ( sys_is_absolute(path) ) {
3004 if (_abspath(p, path, MAXPATHLEN) == 0) {
3009 } else if (path[0] == '/' || path[0] == '\\') {
3010 /* Rooted, but maybe on different drive. */
3011 if (isALPHA(dir[0]) && dir[1] == ':' ) {
3012 char p1[MAXPATHLEN];
3014 /* Need to prepend the drive. */
3017 Copy(path, p1 + 2, strlen(path) + 1, char);
3019 if (_abspath(p, p1, MAXPATHLEN) == 0) {
3024 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3030 /* Either path is relative, or starts with a drive letter. */
3031 /* If the path starts with a drive letter, then dir is
3033 a/b) it is absolute/x:relative on the same drive.
3034 c) path is on current drive, and dir is rooted
3035 In all the cases it is safe to drop the drive part
3037 if ( !sys_is_relative(path) ) {
3038 if ( ( ( sys_is_absolute(dir)
3039 || (isALPHA(dir[0]) && dir[1] == ':'
3040 && strnicmp(dir, path,1) == 0))
3041 && strnicmp(dir, path,1) == 0)
3042 || ( !(isALPHA(dir[0]) && dir[1] == ':')
3043 && toupper(path[0]) == current_drive())) {
3045 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3046 RETVAL = p; goto done;
3048 RETVAL = NULL; goto done;
3052 /* Need to prepend the absolute path of dir. */
3053 char p1[MAXPATHLEN];
3055 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
3058 if (p1[ l - 1 ] != '/') {
3062 Copy(path, p1 + l, strlen(path) + 1, char);
3063 if (_abspath(p, p1, MAXPATHLEN) == 0) {
3077 /* Backslashes are already converted to slashes. */
3078 /* Remove trailing slashes */
3080 while (l > 0 && RETVAL[l-1] == '/')
3082 ST(0) = sv_newmortal();
3083 sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
3084 /* Remove duplicate slashes, skipping the first three, which
3085 may be parts of a server-based path */
3086 s = t = 3 + SvPV_force(sv, n_a);
3088 /* Do not worry about multibyte chars here, this would contradict the
3089 eventual UTFization, and currently most other places break too... */
3091 if (s[0] == t[-1] && s[0] == '/')
3092 s++; /* Skip duplicate / */
3098 SvCUR_set(sv, t - SvPVX(sv));
3100 #ifndef INCOMPLETE_TAINTS
3102 SvTAINTED_on(ST(0));
3107 typedef APIRET (*PELP)(PSZ path, ULONG type);
3109 /* Kernels after 2000/09/15 understand this too: */
3110 #ifndef LIBPATHSTRICT
3111 # define LIBPATHSTRICT 3
3115 ExtLIBPATH(ULONG ord, PSZ path, IV type)
3118 PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */
3123 what = BEGIN_LIBPATH;
3125 what = LIBPATHSTRICT;
3126 return (*(PELP)f)(path, what);
3129 #define extLibpath(to,type) \
3130 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
3132 #define extLibpath_set(p,type) \
3133 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
3135 XS(XS_Cwd_extLibpath)
3138 if (items < 0 || items > 1)
3139 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
3153 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
3154 RETVAL = extLibpath(to, type);
3155 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
3156 Perl_croak_nocontext("panic Cwd::extLibpath parameter");
3157 sv_setpv(TARG, RETVAL);
3158 XSprePUSH; PUSHTARG;
3163 XS(XS_Cwd_extLibpath_set)
3166 if (items < 1 || items > 2)
3167 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
3170 char * s = (char *)SvPV(ST(0),n_a);
3181 RETVAL = extLibpath_set(s, type);
3182 ST(0) = boolSV(RETVAL);
3183 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3188 /* Input: Address, BufLen
3190 DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3191 ULONG * Offset, ULONG Address);
3194 DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
3195 (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3196 ULONG * Offset, ULONG Address),
3197 (hmod, obj, BufLen, Buf, Offset, Address))
3199 enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full,
3200 mod_name_C_function = 0x100, mod_name_HMODULE = 0x200};
3203 module_name_at(void *pp, enum module_name_how how)
3206 char buf[MAXPATHLEN];
3209 ULONG obj, offset, rc, addr = (ULONG)pp;
3211 if (how & mod_name_HMODULE) {
3212 if ((how & ~mod_name_HMODULE) == mod_name_shortname)
3213 Perl_croak(aTHX_ "Can't get short module name from a handle");
3215 how &= ~mod_name_HMODULE;
3216 } else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr))
3217 return &PL_sv_undef;
3218 if (how == mod_name_handle)
3219 return newSVuv(mod);
3221 if ( how != mod_name_shortname
3222 && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
3223 return &PL_sv_undef;
3229 return newSVpv(buf, 0);
3233 module_name_of_cv(SV *cv, enum module_name_how how)
3235 if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
3238 if (how & mod_name_C_function)
3239 return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function);
3240 else if (how & mod_name_HMODULE)
3241 return module_name_at((void*)SvIV(cv), how);
3242 Perl_croak(aTHX_ "Not an XSUB reference");
3244 return module_name_at(CvXSUB(SvRV(cv)), how);
3247 /* Find module name to which *this* subroutine is compiled */
3248 #define module_name(how) module_name_at(&module_name_at, how)
3254 Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
3260 how = mod_name_full;
3262 how = (int)SvIV(ST(0));
3265 RETVAL = module_name(how);
3267 RETVAL = module_name_of_cv(ST(1), how);
3274 DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo,
3275 (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum),
3276 (r1, r2, buf, szbuf, fnum))
3278 XS(XS_OS2__headerInfo)
3281 if (items > 4 || items < 2)
3282 Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])");
3284 ULONG req = (ULONG)SvIV(ST(0));
3285 STRLEN size = (STRLEN)SvIV(ST(1)), n_a;
3286 ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0);
3287 ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0);
3290 Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size);
3291 ST(0) = newSVpvn("",0);
3292 SvGROW(ST(0), size + 1);
3295 if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req))
3296 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3297 req, size, handle, offset, os2error(Perl_rc));
3298 SvCUR_set(ST(0), size);
3304 #define DQHI_QUERYLIBPATHSIZE 4
3305 #define DQHI_QUERYLIBPATH 5
3311 Perl_croak(aTHX_ "Usage: OS2::libPath()");
3316 if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size),
3317 DQHI_QUERYLIBPATHSIZE))
3318 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3319 DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0,
3321 ST(0) = newSVpvn("",0);
3322 SvGROW(ST(0), size + 1);
3325 /* We should be careful: apparently, this entry point does not
3326 pay attention to the size argument, so may overwrite
3328 if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size,
3330 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3331 DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc));
3332 SvCUR_set(ST(0), size);
3338 #define get_control87() _control87(0,0)
3339 #define set_control87 _control87
3341 XS(XS_OS2__control87)
3345 Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
3347 unsigned new = (unsigned)SvIV(ST(0));
3348 unsigned mask = (unsigned)SvIV(ST(1));
3352 RETVAL = _control87(new, mask);
3353 XSprePUSH; PUSHi((IV)RETVAL);
3363 if (items < 0 || items > 1)
3364 Perl_croak(aTHX_ "Usage: OS2::mytype([which])");
3366 which = (int)SvIV(ST(0));
3373 RETVAL = os2_mytype; /* Reset after fork */
3376 RETVAL = os2_mytype_ini; /* Before any fork */
3379 RETVAL = Perl_os2_initial_mode; /* Before first morphing */
3382 RETVAL = my_type(); /* Morphed type */
3385 Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which);
3387 XSprePUSH; PUSHi((IV)RETVAL);
3393 XS(XS_OS2_mytype_set)
3399 type = (int)SvIV(ST(0));
3401 Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)");
3407 XS(XS_OS2_get_control87)
3411 Perl_croak(aTHX_ "Usage: OS2::get_control87()");
3416 RETVAL = get_control87();
3417 XSprePUSH; PUSHi((IV)RETVAL);
3423 XS(XS_OS2_set_control87)
3426 if (items < 0 || items > 2)
3427 Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
3437 new = (unsigned)SvIV(ST(0));
3443 mask = (unsigned)SvIV(ST(1));
3446 RETVAL = set_control87(new, mask);
3447 XSprePUSH; PUSHi((IV)RETVAL);
3452 XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */
3455 if (items < 0 || items > 1)
3456 Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)");
3465 delta = (LONG)SvIV(ST(0));
3467 if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL)))
3468 croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error");
3469 XSprePUSH; PUSHu((UV)RETVAL);
3477 char *file = __FILE__;
3481 if (_emx_env & 0x200) { /* OS/2 */
3482 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
3483 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
3484 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
3486 newXS("OS2::Error", XS_OS2_Error, file);
3487 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
3488 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
3489 newXSproto("OS2::DevCap", XS_OS2_DevCap, file, ";$$");
3490 newXSproto("OS2::SysInfoFor", XS_OS2_SysInfoFor, file, "$;$");
3491 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
3492 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
3493 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
3494 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
3495 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
3496 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
3497 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
3498 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
3499 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
3500 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
3501 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
3502 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
3503 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
3504 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
3505 newXS("OS2::replaceModule", XS_OS2_replaceModule, file);
3506 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
3507 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
3508 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
3509 newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
3510 newXSproto("OS2::mytype", XS_OS2_mytype, file, ";$");
3511 newXSproto("OS2::mytype_set", XS_OS2_mytype_set, file, "$");
3512 newXSproto("OS2::_headerInfo", XS_OS2__headerInfo, file, "$$;$$");
3513 newXSproto("OS2::libPath", XS_OS2_libPath, file, "");
3514 newXSproto("OS2::Timer", XS_OS2_Timer, file, "");
3515 newXSproto("OS2::incrMaxFHandles", XS_OS2_incrMaxFHandles, file, ";$");
3516 newXSproto("OS2::SysValues", XS_OS2_SysValues, file, ";$$");
3517 newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$");
3518 newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$");
3519 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
3522 sv_setiv(GvSV(gv), 1);
3524 gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
3526 sv_setiv(GvSV(gv), exe_is_aout());
3527 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
3529 sv_setiv(GvSV(gv), _emx_rev);
3530 sv_setpv(GvSV(gv), _emx_vprt);
3532 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
3534 sv_setiv(GvSV(gv), _emx_env);
3535 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
3537 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
3538 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
3540 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
3545 extern void _emx_init(void*);
3547 static void jmp_out_of_atexit(void);
3549 #define FORCE_EMX_INIT_CONTRACT_ARGV 1
3550 #define FORCE_EMX_INIT_INSTALL_ATEXIT 2
3553 my_emx_init(void *layout) {
3554 static volatile void *old_esp = 0; /* Cannot be on stack! */
3556 /* Can't just call emx_init(), since it moves the stack pointer */
3557 /* It also busts a lot of registers, so be extra careful */
3565 "popf\n" : : "r" (layout), "m" (old_esp) );
3568 struct layout_table_t {
3589 static ULONG osv_res; /* Cannot be on stack! */
3591 /* Can't just call __os_version(), since it does not follow C
3592 calling convention: it busts a lot of registers, so be extra careful */
3595 "call ___os_version\n"
3598 "popf\n" : "=m" (osv_res) );
3604 force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
3606 /* Calling emx_init() will bust the top of stack: it installs an
3607 exception handler and puts argv data there. */
3608 char *oldarg, *oldenv;
3609 void *oldstackend, *oldstack;
3612 ULONG rc, error = 0, out;
3614 static struct layout_table_t layout_table;
3616 char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
3618 EXCEPTIONREGISTRATIONRECORD xreg;
3622 layout_table.os2_dll = (ULONG)&os2_dll_fake;
3623 layout_table.flags = 0x02000002; /* flags: application, OMF */
3625 DosGetInfoBlocks(&tib, &pib);
3626 oldarg = pib->pib_pchcmd;
3627 oldenv = pib->pib_pchenv;
3628 oldstack = tib->tib_pstack;
3629 oldstackend = tib->tib_pstacklimit;
3631 /* Minimize the damage to the stack via reducing the size of argv. */
3632 if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
3633 pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */
3634 pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */
3637 newstack = alloca(sizeof(*newstack));
3638 /* Emulate the stack probe */
3639 s = ((char*)newstack) + sizeof(*newstack);
3640 while (s > (char*)newstack) {
3645 /* Reassigning stack is documented to work */
3646 tib->tib_pstack = (void*)newstack;
3647 tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
3649 /* Can't just call emx_init(), since it moves the stack pointer */
3650 my_emx_init((void*)&layout_table);
3652 /* Remove the exception handler, cannot use it - too low on the stack.
3653 Check whether it is inside the new stack. */
3655 if (tib->tib_pexchain >= tib->tib_pstacklimit
3656 || tib->tib_pexchain < tib->tib_pstack) {
3659 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
3660 (unsigned long)tib->tib_pstack,
3661 (unsigned long)tib->tib_pexchain,
3662 (unsigned long)tib->tib_pstacklimit);
3665 if (tib->tib_pexchain != &(newstack->xreg)) {
3666 sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
3667 (unsigned long)tib->tib_pexchain,
3668 (unsigned long)&(newstack->xreg));
3670 rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
3672 sprintf(buf + strlen(buf),
3673 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
3676 /* ExceptionRecords should be on stack, in a correct order. Sigh... */
3677 preg->prev_structure = 0;
3678 preg->ExceptionHandler = _emx_exception;
3679 rc = DosSetExceptionHandler(preg);
3681 sprintf(buf + strlen(buf),
3682 "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
3683 DosWrite(2, buf, strlen(buf), &out);
3684 emx_exception_init = 1; /* Do it around spawn*() calls */
3687 emx_exception_init = 1; /* Do it around spawn*() calls */
3690 /* Restore the damage */
3691 pib->pib_pchcmd = oldarg;
3692 pib->pib_pchcmd = oldenv;
3693 tib->tib_pstacklimit = oldstackend;
3694 tib->tib_pstack = oldstack;
3695 emx_runtime_init = 1;
3697 DosWrite(2, buf, strlen(buf), &out);
3703 jmp_out_of_atexit(void)
3705 if (longjmp_at_exit)
3706 longjmp(at_exit_buf, 1);
3709 extern void _CRT_term(void);
3712 Perl_OS2_term(void **p, int exitstatus, int flags)
3714 if (!emx_runtime_secondary)
3717 /* The principal executable is not running the same CRTL, so there
3718 is nobody to shutdown *this* CRTL except us... */
3719 if (flags & FORCE_EMX_DEINIT_EXIT) {
3720 if (p && !emx_exception_init)
3721 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
3722 /* Do not run the executable's CRTL's termination routines */
3723 exit(exitstatus); /* Run at-exit, flush buffers, etc */
3725 /* Run at-exit list, and jump out at the end */
3726 if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
3727 longjmp_at_exit = 1;
3728 exit(exitstatus); /* The first pass through "if" */
3731 /* Get here if we managed to jump out of exit(), or did not run atexit. */
3732 longjmp_at_exit = 0; /* Maybe exit() is called again? */
3733 #if 0 /* _atexit_n is not exported */
3734 if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
3735 _atexit_n = 0; /* Remove the atexit() handlers */
3737 /* Will segfault on program termination if we leave this dangling... */
3738 if (p && !emx_exception_init)
3739 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
3740 /* Typically there is no need to do this, done from _DLL_InitTerm() */
3741 if (flags & FORCE_EMX_DEINIT_CRT_TERM)
3742 _CRT_term(); /* Flush buffers, etc. */
3743 /* Now it is a good time to call exit() in the caller's CRTL... */
3746 #include <emx/startup.h>
3748 extern ULONG __os_version(); /* See system.doc */
3751 check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
3753 ULONG v_crt, v_emx, count = 0, rc, rc1, maybe_inited = 0;
3754 static HMTX hmtx_emx_init = NULLHANDLE;
3755 static int emx_init_done = 0;
3757 /* If _environ is not set, this code sits in a DLL which
3758 uses a CRT DLL which not compatible with the executable's
3759 CRT library. Some parts of the DLL are not initialized.
3761 if (_environ != NULL)
3762 return; /* Properly initialized */
3764 /* It is not DOS, so we may use OS/2 API now */
3765 /* Some data we manipulate is static; protect ourselves from
3766 calling the same API from a different thread. */
3767 DosEnterMustComplete(&count);
3769 rc1 = DosEnterCritSec();
3771 rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/
3776 hmtx_emx_init = NULLHANDLE;
3778 if (rc1 == NO_ERROR)
3780 DosExitMustComplete(&count);
3782 while (maybe_inited) { /* Other thread did or is doing the same now */
3785 rc = DosRequestMutexSem(hmtx_emx_init,
3786 (ULONG) SEM_INDEFINITE_WAIT); /* Timeout (none) */
3787 if (rc == ERROR_INTERRUPT)
3789 if (rc != NO_ERROR) {
3794 "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc);
3795 DosWrite(2, buf, strlen(buf), &out);
3798 DosReleaseMutexSem(hmtx_emx_init);
3802 /* If the executable does not use EMX.DLL, EMX.DLL is not completely
3803 initialized either. Uninitialized EMX.DLL returns 0 in the low
3804 nibble of __os_version(). */
3805 v_emx = my_os_version();
3807 /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
3808 (=>_CRT_init=>_entry2) via a call to __os_version(), then
3809 reset when the EXE initialization code calls _text=>_init=>_entry2.
3810 The first time they are wrongly set to 0; the second time the
3811 EXE initialization code had already called emx_init=>initialize1
3812 which correctly set version_major, version_minor used by
3814 v_crt = (_osmajor | _osminor);
3816 if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */
3817 force_init_emx_runtime( preg,
3818 FORCE_EMX_INIT_CONTRACT_ARGV
3819 | FORCE_EMX_INIT_INSTALL_ATEXIT );
3820 emx_wasnt_initialized = 1;
3821 /* Update CRTL data basing on now-valid EMX runtime data */
3822 if (!v_crt) { /* The only wrong data are the versions. */
3823 v_emx = my_os_version(); /* *Now* it works */
3824 *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
3825 *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
3828 emx_runtime_secondary = 1;
3829 /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
3830 atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */
3832 if (env == NULL) { /* Fetch from the process info block */
3838 DosGetInfoBlocks(&tib, &pib);
3839 e = pib->pib_pchenv;
3840 while (*e) { /* Get count */
3842 e = e + strlen(e) + 1;
3844 New(1307, env, c + 1, char*);
3846 e = pib->pib_pchenv;
3849 e = e + strlen(e) + 1;
3853 _environ = _org_environ = env;
3856 DosReleaseMutexSem(hmtx_emx_init);
3859 #define ENTRY_POINT 0x10000
3864 struct layout_table_t *layout;
3865 if (emx_wasnt_initialized)
3867 /* Now we know that the principal executable is an EMX application
3868 - unless somebody did already play with delayed initialization... */
3869 /* With EMX applications to determine whether it is AOUT one needs
3870 to examine the start of the executable to find "layout" */
3871 if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */
3872 || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */
3873 || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */
3874 || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */
3875 return 0; /* ! EMX executable */
3877 Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
3878 return !(layout->flags & 2);
3882 Perl_OS2_init(char **env)
3884 Perl_OS2_init3(env, 0, 0);
3888 Perl_OS2_init3(char **env, void **preg, int flags)
3892 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
3895 check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
3898 OS2_Perl_data.xs_init = &Xs_OS2_init;
3899 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
3900 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
3901 strcpy(PL_sh_path, SH_PATH);
3902 PL_sh_path[0] = shell[0];
3903 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
3904 int l = strlen(shell), i;
3905 if (shell[l-1] == '/' || shell[l-1] == '\\') {
3908 New(1304, PL_sh_path, l + 8, char);
3909 strncpy(PL_sh_path, shell, l);
3910 strcpy(PL_sh_path + l, "/sh.exe");
3911 for (i = 0; i < l; i++) {
3912 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
3915 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
3916 MUTEX_INIT(&start_thread_mutex);
3917 MUTEX_INIT(&perlos2_state_mutex);
3919 os2_mytype = my_type(); /* Do it before morphing. Needed? */
3920 os2_mytype_ini = os2_mytype;
3921 Perl_os2_initial_mode = -1; /* Uninit */
3922 /* Some DLLs reset FP flags on load. We may have been linked with them */
3923 _control87(MCW_EM, MCW_EM);
3930 my_tmpnam (char *str)
3932 char *p = getenv("TMP"), *tpath;
3934 if (!p) p = getenv("TEMP");
3935 tpath = tempnam(p, "pltmp");
3949 if (s.st_mode & S_IWOTH) {
3952 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
3958 /* EMX flavors do not tolerate trailing slashes. t/op/mkdir.t has many
3959 trailing slashes, so we need to support this as well. */
3962 my_rmdir (__const__ char *s)
3966 STRLEN l = strlen(s);
3969 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
3971 New(1305, buf, l + 1, char);
3973 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
3987 my_mkdir (__const__ char *s, long perm)
3991 STRLEN l = strlen(s);
3994 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
3996 New(1305, buf, l + 1, char);
3998 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
4003 rc = mkdir(s, perm);
4011 /* This code was contributed by Rocco Caputo. */
4013 my_flock(int handle, int o)
4015 FILELOCK rNull, rFull;
4016 ULONG timeout, handle_type, flag_word;
4018 int blocking, shared;
4019 static int use_my_flock = -1;
4021 if (use_my_flock == -1) {
4022 MUTEX_LOCK(&perlos2_state_mutex);
4023 if (use_my_flock == -1) {
4024 char *s = getenv("USE_PERL_FLOCK");
4026 use_my_flock = atoi(s);
4030 MUTEX_UNLOCK(&perlos2_state_mutex);
4032 if (!(_emx_env & 0x200) || !use_my_flock)
4033 return flock(handle, o); /* Delegate to EMX. */
4035 /* is this a file? */
4036 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
4037 (handle_type & 0xFF))
4042 /* set lock/unlock ranges */
4043 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
4044 rFull.lRange = 0x7FFFFFFF;
4045 /* set timeout for blocking */
4046 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
4047 /* shared or exclusive? */
4048 shared = (o & LOCK_SH) ? 1 : 0;
4049 /* do not block the unlock */
4050 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
4051 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
4056 case ERROR_INVALID_HANDLE:
4059 case ERROR_SHARING_BUFFER_EXCEEDED:
4062 case ERROR_LOCK_VIOLATION:
4063 break; /* not an error */
4064 case ERROR_INVALID_PARAMETER:
4065 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
4066 case ERROR_READ_LOCKS_NOT_SUPPORTED:
4069 case ERROR_INTERRUPT:
4077 /* lock may block */
4078 if (o & (LOCK_SH | LOCK_EX)) {
4079 /* for blocking operations */
4093 case ERROR_INVALID_HANDLE:
4096 case ERROR_SHARING_BUFFER_EXCEEDED:
4099 case ERROR_LOCK_VIOLATION:
4101 errno = EWOULDBLOCK;
4105 case ERROR_INVALID_PARAMETER:
4106 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
4107 case ERROR_READ_LOCKS_NOT_SUPPORTED:
4110 case ERROR_INTERRUPT:
4117 /* give away timeslice */
4129 if (_my_pwent == -1) {
4130 char *s = getenv("USE_PERL_PWENT");
4132 _my_pwent = atoi(s);
4146 if (!use_my_pwent()) {
4147 setpwent(); /* Delegate to EMX. */
4156 if (!use_my_pwent()) {
4157 endpwent(); /* Delegate to EMX. */
4165 if (!use_my_pwent())
4166 return getpwent(); /* Delegate to EMX. */
4168 return 0; /* Return one entry only */
4187 return 0; /* Return one entry only */
4194 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
4195 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
4197 static struct passwd *
4198 passw_wrap(struct passwd *p)
4202 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
4205 s = getenv("PW_PASSWD");
4207 s = (char*)pw_p; /* Make match impossible */
4214 my_getpwuid (uid_t id)
4216 return passw_wrap(getpwuid(id));
4220 my_getpwnam (__const__ char *n)
4222 return passw_wrap(getpwnam(n));
4226 gcvt_os2 (double value, int digits, char *buffer)
4228 double absv = value > 0 ? value : -value;
4229 /* EMX implementation is lousy between 0.1 and 0.0001 (uses exponents below
4230 0.1), 1-digit stuff is ok below 0.001; multi-digit below 0.0001. */
4234 buggy = (absv < 1000 && (absv >= 10 || (absv > 1 && floor(absv) != absv)));
4239 sprintf(pat, "%%.%dg", digits);
4240 sprintf(buffer, pat, value);
4243 return gcvt (value, digits, buffer);
4247 int fork_with_resources()
4249 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
4251 void *ctx = PERL_GET_CONTEXT;
4253 unsigned fpflag = _control87(0,0);
4256 if (rc == 0) { /* child */
4257 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
4258 ALLOC_THREAD_KEY; /* Acquire the thread-local memory */
4259 PERL_SET_CONTEXT(ctx); /* Reinit the thread-local memory */
4262 { /* Reload loaded-on-demand DLLs */
4263 struct dll_handle_t *dlls = dll_handles;
4265 while (dlls->modname) {
4266 char dllname[260], fail[260];
4269 if (!dlls->handle) { /* Was not loaded */
4273 /* It was loaded in the parent. We need to reload it. */
4275 rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname);
4277 Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx",
4278 dlls->modname, (int)dlls->handle, rc, rc);
4282 rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle);
4284 Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'",
4290 { /* Support message queue etc. */
4291 os2_mytype = my_type();
4292 /* Apparently, subprocesses (in particular, fork()) do not
4293 inherit the morphed state, so os2_mytype is the same as
4296 if (Perl_os2_initial_mode != -1
4297 && Perl_os2_initial_mode != os2_mytype) {
4302 (void)_obtain_Perl_HAB;
4303 if (Perl_hmq_refcnt) {
4306 Create_HMQ(Perl_hmq_servers != 0,
4307 "Cannot create a message queue on fork");
4310 /* We may have loaded some modules */
4311 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */