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 */
625 loadModule(const char *modname, int fail)
627 HMODULE h = (HMODULE)dlopen(modname, 0);
630 Perl_croak_nocontext("Error loading module '%s': %s",
635 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
644 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
645 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
648 return (pib->pib_ultype);
652 my_type_set(int type)
658 if (!(_emx_env & 0x200))
659 Perl_croak_nocontext("Can't set type on DOS"); /* not OS/2. */
660 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
661 croak_with_os2error("Error getting info blocks");
662 pib->pib_ultype = type;
666 loadByOrdinal(enum entries_ordinals ord, int fail)
668 if (sizeof(loadOrdinals)/sizeof(loadOrdinals[0]) != ORD_NENTRIES)
669 Perl_croak_nocontext(
670 "Wrong size of loadOrdinals array: expected %d, actual %d",
671 sizeof(loadOrdinals)/sizeof(loadOrdinals[0]), ORD_NENTRIES);
672 if (ExtFCN[ord] == NULL) {
676 if (!loadOrdinals[ord].dll->handle) {
677 if (loadOrdinals[ord].dll->requires_pm && my_type() < 2) { /* FS */
678 char *s = getenv("PERL_ASIF_PM");
680 if (!s || !atoi(s)) {
681 /* The module will not function well without PM.
682 The usual way to detect PM is the existence of the mutex
683 \SEM32\PMDRAG.SEM. */
686 if (CheckOSError(DosOpenMutexSem("\\SEM32\\PMDRAG.SEM",
688 Perl_croak_nocontext("Looks like we have no PM; will not load DLL %s without $ENV{PERL_ASIF_PM}",
689 loadOrdinals[ord].dll->modname);
690 DosCloseMutexSem(hMtx);
693 MUTEX_LOCK(&perlos2_state_mutex);
694 loadOrdinals[ord].dll->handle
695 = loadModule(loadOrdinals[ord].dll->modname, fail);
696 MUTEX_UNLOCK(&perlos2_state_mutex);
698 if (!loadOrdinals[ord].dll->handle)
699 return 0; /* Possible with FAIL==0 only */
700 if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle,
701 loadOrdinals[ord].entrypoint,
702 loadOrdinals[ord].entryname,&fcn))) {
703 char buf[20], *s = (char*)loadOrdinals[ord].entryname;
708 sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint);
709 Perl_croak_nocontext(
710 "This version of OS/2 does not support %s.%s",
711 loadOrdinals[ord].dll->modname, s);
715 if ((long)ExtFCN[ord] == -1)
716 Perl_croak_nocontext("panic queryaddr");
721 init_PMWIN_entries(void)
725 for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++)
726 ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1);
729 /*****************************************************/
730 /* socket forwarders without linking with tcpip DLLs */
732 DeclFuncByORD(struct hostent *, gethostent, ORD_GETHOSTENT, (void), ())
733 DeclFuncByORD(struct netent *, getnetent, ORD_GETNETENT, (void), ())
734 DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ())
735 DeclFuncByORD(struct servent *, getservent, ORD_GETSERVENT, (void), ())
737 DeclVoidFuncByORD(sethostent, ORD_SETHOSTENT, (int x), (x))
738 DeclVoidFuncByORD(setnetent, ORD_SETNETENT, (int x), (x))
739 DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x))
740 DeclVoidFuncByORD(setservent, ORD_SETSERVENT, (int x), (x))
742 DeclVoidFuncByORD(endhostent, ORD_ENDHOSTENT, (void), ())
743 DeclVoidFuncByORD(endnetent, ORD_ENDNETENT, (void), ())
744 DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ())
745 DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ())
748 static const signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
750 #define QSS_INI_BUFFER 1024
752 ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
755 get_sysinfo(ULONG pid, ULONG flags)
758 ULONG rc, buf_len = QSS_INI_BUFFER;
761 if (!pidtid_lookup) {
763 *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0);
765 if (pDosVerifyPidTid) { /* Warp3 or later */
766 /* Up to some fixpak QuerySysState() kills the system if a non-existent
768 if (CheckOSError(pDosVerifyPidTid(pid, 1)))
771 New(1322, pbuffer, buf_len, char);
772 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
773 rc = QuerySysState(flags, pid, pbuffer, buf_len);
774 while (rc == ERROR_BUFFER_OVERFLOW) {
775 Renew(pbuffer, buf_len *= 2, char);
776 rc = QuerySysState(flags, pid, pbuffer, buf_len);
783 psi = (PQTOPLEVEL)pbuffer;
784 if (psi && pid && pid != psi->procdata->pid) {
786 Perl_croak_nocontext("panic: wrong pid in sysinfo");
791 #define PRIO_ERR 0x1111
801 psi = get_sysinfo(pid, QSS_PROCESS);
804 prio = psi->procdata->threads->priority;
810 setpriority(int which, int pid, int val)
812 ULONG rc, prio = sys_prio(pid);
814 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
815 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
816 /* Do not change class. */
817 return CheckOSError(DosSetPriority((pid < 0)
818 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
820 (32 - val) % 32 - (prio & 0xFF),
823 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
824 /* Documentation claims one can change both class and basevalue,
825 * but I find it wrong. */
826 /* Change class, but since delta == 0 denotes absolute 0, correct. */
827 if (CheckOSError(DosSetPriority((pid < 0)
828 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
829 priors[(32 - val) >> 5] + 1,
833 if ( ((32 - val) % 32) == 0 ) return 0;
834 return CheckOSError(DosSetPriority((pid < 0)
835 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
844 getpriority(int which /* ignored */, int pid)
848 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
850 if (ret == PRIO_ERR) {
853 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
856 /*****************************************************************************/
862 spawn_sighandler(int sig)
864 /* Some programs do not arrange for the keyboard signals to be
865 delivered to them. We need to deliver the signal manually. */
866 /* We may get a signal only if
867 a) kid does not receive keyboard signal: deliver it;
868 b) kid already died, and we get a signal. We may only hope
869 that the pid number was not reused.
873 sig = SIGKILL; /* Try harder. */
874 kill(spawn_pid, sig);
879 result(pTHX_ int flag, int pid)
882 Signal_t (*ihand)(); /* place to save signal during system() */
883 Signal_t (*qhand)(); /* place to save signal during system() */
889 if (pid < 0 || flag != 0)
895 ihand = rsignal(SIGINT, &spawn_sighandler);
896 qhand = rsignal(SIGQUIT, &spawn_sighandler);
898 r = wait4pid(pid, &status, 0);
899 } while (r == -1 && errno == EINTR);
900 rsignal(SIGINT, ihand);
901 rsignal(SIGQUIT, qhand);
903 PL_statusvalue = (U16)status;
906 return status & 0xFFFF;
908 ihand = rsignal(SIGINT, SIG_IGN);
909 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
910 rsignal(SIGINT, ihand);
911 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
914 return PL_statusvalue;
928 file_type(char *path)
933 if (!(_emx_env & 0x200))
934 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
935 if (CheckOSError(DosQueryAppType(path, &apptype))) {
937 case ERROR_FILE_NOT_FOUND:
938 case ERROR_PATH_NOT_FOUND:
940 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
942 default: /* Found, but not an
943 executable, or some other
951 /* Spawn/exec a program, revert to shell if needed. */
952 /* global PL_Argv[] contains arguments. */
954 extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
955 EXCEPTIONREGISTRATIONRECORD *,
960 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
965 char const * args[4];
966 static const char * const fargs[4]
967 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
968 const char * const *argsp = fargs;
971 int new_stderr = -1, nostderr = 0;
979 if (really && !*(real_name = SvPV(really, n_a)))
983 if (strEQ(PL_Argv[0],"/bin/sh"))
984 PL_Argv[0] = PL_sh_path;
986 /* We should check PERL_SH* and PERLLIB_* as well? */
987 if (!really || pass >= 2)
988 real_name = PL_Argv[0];
989 if (real_name[0] != '/' && real_name[0] != '\\'
990 && !(real_name[0] && real_name[1] == ':'
991 && (real_name[2] == '/' || real_name[2] != '\\'))
992 ) /* will spawnvp use PATH? */
993 TAINT_ENV(); /* testing IFS here is overkill, probably */
997 if (_emx_env & 0x200) { /* OS/2. */
998 int type = file_type(real_name);
1000 if (type == -1) { /* Not found */
1005 else if (type == -2) { /* Not an EXE */
1010 else if (type == -3) { /* Is a directory? */
1011 /* Special-case this */
1013 int l = strlen(real_name);
1015 if (l + 5 <= sizeof tbuf) {
1016 strcpy(tbuf, real_name);
1017 strcpy(tbuf + l, ".exe");
1018 type = file_type(tbuf);
1028 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
1029 case FAPPTYP_WINDOWAPI:
1030 { /* Apparently, kids are started basing on startup type, not the morphed type */
1031 if (os2_mytype != 3) { /* not PM */
1032 if (flag == P_NOWAIT)
1034 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
1035 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d",
1040 case FAPPTYP_NOTWINDOWCOMPAT:
1042 if (os2_mytype != 0) { /* not full screen */
1043 if (flag == P_NOWAIT)
1045 else if ((flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
1046 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d",
1051 case FAPPTYP_NOTSPEC:
1052 /* Let the shell handle this... */
1054 buf = ""; /* Pacify a warning */
1055 file = 0; /* Pacify a warning */
1063 new_stderr = dup(2); /* Preserve stderr */
1064 if (new_stderr == -1) {
1072 fl_stderr = fcntl(2, F_GETFD);
1076 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
1080 rc = result(aTHX_ trueflag, spawnvp(flag,real_name,PL_Argv));
1082 if (execf == EXECF_TRUEEXEC)
1083 rc = execvp(real_name,PL_Argv);
1084 else if (execf == EXECF_EXEC)
1085 rc = spawnvp(trueflag | P_OVERLAY,real_name,PL_Argv);
1086 else if (execf == EXECF_SPAWN_NOWAIT)
1087 rc = spawnvp(flag,real_name,PL_Argv);
1088 else if (execf == EXECF_SYNC)
1089 rc = spawnvp(trueflag,real_name,PL_Argv);
1090 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
1091 rc = result(aTHX_ trueflag,
1092 spawnvp(flag,real_name,PL_Argv));
1094 if (rc < 0 && pass == 1) {
1096 if (real_name == PL_Argv[0]) {
1099 if (err == ENOENT || err == ENOEXEC) {
1100 /* No such file, or is a script. */
1101 /* Try adding script extensions to the file name, and
1103 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
1107 SV *scrsv = sv_2mortal(newSVpv(scr, 0));
1108 SV *bufsv = sv_newmortal();
1111 scr = SvPV(scrsv, n_a); /* free()ed later */
1113 file = PerlIO_open(scr, "r");
1118 buf = sv_gets(bufsv, file, 0 /* No append */);
1120 buf = ""; /* XXX Needed? */
1121 if (!buf[0]) { /* Empty... */
1123 /* Special case: maybe from -Zexe build, so
1124 there is an executable around (contrary to
1125 documentation, DosQueryAppType sometimes (?)
1126 does not append ".exe", so we could have
1127 reached this place). */
1128 sv_catpv(scrsv, ".exe");
1129 scr = SvPV(scrsv, n_a); /* Reload */
1130 if (PerlLIO_stat(scr,&PL_statbuf) >= 0
1131 && !S_ISDIR(PL_statbuf.st_mode)) { /* Found */
1135 } else { /* Restore */
1136 SvCUR_set(scrsv, SvCUR(scrsv) - 4);
1140 if (PerlIO_close(file) != 0) { /* Failure */
1142 if (ckWARN(WARN_EXEC))
1143 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
1144 scr, Strerror(errno));
1145 buf = ""; /* Not #! */
1148 if (buf[0] == '#') {
1151 } else if (buf[0] == 'e') {
1152 if (strnEQ(buf, "extproc", 7)
1155 } else if (buf[0] == 'E') {
1156 if (strnEQ(buf, "EXTPROC", 7)
1161 buf = ""; /* Not #! */
1169 /* Do better than pdksh: allow a few args,
1170 strip trailing whitespace. */
1180 while (*s && !isSPACE(*s))
1187 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"",
1188 s1 - buf, buf, scr);
1192 /* Can jump from far, buf/file invalid if force_shell: */
1196 const char *exec_args[2];
1199 || (!buf[0] && file)) { /* File without magic */
1200 /* In fact we tried all what pdksh would
1201 try. There is no point in calling
1202 pdksh, we may just emulate its logic. */
1203 char *shell = getenv("EXECSHELL");
1204 char *shell_opt = NULL;
1210 shell = getenv("OS2_SHELL");
1211 if (inicmd) { /* No spaces at start! */
1213 while (*s && !isSPACE(*s)) {
1215 inicmd = NULL; /* Cannot use */
1223 /* Dosish shells will choke on slashes
1224 in paths, fortunately, this is
1225 important for zeroth arg only. */
1232 /* If EXECSHELL is set, we do not set */
1235 shell = ((_emx_env & 0x200)
1237 : "c:/command.com");
1238 nargs = shell_opt ? 2 : 1; /* shell file args */
1239 exec_args[0] = shell;
1240 exec_args[1] = shell_opt;
1242 if (nargs == 2 && inicmd) {
1243 /* Use the original cmd line */
1244 /* XXXX This is good only until we refuse
1245 quoted arguments... */
1246 PL_Argv[0] = inicmd;
1247 PL_Argv[1] = Nullch;
1249 } else if (!buf[0] && inicmd) { /* No file */
1250 /* Start with the original cmdline. */
1251 /* XXXX This is good only until we refuse
1252 quoted arguments... */
1254 PL_Argv[0] = inicmd;
1255 PL_Argv[1] = Nullch;
1256 nargs = 2; /* shell -c */
1259 while (a[1]) /* Get to the end */
1261 a++; /* Copy finil NULL too */
1262 while (a >= PL_Argv) {
1263 *(a + nargs) = *a; /* PL_Argv was preallocated to be
1267 while (--nargs >= 0) /* XXXX Discard const... */
1268 PL_Argv[nargs] = (char*)argsp[nargs];
1269 /* Enable pathless exec if #! (as pdksh). */
1270 pass = (buf[0] == '#' ? 2 : 3);
1274 /* Not found: restore errno */
1277 } else if (errno == ENOEXEC) { /* Cannot transfer `real_name' via shell. */
1278 if (rc < 0 && ckWARN(WARN_EXEC))
1279 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s script `%s' with ARGV[0] being `%s'",
1280 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1281 ? "spawn" : "exec"),
1282 real_name, PL_Argv[0]);
1284 } else if (errno == ENOENT) { /* Cannot transfer `real_name' via shell. */
1285 if (rc < 0 && ckWARN(WARN_EXEC))
1286 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)",
1287 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1288 ? "spawn" : "exec"),
1289 real_name, PL_Argv[0]);
1292 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
1293 char *no_dir = strrchr(PL_Argv[0], '/');
1295 /* Do as pdksh port does: if not found with /, try without
1298 PL_Argv[0] = no_dir + 1;
1303 if (rc < 0 && ckWARN(WARN_EXEC))
1304 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n",
1305 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1306 ? "spawn" : "exec"),
1307 real_name, Strerror(errno));
1309 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
1310 && ((trueflag & 0xFF) == P_WAIT))
1314 if (new_stderr != -1) { /* How can we use error codes? */
1315 dup2(new_stderr, 2);
1317 fcntl(2, F_SETFD, fl_stderr);
1318 } else if (nostderr)
1323 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
1325 do_spawn3(pTHX_ char *cmd, int execf, int flag)
1329 char *shell, *copt, *news = NULL;
1330 int rc, seenspace = 0, mergestderr = 0;
1333 if ((shell = getenv("EMXSHELL")) != NULL)
1335 else if ((shell = getenv("SHELL")) != NULL)
1337 else if ((shell = getenv("COMSPEC")) != NULL)
1342 /* Consensus on perl5-porters is that it is _very_ important to
1343 have a shell which will not change between computers with the
1344 same architecture, to avoid "action on a distance".
1345 And to have simple build, this shell should be sh. */
1350 while (*cmd && isSPACE(*cmd))
1353 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
1354 STRLEN l = strlen(PL_sh_path);
1356 New(1302, news, strlen(cmd) - 7 + l + 1, char);
1357 strcpy(news, PL_sh_path);
1358 strcpy(news + l, cmd + 7);
1362 /* save an extra exec if possible */
1363 /* see if there are shell metacharacters in it */
1365 if (*cmd == '.' && isSPACE(cmd[1]))
1368 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1371 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
1375 for (s = cmd; *s; s++) {
1376 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
1377 if (*s == '\n' && s[1] == '\0') {
1380 } else if (*s == '\\' && !seenspace) {
1381 continue; /* Allow backslashes in names */
1382 } else if (*s == '>' && s >= cmd + 3
1383 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
1384 && isSPACE(s[-2]) ) {
1387 while (*t && isSPACE(*t))
1392 break; /* Allow 2>&1 as the last thing */
1395 /* We do not convert this to do_spawn_ve since shell
1396 should be smart enough to start itself gloriously. */
1398 if (execf == EXECF_TRUEEXEC)
1399 rc = execl(shell,shell,copt,cmd,(char*)0);
1400 else if (execf == EXECF_EXEC)
1401 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
1402 else if (execf == EXECF_SPAWN_NOWAIT)
1403 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
1404 else if (execf == EXECF_SPAWN_BYFLAG)
1405 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
1407 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
1408 if (execf == EXECF_SYNC)
1409 rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0);
1411 rc = result(aTHX_ P_WAIT,
1412 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
1413 if (rc < 0 && ckWARN(WARN_EXEC))
1414 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
1415 (execf == EXECF_SPAWN ? "spawn" : "exec"),
1416 shell, Strerror(errno));
1423 } else if (*s == ' ' || *s == '\t') {
1428 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
1429 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
1430 PL_Cmd = savepvn(cmd, s-cmd);
1432 for (s = PL_Cmd; *s;) {
1433 while (*s && isSPACE(*s)) s++;
1436 while (*s && !isSPACE(*s)) s++;
1442 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
1451 /* Array spawn/exec. */
1453 os2_aspawn4(pTHX_ SV *really, register SV **vmark, register SV **vsp, int execing)
1455 register SV **mark = (SV **)vmark;
1456 register SV **sp = (SV **)vsp;
1459 int flag = P_WAIT, flag_set = 0;
1463 New(1301,PL_Argv, sp - mark + 3, char*);
1466 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
1468 flag = SvIVx(*mark);
1473 while (++mark <= sp) {
1475 *a++ = SvPVx(*mark, n_a);
1481 if ( flag_set && (a == PL_Argv + 1)
1482 && !really && !execing ) { /* One arg? */
1483 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
1485 rc = do_spawn_ve(aTHX_ really, flag,
1486 (execing ? EXECF_EXEC : EXECF_SPAWN), NULL, 0);
1495 os2_do_aspawn(pTHX_ SV *really, register SV **vmark, register SV **vsp)
1497 return os2_aspawn4(aTHX_ really, vmark, vsp, 0);
1502 Perl_do_aexec(pTHX_ SV* really, SV** vmark, SV** vsp)
1504 return os2_aspawn4(aTHX_ really, vmark, vsp, 1);
1508 os2_do_spawn(pTHX_ char *cmd)
1510 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
1514 do_spawn_nowait(pTHX_ char *cmd)
1516 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1520 Perl_do_exec(pTHX_ char *cmd)
1522 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1527 os2exec(pTHX_ char *cmd)
1529 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1533 my_syspopen(pTHX_ char *cmd, char *mode)
1537 register I32 this, that, newfd;
1540 int fh_fl = 0; /* Pacify the warning */
1542 /* `this' is what we use in the parent, `that' in the child. */
1543 this = (*mode == 'w');
1547 taint_proper("Insecure %s%s", "EXEC");
1551 /* Now we need to spawn the child. */
1552 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1553 int new = dup(p[this]);
1560 newfd = dup(*mode == 'r'); /* Preserve std* */
1562 /* This cannot happen due to fh being bad after pipe(), since
1563 pipe() should have created fh 0 and 1 even if they were
1564 initially closed. But we closed p[this] before. */
1565 if (errno != EBADF) {
1572 fh_fl = fcntl(*mode == 'r', F_GETFD);
1573 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1574 dup2(p[that], *mode == 'r');
1577 /* Where is `this' and newfd now? */
1578 fcntl(p[this], F_SETFD, FD_CLOEXEC);
1580 fcntl(newfd, F_SETFD, FD_CLOEXEC);
1581 pid = do_spawn_nowait(aTHX_ cmd);
1583 close(*mode == 'r'); /* It was closed initially */
1584 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1585 dup2(newfd, *mode == 'r'); /* Return std* back. */
1587 fcntl(*mode == 'r', F_SETFD, fh_fl);
1589 fcntl(*mode == 'r', F_SETFD, fh_fl);
1590 if (p[that] == (*mode == 'r'))
1596 if (p[that] < p[this]) { /* Make fh as small as possible */
1597 dup2(p[this], p[that]);
1601 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1602 (void)SvUPGRADE(sv,SVt_IV);
1604 PL_forkprocess = pid;
1605 return PerlIO_fdopen(p[this], mode);
1607 #else /* USE_POPEN */
1613 res = popen(cmd, mode);
1615 char *shell = getenv("EMXSHELL");
1617 my_setenv("EMXSHELL", PL_sh_path);
1618 res = popen(cmd, mode);
1619 my_setenv("EMXSHELL", shell);
1621 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1622 (void)SvUPGRADE(sv,SVt_IV);
1623 SvIVX(sv) = -1; /* A cooky. */
1626 #endif /* USE_POPEN */
1630 /******************************************************************/
1636 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1642 /*******************************************************************/
1643 /* not implemented in EMX 0.9d */
1645 char * ctermid(char *s) { return 0; }
1647 #ifdef MYTTYNAME /* was not in emx0.9a */
1648 void * ttyname(x) { return 0; }
1651 /*****************************************************************************/
1652 /* not implemented in C Set++ */
1655 int setuid(x) { errno = EINVAL; return -1; }
1656 int setgid(x) { errno = EINVAL; return -1; }
1659 /*****************************************************************************/
1660 /* stat() hack for char/block device */
1664 enum os2_stat_extra { /* EMX 0.9d fix 4 defines up to 0100000 */
1665 os2_stat_archived = 0x1000000, /* 0100000000 */
1666 os2_stat_hidden = 0x2000000, /* 0200000000 */
1667 os2_stat_system = 0x4000000, /* 0400000000 */
1668 os2_stat_force = 0x8000000, /* Do not ignore flags on chmod */
1671 #define OS2_STAT_SPECIAL (os2_stat_system | os2_stat_archived | os2_stat_hidden)
1674 massage_os2_attr(struct stat *st)
1676 if ( ((st->st_mode & S_IFMT) != S_IFREG
1677 && (st->st_mode & S_IFMT) != S_IFDIR)
1678 || !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM)))
1681 if ( st->st_attr & FILE_ARCHIVED )
1682 st->st_mode |= (os2_stat_archived | os2_stat_force);
1683 if ( st->st_attr & FILE_HIDDEN )
1684 st->st_mode |= (os2_stat_hidden | os2_stat_force);
1685 if ( st->st_attr & FILE_SYSTEM )
1686 st->st_mode |= (os2_stat_system | os2_stat_force);
1689 /* First attempt used DosQueryFSAttach which crashed the system when
1690 used with 5.001. Now just look for /dev/. */
1692 os2_stat(const char *name, struct stat *st)
1694 static int ino = SHRT_MAX;
1695 STRLEN l = strlen(name);
1697 if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0
1698 || ( stricmp(name + 5, "con") != 0
1699 && stricmp(name + 5, "tty") != 0
1700 && stricmp(name + 5, "nul") != 0
1701 && stricmp(name + 5, "null") != 0) ) {
1702 int s = stat(name, st);
1706 massage_os2_attr(st);
1710 memset(st, 0, sizeof *st);
1711 st->st_mode = S_IFCHR|0666;
1712 MUTEX_LOCK(&perlos2_state_mutex);
1713 st->st_ino = (ino-- & 0x7FFF);
1714 MUTEX_UNLOCK(&perlos2_state_mutex);
1720 os2_fstat(int handle, struct stat *st)
1722 int s = fstat(handle, st);
1726 massage_os2_attr(st);
1732 os2_chmod (const char *name, int pmode) /* Modelled after EMX src/lib/io/chmod.c */
1736 if (!(pmode & os2_stat_force))
1737 return chmod(name, pmode);
1739 attr = __chmod (name, 0, 0); /* Get attributes */
1742 if (pmode & S_IWRITE)
1743 attr &= ~FILE_READONLY;
1745 attr |= FILE_READONLY;
1747 attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM);
1749 if ( pmode & os2_stat_archived )
1750 attr |= FILE_ARCHIVED;
1751 if ( pmode & os2_stat_hidden )
1752 attr |= FILE_HIDDEN;
1753 if ( pmode & os2_stat_system )
1754 attr |= FILE_SYSTEM;
1756 rc = __chmod (name, 1, attr);
1757 if (rc >= 0) rc = 0;
1763 #ifdef USE_PERL_SBRK
1765 /* SBRK() emulation, mostly moved to malloc.c. */
1768 sys_alloc(int size) {
1770 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1772 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1775 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1779 #endif /* USE_PERL_SBRK */
1783 const char *tmppath = TMPPATH1;
1788 char *p = getenv("TMP"), *tpath;
1791 if (!p) p = getenv("TEMP");
1792 if (!p) p = getenv("TMPDIR");
1795 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1799 strcpy(tpath + len + 1, TMPPATH1);
1806 XS(XS_File__Copy_syscopy)
1809 if (items < 2 || items > 3)
1810 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1813 char * src = (char *)SvPV(ST(0),n_a);
1814 char * dst = (char *)SvPV(ST(1),n_a);
1822 flag = (unsigned long)SvIV(ST(2));
1825 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1826 XSprePUSH; PUSHi((IV)RETVAL);
1831 #define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */
1832 #include "patchlevel.h"
1833 #undef PERL_PATCHLEVEL_H_IMPLICIT
1836 mod2fname(pTHX_ SV *sv)
1838 int pos = 6, len, avlen;
1839 unsigned int sum = 0;
1843 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1845 if (SvTYPE(sv) != SVt_PVAV)
1846 Perl_croak_nocontext("Not array reference given to mod2fname");
1848 avlen = av_len((AV*)sv);
1850 Perl_croak_nocontext("Empty array reference given to mod2fname");
1852 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1853 strncpy(fname, s, 8);
1855 if (len < 6) pos = len;
1857 sum = 33 * sum + *(s++); /* Checksumming first chars to
1858 * get the capitalization into c.s. */
1861 while (avlen >= 0) {
1862 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1864 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1868 /* We always load modules as *specific* DLLs, and with the full name.
1869 When loading a specific DLL by its full name, one cannot get a
1870 different DLL, even if a DLL with the same basename is loaded already.
1871 Thus there is no need to include the version into the mangling scheme. */
1873 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
1875 # ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
1876 # define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
1878 sum += COMPATIBLE_VERSION_SUM;
1880 fname[pos] = 'A' + (sum % 26);
1881 fname[pos + 1] = 'A' + (sum / 26 % 26);
1882 fname[pos + 2] = '\0';
1883 return (char *)fname;
1886 XS(XS_DynaLoader_mod2fname)
1890 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1896 RETVAL = mod2fname(aTHX_ sv);
1897 sv_setpv(TARG, RETVAL);
1898 XSprePUSH; PUSHTARG;
1909 int number = SvTRUE(get_sv("OS2::nsyserror", TRUE));
1911 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1915 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
1916 s = os2error_buf + strlen(os2error_buf);
1919 if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf),
1920 rc, "OSO001.MSG", &len)) {
1924 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
1925 s = os2error_buf + strlen(os2error_buf);
1928 case PMERR_INVALID_HWND:
1929 name = "PMERR_INVALID_HWND";
1931 case PMERR_INVALID_HMQ:
1932 name = "PMERR_INVALID_HMQ";
1934 case PMERR_CALL_FROM_WRONG_THREAD:
1935 name = "PMERR_CALL_FROM_WRONG_THREAD";
1937 case PMERR_NO_MSG_QUEUE:
1938 name = "PMERR_NO_MSG_QUEUE";
1940 case PMERR_NOT_IN_A_PM_SESSION:
1941 name = "PMERR_NOT_IN_A_PM_SESSION";
1944 sprintf(s, "%s%s[No description found in OSO001.MSG]",
1945 name, (*name ? "=" : ""));
1948 if (len && s[len - 1] == '\n')
1950 if (len && s[len - 1] == '\r')
1952 if (len && s[len - 1] == '.')
1954 if (len >= 10 && number && strnEQ(s, os2error_buf, 7)
1955 && s[7] == ':' && s[8] == ' ')
1956 /* Some messages start with SYSdddd:, some not */
1957 Move(s + 9, s, (len -= 9) + 1, char);
1959 return os2error_buf;
1969 CroakWinError(int die, char *name)
1972 if (die && Perl_rc) {
1975 Perl_croak(aTHX_ "%s: %s", (name ? name : "Win* API call"), os2error(Perl_rc));
1982 char buf[300], *p, *o = PL_origargv[0], ok = 1;
1984 if (_execname(buf, sizeof buf) != 0)
1991 if (ok && *o != '/' && *o != '\\')
1993 } else if (ok && tolower(*o) != tolower(*p))
1998 if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */
1999 strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */
2013 perllib_mangle(char *s, unsigned int l)
2015 if (!newp && !notfound) {
2016 newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION)
2017 STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION)
2020 newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION)
2021 STRINGIFY(PERL_VERSION) "_PREFIX");
2023 newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX");
2025 newp = getenv("PERLLIB_PREFIX");
2030 while (*newp && !isSPACE(*newp) && *newp != ';') {
2031 newp++; oldl++; /* Skip digits. */
2033 while (*newp && (isSPACE(*newp) || *newp == ';')) {
2034 newp++; /* Skip whitespace. */
2036 newl = strlen(newp);
2037 if (newl == 0 || oldl == 0) {
2038 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
2040 strcpy(mangle_ret, newp);
2043 if (*s == '\\') *s = '/';
2056 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
2059 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
2060 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
2062 strcpy(mangle_ret + newl, s + oldl);
2067 Perl_hab_GET() /* Needed if perl.h cannot be included */
2069 return perl_hab_GET();
2073 Create_HMQ(int serve, char *message) /* Assumes morphing */
2075 unsigned fpflag = _control87(0,0);
2077 init_PMWIN_entries();
2078 /* 64 messages if before OS/2 3.0, ignored otherwise */
2079 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
2083 SAVEINT(rmq_cnt); /* Allow catch()ing. */
2085 _exit(188); /* Panic can try to create a window. */
2086 CroakWinError(1, message ? message : "Cannot create a message queue");
2089 (*PMWIN_entries.CancelShutdown)(Perl_hmq, !serve);
2090 /* We may have loaded some modules */
2091 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
2094 #define REGISTERMQ_WILL_SERVE 1
2095 #define REGISTERMQ_IMEDIATE_UNMORPH 2
2098 Perl_Register_MQ(int serve)
2100 if (Perl_hmq_refcnt <= 0) {
2104 Perl_hmq_refcnt = 0; /* Be extra safe */
2105 DosGetInfoBlocks(&tib, &pib);
2106 if (!Perl_morph_refcnt) {
2107 Perl_os2_initial_mode = pib->pib_ultype;
2108 /* Try morphing into a PM application. */
2109 if (pib->pib_ultype != 3) /* 2 is VIO */
2110 pib->pib_ultype = 3; /* 3 is PM */
2112 Create_HMQ(-1, /* We do CancelShutdown ourselves */
2113 "Cannot create a message queue, or morph to a PM application");
2114 if ((serve & REGISTERMQ_IMEDIATE_UNMORPH)) {
2115 if (!Perl_morph_refcnt && Perl_os2_initial_mode != 3)
2116 pib->pib_ultype = Perl_os2_initial_mode;
2119 if (serve & REGISTERMQ_WILL_SERVE) {
2120 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
2121 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
2122 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
2124 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
2125 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
2127 if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH))
2128 Perl_morph_refcnt++;
2133 Perl_Serve_Messages(int force)
2138 if (Perl_hmq_servers > 0 && !force)
2140 if (Perl_hmq_refcnt <= 0)
2141 Perl_croak_nocontext("No message queue");
2142 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
2144 if (msg.msg == WM_QUIT)
2145 Perl_croak_nocontext("QUITing...");
2146 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
2152 Perl_Process_Messages(int force, I32 *cntp)
2156 if (Perl_hmq_servers > 0 && !force)
2158 if (Perl_hmq_refcnt <= 0)
2159 Perl_croak_nocontext("No message queue");
2160 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
2163 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
2164 if (msg.msg == WM_DESTROY)
2166 if (msg.msg == WM_CREATE)
2169 Perl_croak_nocontext("QUITing...");
2173 Perl_Deregister_MQ(int serve)
2175 if (serve & REGISTERMQ_WILL_SERVE)
2178 if (--Perl_hmq_refcnt <= 0) {
2179 unsigned fpflag = _control87(0,0);
2181 init_PMWIN_entries(); /* To be extra safe */
2182 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
2184 /* We may have (un)loaded some modules */
2185 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
2186 } else if ((serve & REGISTERMQ_WILL_SERVE) && Perl_hmq_servers <= 0)
2187 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); /* Last server exited */
2188 if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH) && (--Perl_morph_refcnt <= 0)) {
2189 /* Try morphing back from a PM application. */
2193 DosGetInfoBlocks(&tib, &pib);
2194 if (pib->pib_ultype == 3) /* 3 is PM */
2195 pib->pib_ultype = Perl_os2_initial_mode;
2197 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
2202 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
2203 && ((path)[2] == '/' || (path)[2] == '\\'))
2204 #define sys_is_rooted _fnisabs
2205 #define sys_is_relative _fnisrel
2206 #define current_drive _getdrive
2208 #undef chdir /* Was _chdir2. */
2209 #define sys_chdir(p) (chdir(p) == 0)
2210 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
2216 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
2218 int arg1 = SvIV(ST(0));
2219 int arg2 = SvIV(ST(1));
2220 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
2221 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
2222 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
2225 if (CheckOSError(DosError(a)))
2226 Perl_croak_nocontext("DosError(%d) failed: %s", a, os2error(Perl_rc));
2227 ST(0) = sv_newmortal();
2228 if (DOS_harderr_state >= 0)
2229 sv_setiv(ST(0), DOS_harderr_state);
2230 DOS_harderr_state = RETVAL;
2235 XS(XS_OS2_Errors2Drive)
2239 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
2243 int suppress = SvOK(sv);
2244 char *s = suppress ? SvPV(sv, n_a) : NULL;
2245 char drive = (s ? *s : 0);
2248 if (suppress && !isALPHA(drive))
2249 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
2250 if (CheckOSError(DosSuppressPopUps((suppress
2251 ? SPU_ENABLESUPPRESSION
2252 : SPU_DISABLESUPPRESSION),
2254 Perl_croak_nocontext("DosSuppressPopUps(%c) failed: %s", drive,
2256 ST(0) = sv_newmortal();
2257 if (DOS_suppression_state > 0)
2258 sv_setpvn(ST(0), &DOS_suppression_state, 1);
2259 else if (DOS_suppression_state == 0)
2260 sv_setpvn(ST(0), "", 0);
2261 DOS_suppression_state = drive;
2266 ULONG (*pDosTmrQueryFreq) (PULONG);
2267 ULONG (*pDosTmrQueryTime) (unsigned long long *);
2273 unsigned long long count;
2277 Perl_croak_nocontext("Usage: OS2::Timer()");
2279 *(PFN*)&pDosTmrQueryFreq = loadByOrdinal(ORD_DosTmrQueryFreq, 0);
2280 *(PFN*)&pDosTmrQueryTime = loadByOrdinal(ORD_DosTmrQueryTime, 0);
2281 MUTEX_LOCK(&perlos2_state_mutex);
2283 if (CheckOSError(pDosTmrQueryFreq(&freq)))
2284 croak_with_os2error("DosTmrQueryFreq");
2285 MUTEX_UNLOCK(&perlos2_state_mutex);
2287 if (CheckOSError(pDosTmrQueryTime(&count)))
2288 croak_with_os2error("DosTmrQueryTime");
2292 XSprePUSH; PUSHn(((NV)count)/freq);
2297 static const char * const dc_fields[] = {
2306 "HORIZONTAL_RESOLUTION",
2307 "VERTICAL_RESOLUTION",
2311 "SMALL_CHAR_HEIGHT",
2315 "COLOR_TABLE_SUPPORT",
2317 "FOREGROUND_MIX_SUPPORT",
2318 "BACKGROUND_MIX_SUPPORT",
2319 "VIO_LOADABLE_FONTS",
2320 "WINDOW_BYTE_ALIGNMENT",
2328 "GRAPHICS_VECTOR_SUBSET",
2330 "ADDITIONAL_GRAPHICS",
2333 "GRAPHICS_CHAR_WIDTH",
2334 "GRAPHICS_CHAR_HEIGHT",
2335 "HORIZONTAL_FONT_RES",
2336 "VERTICAL_FONT_RES",
2339 "DEVICE_POLYSET_POINTS",
2343 DevCap_dc, DevCap_hwnd
2346 HDC (*pWinOpenWindowDC) (HWND hwnd);
2347 HMF (*pDevCloseDC) (HDC hdc);
2348 HDC (*pDevOpenDC) (HAB hab, LONG lType, PCSZ pszToken, LONG lCount,
2349 PDEVOPENDATA pdopData, HDC hdcComp);
2350 BOOL (*pDevQueryCaps) (HDC hdc, LONG lStart, LONG lCount, PLONG alArray);
2357 Perl_croak_nocontext("Usage: OS2::DevCap()");
2359 /* Device Capabilities Data Buffer (10 extra w.r.t. Warp 4.5) */
2360 LONG si[CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1];
2361 int i = 0, j = 0, how = DevCap_dc;
2363 DEVOPENSTRUC doStruc= {0L, (PSZ)"DISPLAY", NULL, 0L, 0L, 0L, 0L, 0L, 0L};
2364 ULONG rc1 = NO_ERROR;
2366 static volatile int devcap_loaded;
2368 if (!devcap_loaded) {
2369 *(PFN*)&pWinOpenWindowDC = loadByOrdinal(ORD_WinOpenWindowDC, 0);
2370 *(PFN*)&pDevOpenDC = loadByOrdinal(ORD_DevOpenDC, 0);
2371 *(PFN*)&pDevCloseDC = loadByOrdinal(ORD_DevCloseDC, 0);
2372 *(PFN*)&pDevQueryCaps = loadByOrdinal(ORD_DevQueryCaps, 0);
2378 if (!items) { /* Get device contents from PM */
2379 hScreenDC = pDevOpenDC(perl_hab_GET(), OD_MEMORY, (PSZ)"*", 0,
2380 (PDEVOPENDATA)&doStruc, NULLHANDLE);
2381 if (CheckWinError(hScreenDC))
2382 croak_with_os2error("DevOpenDC() failed");
2383 } else if (how == DevCap_dc)
2384 hScreenDC = (HDC)SvIV(ST(0));
2385 else { /* DevCap_hwnd */
2387 Perl_croak(aTHX_ "Getting a window's device context without a message queue would lock PM");
2388 hwnd = (HWND)SvIV(ST(0));
2389 hScreenDC = pWinOpenWindowDC(hwnd); /* No need to DevCloseDC() */
2390 if (CheckWinError(hScreenDC))
2391 croak_with_os2error("WinOpenWindowDC() failed");
2393 if (CheckWinError(pDevQueryCaps(hScreenDC,
2394 CAPS_FAMILY, /* W3 documented caps */
2395 CAPS_DEVICE_POLYSET_POINTS
2399 if (!items && CheckWinError(pDevCloseDC(hScreenDC)))
2400 Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc));
2402 Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed");
2403 EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1));
2404 while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) {
2405 ST(j) = sv_newmortal();
2406 sv_setpv(ST(j++), dc_fields[i]);
2407 ST(j) = sv_newmortal();
2408 sv_setiv(ST(j++), si[i]);
2412 XSRETURN(2 * (CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1));
2415 LONG (*pWinQuerySysValue) (HWND hwndDesktop, LONG iSysValue);
2416 BOOL (*pWinSetSysValue) (HWND hwndDesktop, LONG iSysValue, LONG lValue);
2418 const char * const sv_keys[] = {
2470 "DESKTOPWORKAREAYTOP",
2471 "DESKTOPWORKAREAYBOTTOM",
2472 "DESKTOPWORKAREAXRIGHT",
2473 "DESKTOPWORKAREAXLEFT",
2483 "MENUROLLDOWNDELAY",
2486 "TASKLISTMOUSEACCESS",
2516 "PRINTSCREEN", /* 97, the last one on one of the DDK header */
2528 /* In recent DDK the limit is 108 */
2531 XS(XS_OS2_SysValues)
2535 Perl_croak_nocontext("Usage: OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP)");
2537 int i = 0, j = 0, which = -1;
2538 HWND hwnd = HWND_DESKTOP;
2539 static volatile int sv_loaded;
2543 *(PFN*)&pWinQuerySysValue = loadByOrdinal(ORD_WinQuerySysValue, 0);
2548 hwnd = (HWND)SvIV(ST(1));
2550 which = (int)SvIV(ST(0));
2552 EXTEND(SP,2*C_ARRAY_LENGTH(sv_keys));
2553 while (i < C_ARRAY_LENGTH(sv_keys)) {
2555 RETVAL = pWinQuerySysValue(hwnd, i);
2557 && !(sv_keys[i][0] >= '0' && sv_keys[i][0] <= '9'
2558 && i <= SV_PRINTSCREEN) ) {
2561 if (i > SV_PRINTSCREEN)
2562 break; /* May be not present on older systems */
2563 croak_with_os2error("SysValues():");
2567 ST(j) = sv_newmortal();
2568 sv_setpv(ST(j++), sv_keys[i]);
2569 ST(j) = sv_newmortal();
2570 sv_setiv(ST(j++), RETVAL);
2578 RETVAL = pWinQuerySysValue(hwnd, which);
2582 croak_with_os2error("SysValues():");
2584 XSprePUSH; PUSHi((IV)RETVAL);
2589 XS(XS_OS2_SysValues_set)
2592 if (items < 2 || items > 3)
2593 Perl_croak_nocontext("Usage: OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP)");
2595 int which = (int)SvIV(ST(0));
2596 LONG val = (LONG)SvIV(ST(1));
2597 HWND hwnd = HWND_DESKTOP;
2598 static volatile int svs_loaded;
2601 *(PFN*)&pWinSetSysValue = loadByOrdinal(ORD_WinSetSysValue, 0);
2606 hwnd = (HWND)SvIV(ST(2));
2607 if (CheckWinError(pWinSetSysValue(hwnd, which, val)))
2608 croak_with_os2error("SysValues_set()");
2613 #define QSV_MAX_WARP3 QSV_MAX_COMP_LENGTH
2615 static const char * const si_fields[] = {
2617 "MAX_TEXT_SESSIONS",
2621 "DYN_PRI_VARIATION",
2639 "FOREGROUND_FS_SESSION",
2640 "FOREGROUND_PROCESS", /* Warp 3 toolkit defines up to this */
2645 "VIRTUALADDRESSLIMIT",
2646 "INT10ENABLED", /* From $TOOLKIT-ddk\DDK\video\rel\os2c\include\base\os2\bsedos.h */
2653 Perl_croak_nocontext("Usage: OS2::SysInfo()");
2655 /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
2656 ULONG si[C_ARRAY_LENGTH(si_fields) + 10];
2657 APIRET rc = NO_ERROR; /* Return code */
2658 int i = 0, j = 0, last = QSV_MAX_WARP3;
2660 if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */
2661 last, /* info for Warp 3 */
2664 croak_with_os2error("DosQuerySysInfo() failed");
2665 while (last++ <= C_ARRAY_LENGTH(si)) {
2666 if (CheckOSError(DosQuerySysInfo(last, last, /* One entry only */
2669 if (Perl_rc != ERROR_INVALID_PARAMETER)
2670 croak_with_os2error("DosQuerySysInfo() failed");
2677 ST(j) = sv_newmortal();
2678 sv_setpv(ST(j++), si_fields[i]);
2679 ST(j) = sv_newmortal();
2680 sv_setiv(ST(j++), si[i]);
2687 XS(XS_OS2_SysInfoFor)
2690 int count = (items == 2 ? (int)SvIV(ST(1)) : 1);
2692 if (items < 1 || items > 2)
2693 Perl_croak_nocontext("Usage: OS2::SysInfoFor(id[,count])");
2695 /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
2696 ULONG si[C_ARRAY_LENGTH(si_fields) + 10];
2697 APIRET rc = NO_ERROR; /* Return code */
2699 int start = (int)SvIV(ST(0));
2701 if (count > C_ARRAY_LENGTH(si) || count <= 0)
2702 Perl_croak(aTHX_ "unexpected count %d for OS2::SysInfoFor()", count);
2703 if (CheckOSError(DosQuerySysInfo(start,
2707 croak_with_os2error("DosQuerySysInfo() failed");
2710 ST(i) = sv_newmortal();
2711 sv_setiv(ST(i), si[i]);
2718 XS(XS_OS2_BootDrive)
2722 Perl_croak_nocontext("Usage: OS2::BootDrive()");
2724 ULONG si[1] = {0}; /* System Information Data Buffer */
2725 APIRET rc = NO_ERROR; /* Return code */
2729 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
2730 (PVOID)si, sizeof(si))))
2731 croak_with_os2error("DosQuerySysInfo() failed");
2732 c = 'a' - 1 + si[0];
2733 sv_setpvn(TARG, &c, 1);
2734 XSprePUSH; PUSHTARG;
2742 if (items > 2) /* Defaults as for WinAlarm(ERROR) */
2743 Perl_croak_nocontext("Usage: OS2::Beep(freq = 440, ms = 100)");
2745 ULONG freq = (items > 0 ? (ULONG)SvUV(ST(0)) : 440);
2746 ULONG ms = (items > 1 ? (ULONG)SvUV(ST(1)) : 100);
2749 if (CheckOSError(DosBeep(freq, ms)))
2750 croak_with_os2error("SysValues_set()");
2761 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
2763 bool serve = SvOK(ST(0));
2764 unsigned long pmq = perl_hmq_GET(serve);
2767 XSprePUSH; PUSHi((IV)pmq);
2772 XS(XS_OS2_UnMorphPM)
2776 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
2778 bool serve = SvOK(ST(0));
2780 perl_hmq_UNSET(serve);
2785 XS(XS_OS2_Serve_Messages)
2789 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
2791 bool force = SvOK(ST(0));
2792 unsigned long cnt = Perl_Serve_Messages(force);
2795 XSprePUSH; PUSHi((IV)cnt);
2800 XS(XS_OS2_Process_Messages)
2803 if (items < 1 || items > 2)
2804 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
2806 bool force = SvOK(ST(0));
2814 (void)SvIV(sv); /* Force SvIVX */
2816 Perl_croak_nocontext("Can't upgrade count to IV");
2818 cnt = Perl_Process_Messages(force, &cntr);
2821 cnt = Perl_Process_Messages(force, NULL);
2823 XSprePUSH; PUSHi((IV)cnt);
2828 XS(XS_Cwd_current_drive)
2832 Perl_croak_nocontext("Usage: Cwd::current_drive()");
2837 RETVAL = current_drive();
2838 sv_setpvn(TARG, (char *)&RETVAL, 1);
2839 XSprePUSH; PUSHTARG;
2844 XS(XS_Cwd_sys_chdir)
2848 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
2851 char * path = (char *)SvPV(ST(0),n_a);
2854 RETVAL = sys_chdir(path);
2855 ST(0) = boolSV(RETVAL);
2856 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2861 XS(XS_Cwd_change_drive)
2865 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
2868 char d = (char)*SvPV(ST(0),n_a);
2871 RETVAL = change_drive(d);
2872 ST(0) = boolSV(RETVAL);
2873 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2878 XS(XS_Cwd_sys_is_absolute)
2882 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
2885 char * path = (char *)SvPV(ST(0),n_a);
2888 RETVAL = sys_is_absolute(path);
2889 ST(0) = boolSV(RETVAL);
2890 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2895 XS(XS_Cwd_sys_is_rooted)
2899 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
2902 char * path = (char *)SvPV(ST(0),n_a);
2905 RETVAL = sys_is_rooted(path);
2906 ST(0) = boolSV(RETVAL);
2907 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2912 XS(XS_Cwd_sys_is_relative)
2916 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
2919 char * path = (char *)SvPV(ST(0),n_a);
2922 RETVAL = sys_is_relative(path);
2923 ST(0) = boolSV(RETVAL);
2924 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2933 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
2938 /* Can't use TARG, since tainting behaves differently */
2939 RETVAL = _getcwd2(p, MAXPATHLEN);
2940 ST(0) = sv_newmortal();
2941 sv_setpv(ST(0), RETVAL);
2942 #ifndef INCOMPLETE_TAINTS
2943 SvTAINTED_on(ST(0));
2949 XS(XS_Cwd_sys_abspath)
2952 if (items < 1 || items > 2)
2953 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
2956 char * path = (char *)SvPV(ST(0),n_a);
2957 char * dir, *s, *t, *e;
2966 dir = (char *)SvPV(ST(1),n_a);
2968 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
2972 if (_abspath(p, path, MAXPATHLEN) == 0) {
2978 /* Absolute with drive: */
2979 if ( sys_is_absolute(path) ) {
2980 if (_abspath(p, path, MAXPATHLEN) == 0) {
2985 } else if (path[0] == '/' || path[0] == '\\') {
2986 /* Rooted, but maybe on different drive. */
2987 if (isALPHA(dir[0]) && dir[1] == ':' ) {
2988 char p1[MAXPATHLEN];
2990 /* Need to prepend the drive. */
2993 Copy(path, p1 + 2, strlen(path) + 1, char);
2995 if (_abspath(p, p1, MAXPATHLEN) == 0) {
3000 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3006 /* Either path is relative, or starts with a drive letter. */
3007 /* If the path starts with a drive letter, then dir is
3009 a/b) it is absolute/x:relative on the same drive.
3010 c) path is on current drive, and dir is rooted
3011 In all the cases it is safe to drop the drive part
3013 if ( !sys_is_relative(path) ) {
3014 if ( ( ( sys_is_absolute(dir)
3015 || (isALPHA(dir[0]) && dir[1] == ':'
3016 && strnicmp(dir, path,1) == 0))
3017 && strnicmp(dir, path,1) == 0)
3018 || ( !(isALPHA(dir[0]) && dir[1] == ':')
3019 && toupper(path[0]) == current_drive())) {
3021 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3022 RETVAL = p; goto done;
3024 RETVAL = NULL; goto done;
3028 /* Need to prepend the absolute path of dir. */
3029 char p1[MAXPATHLEN];
3031 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
3034 if (p1[ l - 1 ] != '/') {
3038 Copy(path, p1 + l, strlen(path) + 1, char);
3039 if (_abspath(p, p1, MAXPATHLEN) == 0) {
3053 /* Backslashes are already converted to slashes. */
3054 /* Remove trailing slashes */
3056 while (l > 0 && RETVAL[l-1] == '/')
3058 ST(0) = sv_newmortal();
3059 sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
3060 /* Remove duplicate slashes, skipping the first three, which
3061 may be parts of a server-based path */
3062 s = t = 3 + SvPV_force(sv, n_a);
3064 /* Do not worry about multibyte chars here, this would contradict the
3065 eventual UTFization, and currently most other places break too... */
3067 if (s[0] == t[-1] && s[0] == '/')
3068 s++; /* Skip duplicate / */
3074 SvCUR_set(sv, t - SvPVX(sv));
3079 typedef APIRET (*PELP)(PSZ path, ULONG type);
3081 /* Kernels after 2000/09/15 understand this too: */
3082 #ifndef LIBPATHSTRICT
3083 # define LIBPATHSTRICT 3
3087 ExtLIBPATH(ULONG ord, PSZ path, IV type)
3090 PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */
3095 what = BEGIN_LIBPATH;
3097 what = LIBPATHSTRICT;
3098 return (*(PELP)f)(path, what);
3101 #define extLibpath(to,type) \
3102 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
3104 #define extLibpath_set(p,type) \
3105 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
3107 XS(XS_Cwd_extLibpath)
3110 if (items < 0 || items > 1)
3111 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
3125 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
3126 RETVAL = extLibpath(to, type);
3127 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
3128 Perl_croak_nocontext("panic Cwd::extLibpath parameter");
3129 sv_setpv(TARG, RETVAL);
3130 XSprePUSH; PUSHTARG;
3135 XS(XS_Cwd_extLibpath_set)
3138 if (items < 1 || items > 2)
3139 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
3142 char * s = (char *)SvPV(ST(0),n_a);
3153 RETVAL = extLibpath_set(s, type);
3154 ST(0) = boolSV(RETVAL);
3155 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3160 /* Input: Address, BufLen
3162 DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3163 ULONG * Offset, ULONG Address);
3166 DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
3167 (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3168 ULONG * Offset, ULONG Address),
3169 (hmod, obj, BufLen, Buf, Offset, Address))
3171 enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full,
3172 mod_name_C_function = 0x100, mod_name_HMODULE = 0x200};
3175 module_name_at(void *pp, enum module_name_how how)
3178 char buf[MAXPATHLEN];
3181 ULONG obj, offset, rc, addr = (ULONG)pp;
3183 if (how & mod_name_HMODULE) {
3184 if ((how & ~mod_name_HMODULE) == mod_name_shortname)
3185 Perl_croak(aTHX_ "Can't get short module name from a handle");
3187 how &= ~mod_name_HMODULE;
3188 } else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr))
3189 return &PL_sv_undef;
3190 if (how == mod_name_handle)
3191 return newSVuv(mod);
3193 if ( how != mod_name_shortname
3194 && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
3195 return &PL_sv_undef;
3201 return newSVpv(buf, 0);
3205 module_name_of_cv(SV *cv, enum module_name_how how)
3207 if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
3210 if (how & mod_name_C_function)
3211 return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function);
3212 else if (how & mod_name_HMODULE)
3213 return module_name_at((void*)SvIV(cv), how);
3214 Perl_croak(aTHX_ "Not an XSUB reference");
3216 return module_name_at(CvXSUB(SvRV(cv)), how);
3219 /* Find module name to which *this* subroutine is compiled */
3220 #define module_name(how) module_name_at(&module_name_at, how)
3226 Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
3232 how = mod_name_full;
3234 how = (int)SvIV(ST(0));
3237 RETVAL = module_name(how);
3239 RETVAL = module_name_of_cv(ST(1), how);
3246 DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo,
3247 (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum),
3248 (r1, r2, buf, szbuf, fnum))
3250 XS(XS_OS2__headerInfo)
3253 if (items > 4 || items < 2)
3254 Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])");
3256 ULONG req = (ULONG)SvIV(ST(0));
3257 STRLEN size = (STRLEN)SvIV(ST(1)), n_a;
3258 ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0);
3259 ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0);
3262 Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size);
3263 ST(0) = newSVpvn("",0);
3264 SvGROW(ST(0), size + 1);
3267 if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req))
3268 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3269 req, size, handle, offset, os2error(Perl_rc));
3270 SvCUR_set(ST(0), size);
3276 #define DQHI_QUERYLIBPATHSIZE 4
3277 #define DQHI_QUERYLIBPATH 5
3283 Perl_croak(aTHX_ "Usage: OS2::libPath()");
3288 if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size),
3289 DQHI_QUERYLIBPATHSIZE))
3290 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3291 DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0,
3293 ST(0) = newSVpvn("",0);
3294 SvGROW(ST(0), size + 1);
3297 /* We should be careful: apparently, this entry point does not
3298 pay attention to the size argument, so may overwrite
3300 if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size,
3302 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3303 DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc));
3304 SvCUR_set(ST(0), size);
3310 #define get_control87() _control87(0,0)
3311 #define set_control87 _control87
3313 XS(XS_OS2__control87)
3317 Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
3319 unsigned new = (unsigned)SvIV(ST(0));
3320 unsigned mask = (unsigned)SvIV(ST(1));
3324 RETVAL = _control87(new, mask);
3325 XSprePUSH; PUSHi((IV)RETVAL);
3335 if (items < 0 || items > 1)
3336 Perl_croak(aTHX_ "Usage: OS2::mytype([which])");
3338 which = (int)SvIV(ST(0));
3345 RETVAL = os2_mytype; /* Reset after fork */
3348 RETVAL = os2_mytype_ini; /* Before any fork */
3351 RETVAL = Perl_os2_initial_mode; /* Before first morphing */
3354 RETVAL = my_type(); /* Morphed type */
3357 Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which);
3359 XSprePUSH; PUSHi((IV)RETVAL);
3365 XS(XS_OS2_mytype_set)
3371 type = (int)SvIV(ST(0));
3373 Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)");
3379 XS(XS_OS2_get_control87)
3383 Perl_croak(aTHX_ "Usage: OS2::get_control87()");
3388 RETVAL = get_control87();
3389 XSprePUSH; PUSHi((IV)RETVAL);
3395 XS(XS_OS2_set_control87)
3398 if (items < 0 || items > 2)
3399 Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
3409 new = (unsigned)SvIV(ST(0));
3415 mask = (unsigned)SvIV(ST(1));
3418 RETVAL = set_control87(new, mask);
3419 XSprePUSH; PUSHi((IV)RETVAL);
3424 XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */
3427 if (items < 0 || items > 1)
3428 Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)");
3437 delta = (LONG)SvIV(ST(0));
3439 if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL)))
3440 croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error");
3441 XSprePUSH; PUSHu((UV)RETVAL);
3449 char *file = __FILE__;
3453 if (_emx_env & 0x200) { /* OS/2 */
3454 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
3455 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
3456 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
3458 newXS("OS2::Error", XS_OS2_Error, file);
3459 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
3460 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
3461 newXSproto("OS2::DevCap", XS_OS2_DevCap, file, ";$$");
3462 newXSproto("OS2::SysInfoFor", XS_OS2_SysInfoFor, file, "$;$");
3463 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
3464 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
3465 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
3466 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
3467 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
3468 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
3469 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
3470 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
3471 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
3472 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
3473 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
3474 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
3475 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
3476 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
3477 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
3478 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
3479 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
3480 newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
3481 newXSproto("OS2::mytype", XS_OS2_mytype, file, ";$");
3482 newXSproto("OS2::mytype_set", XS_OS2_mytype_set, file, "$");
3483 newXSproto("OS2::_headerInfo", XS_OS2__headerInfo, file, "$$;$$");
3484 newXSproto("OS2::libPath", XS_OS2_libPath, file, "");
3485 newXSproto("OS2::Timer", XS_OS2_Timer, file, "");
3486 newXSproto("OS2::incrMaxFHandles", XS_OS2_incrMaxFHandles, file, ";$");
3487 newXSproto("OS2::SysValues", XS_OS2_SysValues, file, ";$$");
3488 newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$");
3489 newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$");
3490 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
3493 sv_setiv(GvSV(gv), 1);
3495 gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
3497 sv_setiv(GvSV(gv), exe_is_aout());
3498 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
3500 sv_setiv(GvSV(gv), _emx_rev);
3501 sv_setpv(GvSV(gv), _emx_vprt);
3503 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
3505 sv_setiv(GvSV(gv), _emx_env);
3506 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
3508 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
3509 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
3511 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
3516 extern void _emx_init(void*);
3518 static void jmp_out_of_atexit(void);
3520 #define FORCE_EMX_INIT_CONTRACT_ARGV 1
3521 #define FORCE_EMX_INIT_INSTALL_ATEXIT 2
3524 my_emx_init(void *layout) {
3525 static volatile void *old_esp = 0; /* Cannot be on stack! */
3527 /* Can't just call emx_init(), since it moves the stack pointer */
3528 /* It also busts a lot of registers, so be extra careful */
3536 "popf\n" : : "r" (layout), "m" (old_esp) );
3539 struct layout_table_t {
3560 static ULONG osv_res; /* Cannot be on stack! */
3562 /* Can't just call __os_version(), since it does not follow C
3563 calling convention: it busts a lot of registers, so be extra careful */
3566 "call ___os_version\n"
3569 "popf\n" : "=m" (osv_res) );
3575 force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
3577 /* Calling emx_init() will bust the top of stack: it installs an
3578 exception handler and puts argv data there. */
3579 char *oldarg, *oldenv;
3580 void *oldstackend, *oldstack;
3583 ULONG rc, error = 0, out;
3585 static struct layout_table_t layout_table;
3587 char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
3589 EXCEPTIONREGISTRATIONRECORD xreg;
3593 layout_table.os2_dll = (ULONG)&os2_dll_fake;
3594 layout_table.flags = 0x02000002; /* flags: application, OMF */
3596 DosGetInfoBlocks(&tib, &pib);
3597 oldarg = pib->pib_pchcmd;
3598 oldenv = pib->pib_pchenv;
3599 oldstack = tib->tib_pstack;
3600 oldstackend = tib->tib_pstacklimit;
3602 /* Minimize the damage to the stack via reducing the size of argv. */
3603 if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
3604 pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */
3605 pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */
3608 newstack = alloca(sizeof(*newstack));
3609 /* Emulate the stack probe */
3610 s = ((char*)newstack) + sizeof(*newstack);
3611 while (s > (char*)newstack) {
3616 /* Reassigning stack is documented to work */
3617 tib->tib_pstack = (void*)newstack;
3618 tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
3620 /* Can't just call emx_init(), since it moves the stack pointer */
3621 my_emx_init((void*)&layout_table);
3623 /* Remove the exception handler, cannot use it - too low on the stack.
3624 Check whether it is inside the new stack. */
3626 if (tib->tib_pexchain >= tib->tib_pstacklimit
3627 || tib->tib_pexchain < tib->tib_pstack) {
3630 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
3631 (unsigned long)tib->tib_pstack,
3632 (unsigned long)tib->tib_pexchain,
3633 (unsigned long)tib->tib_pstacklimit);
3636 if (tib->tib_pexchain != &(newstack->xreg)) {
3637 sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
3638 (unsigned long)tib->tib_pexchain,
3639 (unsigned long)&(newstack->xreg));
3641 rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
3643 sprintf(buf + strlen(buf),
3644 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
3647 /* ExceptionRecords should be on stack, in a correct order. Sigh... */
3648 preg->prev_structure = 0;
3649 preg->ExceptionHandler = _emx_exception;
3650 rc = DosSetExceptionHandler(preg);
3652 sprintf(buf + strlen(buf),
3653 "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
3654 DosWrite(2, buf, strlen(buf), &out);
3655 emx_exception_init = 1; /* Do it around spawn*() calls */
3658 emx_exception_init = 1; /* Do it around spawn*() calls */
3661 /* Restore the damage */
3662 pib->pib_pchcmd = oldarg;
3663 pib->pib_pchcmd = oldenv;
3664 tib->tib_pstacklimit = oldstackend;
3665 tib->tib_pstack = oldstack;
3666 emx_runtime_init = 1;
3668 DosWrite(2, buf, strlen(buf), &out);
3674 jmp_out_of_atexit(void)
3676 if (longjmp_at_exit)
3677 longjmp(at_exit_buf, 1);
3680 extern void _CRT_term(void);
3683 Perl_OS2_term(void **p, int exitstatus, int flags)
3685 if (!emx_runtime_secondary)
3688 /* The principal executable is not running the same CRTL, so there
3689 is nobody to shutdown *this* CRTL except us... */
3690 if (flags & FORCE_EMX_DEINIT_EXIT) {
3691 if (p && !emx_exception_init)
3692 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
3693 /* Do not run the executable's CRTL's termination routines */
3694 exit(exitstatus); /* Run at-exit, flush buffers, etc */
3696 /* Run at-exit list, and jump out at the end */
3697 if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
3698 longjmp_at_exit = 1;
3699 exit(exitstatus); /* The first pass through "if" */
3702 /* Get here if we managed to jump out of exit(), or did not run atexit. */
3703 longjmp_at_exit = 0; /* Maybe exit() is called again? */
3704 #if 0 /* _atexit_n is not exported */
3705 if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
3706 _atexit_n = 0; /* Remove the atexit() handlers */
3708 /* Will segfault on program termination if we leave this dangling... */
3709 if (p && !emx_exception_init)
3710 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
3711 /* Typically there is no need to do this, done from _DLL_InitTerm() */
3712 if (flags & FORCE_EMX_DEINIT_CRT_TERM)
3713 _CRT_term(); /* Flush buffers, etc. */
3714 /* Now it is a good time to call exit() in the caller's CRTL... */
3717 #include <emx/startup.h>
3719 extern ULONG __os_version(); /* See system.doc */
3722 check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
3724 ULONG v_crt, v_emx, count = 0, rc, rc1, maybe_inited = 0;
3725 static HMTX hmtx_emx_init = NULLHANDLE;
3726 static int emx_init_done = 0;
3728 /* If _environ is not set, this code sits in a DLL which
3729 uses a CRT DLL which not compatible with the executable's
3730 CRT library. Some parts of the DLL are not initialized.
3732 if (_environ != NULL)
3733 return; /* Properly initialized */
3735 /* It is not DOS, so we may use OS/2 API now */
3736 /* Some data we manipulate is static; protect ourselves from
3737 calling the same API from a different thread. */
3738 DosEnterMustComplete(&count);
3740 rc1 = DosEnterCritSec();
3742 rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/
3747 hmtx_emx_init = NULLHANDLE;
3749 if (rc1 == NO_ERROR)
3751 DosExitMustComplete(&count);
3753 while (maybe_inited) { /* Other thread did or is doing the same now */
3756 rc = DosRequestMutexSem(hmtx_emx_init,
3757 (ULONG) SEM_INDEFINITE_WAIT); /* Timeout (none) */
3758 if (rc == ERROR_INTERRUPT)
3760 if (rc != NO_ERROR) {
3765 "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc);
3766 DosWrite(2, buf, strlen(buf), &out);
3769 DosReleaseMutexSem(hmtx_emx_init);
3773 /* If the executable does not use EMX.DLL, EMX.DLL is not completely
3774 initialized either. Uninitialized EMX.DLL returns 0 in the low
3775 nibble of __os_version(). */
3776 v_emx = my_os_version();
3778 /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
3779 (=>_CRT_init=>_entry2) via a call to __os_version(), then
3780 reset when the EXE initialization code calls _text=>_init=>_entry2.
3781 The first time they are wrongly set to 0; the second time the
3782 EXE initialization code had already called emx_init=>initialize1
3783 which correctly set version_major, version_minor used by
3785 v_crt = (_osmajor | _osminor);
3787 if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */
3788 force_init_emx_runtime( preg,
3789 FORCE_EMX_INIT_CONTRACT_ARGV
3790 | FORCE_EMX_INIT_INSTALL_ATEXIT );
3791 emx_wasnt_initialized = 1;
3792 /* Update CRTL data basing on now-valid EMX runtime data */
3793 if (!v_crt) { /* The only wrong data are the versions. */
3794 v_emx = my_os_version(); /* *Now* it works */
3795 *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
3796 *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
3799 emx_runtime_secondary = 1;
3800 /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
3801 atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */
3803 if (env == NULL) { /* Fetch from the process info block */
3809 DosGetInfoBlocks(&tib, &pib);
3810 e = pib->pib_pchenv;
3811 while (*e) { /* Get count */
3813 e = e + strlen(e) + 1;
3815 New(1307, env, c + 1, char*);
3817 e = pib->pib_pchenv;
3820 e = e + strlen(e) + 1;
3824 _environ = _org_environ = env;
3827 DosReleaseMutexSem(hmtx_emx_init);
3830 #define ENTRY_POINT 0x10000
3835 struct layout_table_t *layout;
3836 if (emx_wasnt_initialized)
3838 /* Now we know that the principal executable is an EMX application
3839 - unless somebody did already play with delayed initialization... */
3840 /* With EMX applications to determine whether it is AOUT one needs
3841 to examine the start of the executable to find "layout" */
3842 if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */
3843 || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */
3844 || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */
3845 || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */
3846 return 0; /* ! EMX executable */
3848 Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
3849 return !(layout->flags & 2);
3853 Perl_OS2_init(char **env)
3855 Perl_OS2_init3(env, 0, 0);
3859 Perl_OS2_init3(char **env, void **preg, int flags)
3863 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
3866 check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
3869 OS2_Perl_data.xs_init = &Xs_OS2_init;
3870 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
3871 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
3872 strcpy(PL_sh_path, SH_PATH);
3873 PL_sh_path[0] = shell[0];
3874 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
3875 int l = strlen(shell), i;
3876 if (shell[l-1] == '/' || shell[l-1] == '\\') {
3879 New(1304, PL_sh_path, l + 8, char);
3880 strncpy(PL_sh_path, shell, l);
3881 strcpy(PL_sh_path + l, "/sh.exe");
3882 for (i = 0; i < l; i++) {
3883 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
3886 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
3887 MUTEX_INIT(&start_thread_mutex);
3888 MUTEX_INIT(&perlos2_state_mutex);
3890 os2_mytype = my_type(); /* Do it before morphing. Needed? */
3891 os2_mytype_ini = os2_mytype;
3892 Perl_os2_initial_mode = -1; /* Uninit */
3893 /* Some DLLs reset FP flags on load. We may have been linked with them */
3894 _control87(MCW_EM, MCW_EM);
3901 my_tmpnam (char *str)
3903 char *p = getenv("TMP"), *tpath;
3905 if (!p) p = getenv("TEMP");
3906 tpath = tempnam(p, "pltmp");
3920 if (s.st_mode & S_IWOTH) {
3923 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
3929 /* EMX flavors do not tolerate trailing slashes. t/op/mkdir.t has many
3930 trailing slashes, so we need to support this as well. */
3933 my_rmdir (__const__ char *s)
3937 STRLEN l = strlen(s);
3940 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
3942 New(1305, buf, l + 1, char);
3944 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
3958 my_mkdir (__const__ char *s, long perm)
3962 STRLEN l = strlen(s);
3965 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
3967 New(1305, buf, l + 1, char);
3969 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
3974 rc = mkdir(s, perm);
3982 /* This code was contributed by Rocco Caputo. */
3984 my_flock(int handle, int o)
3986 FILELOCK rNull, rFull;
3987 ULONG timeout, handle_type, flag_word;
3989 int blocking, shared;
3990 static int use_my_flock = -1;
3992 if (use_my_flock == -1) {
3993 MUTEX_LOCK(&perlos2_state_mutex);
3994 if (use_my_flock == -1) {
3995 char *s = getenv("USE_PERL_FLOCK");
3997 use_my_flock = atoi(s);
4001 MUTEX_UNLOCK(&perlos2_state_mutex);
4003 if (!(_emx_env & 0x200) || !use_my_flock)
4004 return flock(handle, o); /* Delegate to EMX. */
4006 /* is this a file? */
4007 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
4008 (handle_type & 0xFF))
4013 /* set lock/unlock ranges */
4014 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
4015 rFull.lRange = 0x7FFFFFFF;
4016 /* set timeout for blocking */
4017 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
4018 /* shared or exclusive? */
4019 shared = (o & LOCK_SH) ? 1 : 0;
4020 /* do not block the unlock */
4021 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
4022 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
4027 case ERROR_INVALID_HANDLE:
4030 case ERROR_SHARING_BUFFER_EXCEEDED:
4033 case ERROR_LOCK_VIOLATION:
4034 break; /* not an error */
4035 case ERROR_INVALID_PARAMETER:
4036 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
4037 case ERROR_READ_LOCKS_NOT_SUPPORTED:
4040 case ERROR_INTERRUPT:
4048 /* lock may block */
4049 if (o & (LOCK_SH | LOCK_EX)) {
4050 /* for blocking operations */
4064 case ERROR_INVALID_HANDLE:
4067 case ERROR_SHARING_BUFFER_EXCEEDED:
4070 case ERROR_LOCK_VIOLATION:
4072 errno = EWOULDBLOCK;
4076 case ERROR_INVALID_PARAMETER:
4077 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
4078 case ERROR_READ_LOCKS_NOT_SUPPORTED:
4081 case ERROR_INTERRUPT:
4088 /* give away timeslice */
4100 if (_my_pwent == -1) {
4101 char *s = getenv("USE_PERL_PWENT");
4103 _my_pwent = atoi(s);
4117 if (!use_my_pwent()) {
4118 setpwent(); /* Delegate to EMX. */
4127 if (!use_my_pwent()) {
4128 endpwent(); /* Delegate to EMX. */
4136 if (!use_my_pwent())
4137 return getpwent(); /* Delegate to EMX. */
4139 return 0; /* Return one entry only */
4158 return 0; /* Return one entry only */
4165 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
4166 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
4168 static struct passwd *
4169 passw_wrap(struct passwd *p)
4173 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
4176 s = getenv("PW_PASSWD");
4178 s = (char*)pw_p; /* Make match impossible */
4185 my_getpwuid (uid_t id)
4187 return passw_wrap(getpwuid(id));
4191 my_getpwnam (__const__ char *n)
4193 return passw_wrap(getpwnam(n));
4197 gcvt_os2 (double value, int digits, char *buffer)
4199 double absv = value > 0 ? value : -value;
4200 /* EMX implementation is lousy between 0.1 and 0.0001 (uses exponents below
4201 0.1), 1-digit stuff is ok below 0.001; multi-digit below 0.0001. */
4205 buggy = (absv < 1000 && (absv >= 10 || (absv > 1 && floor(absv) != absv)));
4210 sprintf(pat, "%%.%dg", digits);
4211 sprintf(buffer, pat, value);
4214 return gcvt (value, digits, buffer);
4218 int fork_with_resources()
4220 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
4222 void *ctx = PERL_GET_CONTEXT;
4224 unsigned fpflag = _control87(0,0);
4227 if (rc == 0) { /* child */
4228 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
4229 ALLOC_THREAD_KEY; /* Acquire the thread-local memory */
4230 PERL_SET_CONTEXT(ctx); /* Reinit the thread-local memory */
4233 { /* Reload loaded-on-demand DLLs */
4234 struct dll_handle_t *dlls = dll_handles;
4236 while (dlls->modname) {
4237 char dllname[260], fail[260];
4240 if (!dlls->handle) { /* Was not loaded */
4244 /* It was loaded in the parent. We need to reload it. */
4246 rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname);
4248 Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx",
4249 dlls->modname, (int)dlls->handle, rc, rc);
4253 rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle);
4255 Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'",
4261 { /* Support message queue etc. */
4262 os2_mytype = my_type();
4263 /* Apparently, subprocesses (in particular, fork()) do not
4264 inherit the morphed state, so os2_mytype is the same as
4267 if (Perl_os2_initial_mode != -1
4268 && Perl_os2_initial_mode != os2_mytype) {
4273 (void)_obtain_Perl_HAB;
4274 if (Perl_hmq_refcnt) {
4277 Create_HMQ(Perl_hmq_servers != 0,
4278 "Cannot create a message queue on fork");
4281 /* We may have loaded some modules */
4282 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */