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 */
623 {&doscalls_handle, NULL, 976}, /* DosPerfSysCall */
624 {&rexxapi_handle, "RexxRegisterSubcomExe", 0},
628 loadModule(const char *modname, int fail)
630 HMODULE h = (HMODULE)dlopen(modname, 0);
633 Perl_croak_nocontext("Error loading module '%s': %s",
638 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
647 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
648 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
651 return (pib->pib_ultype);
655 my_type_set(int type)
661 if (!(_emx_env & 0x200))
662 Perl_croak_nocontext("Can't set type on DOS"); /* not OS/2. */
663 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
664 croak_with_os2error("Error getting info blocks");
665 pib->pib_ultype = type;
669 loadByOrdinal(enum entries_ordinals ord, int fail)
671 if (sizeof(loadOrdinals)/sizeof(loadOrdinals[0]) != ORD_NENTRIES)
672 Perl_croak_nocontext(
673 "Wrong size of loadOrdinals array: expected %d, actual %d",
674 sizeof(loadOrdinals)/sizeof(loadOrdinals[0]), ORD_NENTRIES);
675 if (ExtFCN[ord] == NULL) {
679 if (!loadOrdinals[ord].dll->handle) {
680 if (loadOrdinals[ord].dll->requires_pm && my_type() < 2) { /* FS */
681 char *s = getenv("PERL_ASIF_PM");
683 if (!s || !atoi(s)) {
684 /* The module will not function well without PM.
685 The usual way to detect PM is the existence of the mutex
686 \SEM32\PMDRAG.SEM. */
689 if (CheckOSError(DosOpenMutexSem("\\SEM32\\PMDRAG.SEM",
691 Perl_croak_nocontext("Looks like we have no PM; will not load DLL %s without $ENV{PERL_ASIF_PM}",
692 loadOrdinals[ord].dll->modname);
693 DosCloseMutexSem(hMtx);
696 MUTEX_LOCK(&perlos2_state_mutex);
697 loadOrdinals[ord].dll->handle
698 = loadModule(loadOrdinals[ord].dll->modname, fail);
699 MUTEX_UNLOCK(&perlos2_state_mutex);
701 if (!loadOrdinals[ord].dll->handle)
702 return 0; /* Possible with FAIL==0 only */
703 if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle,
704 loadOrdinals[ord].entrypoint,
705 loadOrdinals[ord].entryname,&fcn))) {
706 char buf[20], *s = (char*)loadOrdinals[ord].entryname;
711 sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint);
712 Perl_croak_nocontext(
713 "This version of OS/2 does not support %s.%s",
714 loadOrdinals[ord].dll->modname, s);
718 if ((long)ExtFCN[ord] == -1)
719 Perl_croak_nocontext("panic queryaddr");
724 init_PMWIN_entries(void)
728 for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++)
729 ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1);
732 /*****************************************************/
733 /* socket forwarders without linking with tcpip DLLs */
735 DeclFuncByORD(struct hostent *, gethostent, ORD_GETHOSTENT, (void), ())
736 DeclFuncByORD(struct netent *, getnetent, ORD_GETNETENT, (void), ())
737 DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ())
738 DeclFuncByORD(struct servent *, getservent, ORD_GETSERVENT, (void), ())
740 DeclVoidFuncByORD(sethostent, ORD_SETHOSTENT, (int x), (x))
741 DeclVoidFuncByORD(setnetent, ORD_SETNETENT, (int x), (x))
742 DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x))
743 DeclVoidFuncByORD(setservent, ORD_SETSERVENT, (int x), (x))
745 DeclVoidFuncByORD(endhostent, ORD_ENDHOSTENT, (void), ())
746 DeclVoidFuncByORD(endnetent, ORD_ENDNETENT, (void), ())
747 DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ())
748 DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ())
751 static const signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
753 #define QSS_INI_BUFFER 1024
755 ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
758 get_sysinfo(ULONG pid, ULONG flags)
761 ULONG rc, buf_len = QSS_INI_BUFFER;
765 if (!pidtid_lookup) {
767 *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0);
769 if (pDosVerifyPidTid) { /* Warp3 or later */
770 /* Up to some fixpak QuerySysState() kills the system if a non-existent
772 if (CheckOSError(pDosVerifyPidTid(pid, 1)))
776 New(1322, pbuffer, buf_len, char);
777 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
778 rc = QuerySysState(flags, pid, pbuffer, buf_len);
779 while (rc == ERROR_BUFFER_OVERFLOW) {
780 Renew(pbuffer, buf_len *= 2, char);
781 rc = QuerySysState(flags, pid, pbuffer, buf_len);
788 psi = (PQTOPLEVEL)pbuffer;
789 if (psi && pid && psi->procdata && pid != psi->procdata->pid) {
791 Perl_croak_nocontext("panic: wrong pid in sysinfo");
796 #define PRIO_ERR 0x1111
806 psi = get_sysinfo(pid, QSS_PROCESS);
809 prio = psi->procdata->threads->priority;
815 setpriority(int which, int pid, int val)
817 ULONG rc, prio = sys_prio(pid);
819 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
820 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
821 /* Do not change class. */
822 return CheckOSError(DosSetPriority((pid < 0)
823 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
825 (32 - val) % 32 - (prio & 0xFF),
828 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
829 /* Documentation claims one can change both class and basevalue,
830 * but I find it wrong. */
831 /* Change class, but since delta == 0 denotes absolute 0, correct. */
832 if (CheckOSError(DosSetPriority((pid < 0)
833 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
834 priors[(32 - val) >> 5] + 1,
838 if ( ((32 - val) % 32) == 0 ) return 0;
839 return CheckOSError(DosSetPriority((pid < 0)
840 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
849 getpriority(int which /* ignored */, int pid)
853 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
855 if (ret == PRIO_ERR) {
858 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
861 /*****************************************************************************/
867 spawn_sighandler(int sig)
869 /* Some programs do not arrange for the keyboard signals to be
870 delivered to them. We need to deliver the signal manually. */
871 /* We may get a signal only if
872 a) kid does not receive keyboard signal: deliver it;
873 b) kid already died, and we get a signal. We may only hope
874 that the pid number was not reused.
878 sig = SIGKILL; /* Try harder. */
879 kill(spawn_pid, sig);
884 result(pTHX_ int flag, int pid)
887 Signal_t (*ihand)(); /* place to save signal during system() */
888 Signal_t (*qhand)(); /* place to save signal during system() */
894 if (pid < 0 || flag != 0)
900 ihand = rsignal(SIGINT, &spawn_sighandler);
901 qhand = rsignal(SIGQUIT, &spawn_sighandler);
903 r = wait4pid(pid, &status, 0);
904 } while (r == -1 && errno == EINTR);
905 rsignal(SIGINT, ihand);
906 rsignal(SIGQUIT, qhand);
908 PL_statusvalue = (U16)status;
911 return status & 0xFFFF;
913 ihand = rsignal(SIGINT, SIG_IGN);
914 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
915 rsignal(SIGINT, ihand);
916 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
919 return PL_statusvalue;
933 file_type(char *path)
938 if (!(_emx_env & 0x200))
939 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
940 if (CheckOSError(DosQueryAppType(path, &apptype))) {
942 case ERROR_FILE_NOT_FOUND:
943 case ERROR_PATH_NOT_FOUND:
945 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
947 default: /* Found, but not an
948 executable, or some other
956 /* Spawn/exec a program, revert to shell if needed. */
957 /* global PL_Argv[] contains arguments. */
959 extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
960 EXCEPTIONREGISTRATIONRECORD *,
965 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
970 char const * args[4];
971 static const char * const fargs[4]
972 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
973 const char * const *argsp = fargs;
976 int new_stderr = -1, nostderr = 0;
984 if (really && !*(real_name = SvPV(really, n_a)))
988 if (strEQ(PL_Argv[0],"/bin/sh"))
989 PL_Argv[0] = PL_sh_path;
991 /* We should check PERL_SH* and PERLLIB_* as well? */
992 if (!really || pass >= 2)
993 real_name = PL_Argv[0];
994 if (real_name[0] != '/' && real_name[0] != '\\'
995 && !(real_name[0] && real_name[1] == ':'
996 && (real_name[2] == '/' || real_name[2] != '\\'))
997 ) /* will spawnvp use PATH? */
998 TAINT_ENV(); /* testing IFS here is overkill, probably */
1002 if (_emx_env & 0x200) { /* OS/2. */
1003 int type = file_type(real_name);
1005 if (type == -1) { /* Not found */
1010 else if (type == -2) { /* Not an EXE */
1015 else if (type == -3) { /* Is a directory? */
1016 /* Special-case this */
1018 int l = strlen(real_name);
1020 if (l + 5 <= sizeof tbuf) {
1021 strcpy(tbuf, real_name);
1022 strcpy(tbuf + l, ".exe");
1023 type = file_type(tbuf);
1033 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
1034 case FAPPTYP_WINDOWAPI:
1035 { /* Apparently, kids are started basing on startup type, not the morphed type */
1036 if (os2_mytype != 3) { /* not PM */
1037 if (flag == P_NOWAIT)
1039 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
1040 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d",
1045 case FAPPTYP_NOTWINDOWCOMPAT:
1047 if (os2_mytype != 0) { /* not full screen */
1048 if (flag == P_NOWAIT)
1050 else if ((flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
1051 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d",
1056 case FAPPTYP_NOTSPEC:
1057 /* Let the shell handle this... */
1059 buf = ""; /* Pacify a warning */
1060 file = 0; /* Pacify a warning */
1068 new_stderr = dup(2); /* Preserve stderr */
1069 if (new_stderr == -1) {
1077 fl_stderr = fcntl(2, F_GETFD);
1081 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
1085 rc = result(aTHX_ trueflag, spawnvp(flag,real_name,PL_Argv));
1087 if (execf == EXECF_TRUEEXEC)
1088 rc = execvp(real_name,PL_Argv);
1089 else if (execf == EXECF_EXEC)
1090 rc = spawnvp(trueflag | P_OVERLAY,real_name,PL_Argv);
1091 else if (execf == EXECF_SPAWN_NOWAIT)
1092 rc = spawnvp(flag,real_name,PL_Argv);
1093 else if (execf == EXECF_SYNC)
1094 rc = spawnvp(trueflag,real_name,PL_Argv);
1095 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
1096 rc = result(aTHX_ trueflag,
1097 spawnvp(flag,real_name,PL_Argv));
1099 if (rc < 0 && pass == 1) {
1101 if (real_name == PL_Argv[0]) {
1104 if (err == ENOENT || err == ENOEXEC) {
1105 /* No such file, or is a script. */
1106 /* Try adding script extensions to the file name, and
1108 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
1112 SV *scrsv = sv_2mortal(newSVpv(scr, 0));
1113 SV *bufsv = sv_newmortal();
1116 scr = SvPV(scrsv, n_a); /* free()ed later */
1118 file = PerlIO_open(scr, "r");
1123 buf = sv_gets(bufsv, file, 0 /* No append */);
1125 buf = ""; /* XXX Needed? */
1126 if (!buf[0]) { /* Empty... */
1128 /* Special case: maybe from -Zexe build, so
1129 there is an executable around (contrary to
1130 documentation, DosQueryAppType sometimes (?)
1131 does not append ".exe", so we could have
1132 reached this place). */
1133 sv_catpv(scrsv, ".exe");
1134 PL_Argv[0] = scr = SvPV(scrsv, n_a); /* Reload */
1135 if (PerlLIO_stat(scr,&PL_statbuf) >= 0
1136 && !S_ISDIR(PL_statbuf.st_mode)) { /* Found */
1140 } else { /* Restore */
1141 SvCUR_set(scrsv, SvCUR(scrsv) - 4);
1145 if (PerlIO_close(file) != 0) { /* Failure */
1147 if (ckWARN(WARN_EXEC))
1148 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
1149 scr, Strerror(errno));
1150 buf = ""; /* Not #! */
1153 if (buf[0] == '#') {
1156 } else if (buf[0] == 'e') {
1157 if (strnEQ(buf, "extproc", 7)
1160 } else if (buf[0] == 'E') {
1161 if (strnEQ(buf, "EXTPROC", 7)
1166 buf = ""; /* Not #! */
1174 /* Do better than pdksh: allow a few args,
1175 strip trailing whitespace. */
1185 while (*s && !isSPACE(*s))
1192 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"",
1193 s1 - buf, buf, scr);
1197 /* Can jump from far, buf/file invalid if force_shell: */
1201 const char *exec_args[2];
1204 || (!buf[0] && file)) { /* File without magic */
1205 /* In fact we tried all what pdksh would
1206 try. There is no point in calling
1207 pdksh, we may just emulate its logic. */
1208 char *shell = getenv("EXECSHELL");
1209 char *shell_opt = NULL;
1215 shell = getenv("OS2_SHELL");
1216 if (inicmd) { /* No spaces at start! */
1218 while (*s && !isSPACE(*s)) {
1220 inicmd = NULL; /* Cannot use */
1228 /* Dosish shells will choke on slashes
1229 in paths, fortunately, this is
1230 important for zeroth arg only. */
1237 /* If EXECSHELL is set, we do not set */
1240 shell = ((_emx_env & 0x200)
1242 : "c:/command.com");
1243 nargs = shell_opt ? 2 : 1; /* shell file args */
1244 exec_args[0] = shell;
1245 exec_args[1] = shell_opt;
1247 if (nargs == 2 && inicmd) {
1248 /* Use the original cmd line */
1249 /* XXXX This is good only until we refuse
1250 quoted arguments... */
1251 PL_Argv[0] = inicmd;
1252 PL_Argv[1] = Nullch;
1254 } else if (!buf[0] && inicmd) { /* No file */
1255 /* Start with the original cmdline. */
1256 /* XXXX This is good only until we refuse
1257 quoted arguments... */
1259 PL_Argv[0] = inicmd;
1260 PL_Argv[1] = Nullch;
1261 nargs = 2; /* shell -c */
1264 while (a[1]) /* Get to the end */
1266 a++; /* Copy finil NULL too */
1267 while (a >= PL_Argv) {
1268 *(a + nargs) = *a; /* PL_Argv was preallocated to be
1272 while (--nargs >= 0) /* XXXX Discard const... */
1273 PL_Argv[nargs] = (char*)argsp[nargs];
1274 /* Enable pathless exec if #! (as pdksh). */
1275 pass = (buf[0] == '#' ? 2 : 3);
1279 /* Not found: restore errno */
1282 } else if (errno == ENOEXEC) { /* Cannot transfer `real_name' via shell. */
1283 if (rc < 0 && ckWARN(WARN_EXEC))
1284 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s script `%s' with ARGV[0] being `%s'",
1285 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1286 ? "spawn" : "exec"),
1287 real_name, PL_Argv[0]);
1289 } else if (errno == ENOENT) { /* Cannot transfer `real_name' via shell. */
1290 if (rc < 0 && ckWARN(WARN_EXEC))
1291 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)",
1292 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1293 ? "spawn" : "exec"),
1294 real_name, PL_Argv[0]);
1297 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
1298 char *no_dir = strrchr(PL_Argv[0], '/');
1300 /* Do as pdksh port does: if not found with /, try without
1303 PL_Argv[0] = no_dir + 1;
1308 if (rc < 0 && ckWARN(WARN_EXEC))
1309 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n",
1310 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1311 ? "spawn" : "exec"),
1312 real_name, Strerror(errno));
1314 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
1315 && ((trueflag & 0xFF) == P_WAIT))
1319 if (new_stderr != -1) { /* How can we use error codes? */
1320 dup2(new_stderr, 2);
1322 fcntl(2, F_SETFD, fl_stderr);
1323 } else if (nostderr)
1328 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
1330 do_spawn3(pTHX_ char *cmd, int execf, int flag)
1334 char *shell, *copt, *news = NULL;
1335 int rc, seenspace = 0, mergestderr = 0;
1338 if ((shell = getenv("EMXSHELL")) != NULL)
1340 else if ((shell = getenv("SHELL")) != NULL)
1342 else if ((shell = getenv("COMSPEC")) != NULL)
1347 /* Consensus on perl5-porters is that it is _very_ important to
1348 have a shell which will not change between computers with the
1349 same architecture, to avoid "action on a distance".
1350 And to have simple build, this shell should be sh. */
1355 while (*cmd && isSPACE(*cmd))
1358 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
1359 STRLEN l = strlen(PL_sh_path);
1361 New(1302, news, strlen(cmd) - 7 + l + 1, char);
1362 strcpy(news, PL_sh_path);
1363 strcpy(news + l, cmd + 7);
1367 /* save an extra exec if possible */
1368 /* see if there are shell metacharacters in it */
1370 if (*cmd == '.' && isSPACE(cmd[1]))
1373 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1376 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
1380 for (s = cmd; *s; s++) {
1381 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
1382 if (*s == '\n' && s[1] == '\0') {
1385 } else if (*s == '\\' && !seenspace) {
1386 continue; /* Allow backslashes in names */
1387 } else if (*s == '>' && s >= cmd + 3
1388 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
1389 && isSPACE(s[-2]) ) {
1392 while (*t && isSPACE(*t))
1397 break; /* Allow 2>&1 as the last thing */
1400 /* We do not convert this to do_spawn_ve since shell
1401 should be smart enough to start itself gloriously. */
1403 if (execf == EXECF_TRUEEXEC)
1404 rc = execl(shell,shell,copt,cmd,(char*)0);
1405 else if (execf == EXECF_EXEC)
1406 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
1407 else if (execf == EXECF_SPAWN_NOWAIT)
1408 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
1409 else if (execf == EXECF_SPAWN_BYFLAG)
1410 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
1412 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
1413 if (execf == EXECF_SYNC)
1414 rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0);
1416 rc = result(aTHX_ P_WAIT,
1417 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
1418 if (rc < 0 && ckWARN(WARN_EXEC))
1419 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
1420 (execf == EXECF_SPAWN ? "spawn" : "exec"),
1421 shell, Strerror(errno));
1428 } else if (*s == ' ' || *s == '\t') {
1433 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
1434 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
1435 PL_Cmd = savepvn(cmd, s-cmd);
1437 for (s = PL_Cmd; *s;) {
1438 while (*s && isSPACE(*s)) s++;
1441 while (*s && !isSPACE(*s)) s++;
1447 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
1456 /* Array spawn/exec. */
1458 os2_aspawn4(pTHX_ SV *really, register SV **vmark, register SV **vsp, int execing)
1460 register SV **mark = (SV **)vmark;
1461 register SV **sp = (SV **)vsp;
1464 int flag = P_WAIT, flag_set = 0;
1468 New(1301,PL_Argv, sp - mark + 3, char*);
1471 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
1473 flag = SvIVx(*mark);
1478 while (++mark <= sp) {
1480 *a++ = SvPVx(*mark, n_a);
1486 if ( flag_set && (a == PL_Argv + 1)
1487 && !really && !execing ) { /* One arg? */
1488 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
1490 rc = do_spawn_ve(aTHX_ really, flag,
1491 (execing ? EXECF_EXEC : EXECF_SPAWN), NULL, 0);
1500 os2_do_aspawn(pTHX_ SV *really, register SV **vmark, register SV **vsp)
1502 return os2_aspawn4(aTHX_ really, vmark, vsp, 0);
1507 Perl_do_aexec(pTHX_ SV* really, SV** vmark, SV** vsp)
1509 return os2_aspawn4(aTHX_ really, vmark, vsp, 1);
1513 os2_do_spawn(pTHX_ char *cmd)
1515 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
1519 do_spawn_nowait(pTHX_ char *cmd)
1521 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1525 Perl_do_exec(pTHX_ char *cmd)
1527 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1532 os2exec(pTHX_ char *cmd)
1534 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1538 my_syspopen(pTHX_ char *cmd, char *mode)
1542 register I32 this, that, newfd;
1545 int fh_fl = 0; /* Pacify the warning */
1547 /* `this' is what we use in the parent, `that' in the child. */
1548 this = (*mode == 'w');
1552 taint_proper("Insecure %s%s", "EXEC");
1556 /* Now we need to spawn the child. */
1557 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1558 int new = dup(p[this]);
1565 newfd = dup(*mode == 'r'); /* Preserve std* */
1567 /* This cannot happen due to fh being bad after pipe(), since
1568 pipe() should have created fh 0 and 1 even if they were
1569 initially closed. But we closed p[this] before. */
1570 if (errno != EBADF) {
1577 fh_fl = fcntl(*mode == 'r', F_GETFD);
1578 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1579 dup2(p[that], *mode == 'r');
1582 /* Where is `this' and newfd now? */
1583 fcntl(p[this], F_SETFD, FD_CLOEXEC);
1585 fcntl(newfd, F_SETFD, FD_CLOEXEC);
1586 pid = do_spawn_nowait(aTHX_ cmd);
1588 close(*mode == 'r'); /* It was closed initially */
1589 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1590 dup2(newfd, *mode == 'r'); /* Return std* back. */
1592 fcntl(*mode == 'r', F_SETFD, fh_fl);
1594 fcntl(*mode == 'r', F_SETFD, fh_fl);
1595 if (p[that] == (*mode == 'r'))
1601 if (p[that] < p[this]) { /* Make fh as small as possible */
1602 dup2(p[this], p[that]);
1606 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1607 (void)SvUPGRADE(sv,SVt_IV);
1609 PL_forkprocess = pid;
1610 return PerlIO_fdopen(p[this], mode);
1612 #else /* USE_POPEN */
1618 res = popen(cmd, mode);
1620 char *shell = getenv("EMXSHELL");
1622 my_setenv("EMXSHELL", PL_sh_path);
1623 res = popen(cmd, mode);
1624 my_setenv("EMXSHELL", shell);
1626 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1627 (void)SvUPGRADE(sv,SVt_IV);
1628 SvIVX(sv) = -1; /* A cooky. */
1631 #endif /* USE_POPEN */
1635 /******************************************************************/
1641 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1647 /*******************************************************************/
1648 /* not implemented in EMX 0.9d */
1650 char * ctermid(char *s) { return 0; }
1652 #ifdef MYTTYNAME /* was not in emx0.9a */
1653 void * ttyname(x) { return 0; }
1656 /*****************************************************************************/
1657 /* not implemented in C Set++ */
1660 int setuid(x) { errno = EINVAL; return -1; }
1661 int setgid(x) { errno = EINVAL; return -1; }
1664 /*****************************************************************************/
1665 /* stat() hack for char/block device */
1669 enum os2_stat_extra { /* EMX 0.9d fix 4 defines up to 0100000 */
1670 os2_stat_archived = 0x1000000, /* 0100000000 */
1671 os2_stat_hidden = 0x2000000, /* 0200000000 */
1672 os2_stat_system = 0x4000000, /* 0400000000 */
1673 os2_stat_force = 0x8000000, /* Do not ignore flags on chmod */
1676 #define OS2_STAT_SPECIAL (os2_stat_system | os2_stat_archived | os2_stat_hidden)
1679 massage_os2_attr(struct stat *st)
1681 if ( ((st->st_mode & S_IFMT) != S_IFREG
1682 && (st->st_mode & S_IFMT) != S_IFDIR)
1683 || !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM)))
1686 if ( st->st_attr & FILE_ARCHIVED )
1687 st->st_mode |= (os2_stat_archived | os2_stat_force);
1688 if ( st->st_attr & FILE_HIDDEN )
1689 st->st_mode |= (os2_stat_hidden | os2_stat_force);
1690 if ( st->st_attr & FILE_SYSTEM )
1691 st->st_mode |= (os2_stat_system | os2_stat_force);
1694 /* First attempt used DosQueryFSAttach which crashed the system when
1695 used with 5.001. Now just look for /dev/. */
1697 os2_stat(const char *name, struct stat *st)
1699 static int ino = SHRT_MAX;
1700 STRLEN l = strlen(name);
1702 if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0
1703 || ( stricmp(name + 5, "con") != 0
1704 && stricmp(name + 5, "tty") != 0
1705 && stricmp(name + 5, "nul") != 0
1706 && stricmp(name + 5, "null") != 0) ) {
1707 int s = stat(name, st);
1711 massage_os2_attr(st);
1715 memset(st, 0, sizeof *st);
1716 st->st_mode = S_IFCHR|0666;
1717 MUTEX_LOCK(&perlos2_state_mutex);
1718 st->st_ino = (ino-- & 0x7FFF);
1719 MUTEX_UNLOCK(&perlos2_state_mutex);
1725 os2_fstat(int handle, struct stat *st)
1727 int s = fstat(handle, st);
1731 massage_os2_attr(st);
1737 os2_chmod (const char *name, int pmode) /* Modelled after EMX src/lib/io/chmod.c */
1741 if (!(pmode & os2_stat_force))
1742 return chmod(name, pmode);
1744 attr = __chmod (name, 0, 0); /* Get attributes */
1747 if (pmode & S_IWRITE)
1748 attr &= ~FILE_READONLY;
1750 attr |= FILE_READONLY;
1752 attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM);
1754 if ( pmode & os2_stat_archived )
1755 attr |= FILE_ARCHIVED;
1756 if ( pmode & os2_stat_hidden )
1757 attr |= FILE_HIDDEN;
1758 if ( pmode & os2_stat_system )
1759 attr |= FILE_SYSTEM;
1761 rc = __chmod (name, 1, attr);
1762 if (rc >= 0) rc = 0;
1768 #ifdef USE_PERL_SBRK
1770 /* SBRK() emulation, mostly moved to malloc.c. */
1773 sys_alloc(int size) {
1775 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1777 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1780 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1784 #endif /* USE_PERL_SBRK */
1788 const char *tmppath = TMPPATH1;
1793 char *p = getenv("TMP"), *tpath;
1796 if (!p) p = getenv("TEMP");
1797 if (!p) p = getenv("TMPDIR");
1800 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1804 strcpy(tpath + len + 1, TMPPATH1);
1811 XS(XS_File__Copy_syscopy)
1814 if (items < 2 || items > 3)
1815 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1818 char * src = (char *)SvPV(ST(0),n_a);
1819 char * dst = (char *)SvPV(ST(1),n_a);
1827 flag = (unsigned long)SvIV(ST(2));
1830 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1831 XSprePUSH; PUSHi((IV)RETVAL);
1836 /* APIRET APIENTRY DosReplaceModule (PCSZ pszOld, PCSZ pszNew, PCSZ pszBackup); */
1838 DeclOSFuncByORD(ULONG,replaceModule,ORD_DosReplaceModule,
1839 (char *old, char *new, char *backup), (old, new, backup))
1841 XS(XS_OS2_replaceModule); /* prototype to pass -Wmissing-prototypes */
1842 XS(XS_OS2_replaceModule)
1845 if (items < 1 || items > 3)
1846 Perl_croak(aTHX_ "Usage: OS2::replaceModule(target [, source [, backup]])");
1848 char * target = (char *)SvPV_nolen(ST(0));
1849 char * source = (items < 2) ? Nullch : (char *)SvPV_nolen(ST(1));
1850 char * backup = (items < 3) ? Nullch : (char *)SvPV_nolen(ST(2));
1852 if (!replaceModule(target, source, backup))
1853 croak_with_os2error("replaceModule() error");
1858 /* APIRET APIENTRY DosPerfSysCall(ULONG ulCommand, ULONG ulParm1,
1859 ULONG ulParm2, ULONG ulParm3); */
1861 DeclOSFuncByORD(ULONG,perfSysCall,ORD_DosPerfSysCall,
1862 (ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3),
1863 (ulCommand, ulParm1, ulParm2, ulParm3))
1865 #ifndef CMD_KI_RDCNT
1866 # define CMD_KI_RDCNT 0x63
1868 #ifndef CMD_KI_GETQTY
1869 # define CMD_KI_GETQTY 0x41
1871 #ifndef QSV_NUMPROCESSORS
1872 # define QSV_NUMPROCESSORS 26
1875 typedef unsigned long long myCPUUTIL[4]; /* time/idle/busy/intr */
1879 perfSysCall(ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3)
1884 croak_with_os2error("perfSysCall() error");
1892 if (DosQuerySysInfo(QSV_NUMPROCESSORS, QSV_NUMPROCESSORS, (PVOID)&res, sizeof(res)))
1893 return 1; /* Old system? */
1897 XS(XS_OS2_perfSysCall); /* prototype to pass -Wmissing-prototypes */
1898 XS(XS_OS2_perfSysCall)
1901 if (items < 0 || items > 4)
1902 Perl_croak(aTHX_ "Usage: OS2::perfSysCall(ulCommand = CMD_KI_RDCNT, ulParm1= 0, ulParm2= 0, ulParm3= 0)");
1906 ULONG RETVAL, ulCommand, ulParm1, ulParm2, ulParm3, res;
1908 int total = 0, tot2 = 0;
1911 ulCommand = CMD_KI_RDCNT;
1913 ulCommand = (ULONG)SvUV(ST(0));
1917 total = (ulCommand == CMD_KI_RDCNT ? numprocessors() : 0);
1918 ulParm1 = (total ? (ULONG)u : 0);
1920 if (total > C_ARRAY_LENGTH(u))
1921 croak("Unexpected number of processors: %d", total);
1923 ulParm1 = (ULONG)SvUV(ST(1));
1927 tot2 = (ulCommand == CMD_KI_GETQTY);
1928 ulParm2 = (tot2 ? (ULONG)&res : 0);
1930 ulParm2 = (ULONG)SvUV(ST(2));
1936 ulParm3 = (ULONG)SvUV(ST(3));
1939 RETVAL = perfSysCall(ulCommand, ulParm1, ulParm2, ulParm3);
1941 croak_with_os2error("perfSysCall() error");
1945 if (GIMME_V != G_ARRAY) {
1946 PUSHn(u[0][0]); /* Total ticks on the first processor */
1949 for (i=0; i < total; i++)
1950 for (j=0; j < 4; j++)
1951 PUSHs(sv_2mortal(newSVnv(u[i][j])));
1962 #define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */
1963 #include "patchlevel.h"
1964 #undef PERL_PATCHLEVEL_H_IMPLICIT
1967 mod2fname(pTHX_ SV *sv)
1969 int pos = 6, len, avlen;
1970 unsigned int sum = 0;
1974 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1976 if (SvTYPE(sv) != SVt_PVAV)
1977 Perl_croak_nocontext("Not array reference given to mod2fname");
1979 avlen = av_len((AV*)sv);
1981 Perl_croak_nocontext("Empty array reference given to mod2fname");
1983 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1984 strncpy(fname, s, 8);
1986 if (len < 6) pos = len;
1988 sum = 33 * sum + *(s++); /* Checksumming first chars to
1989 * get the capitalization into c.s. */
1992 while (avlen >= 0) {
1993 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1995 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1999 /* We always load modules as *specific* DLLs, and with the full name.
2000 When loading a specific DLL by its full name, one cannot get a
2001 different DLL, even if a DLL with the same basename is loaded already.
2002 Thus there is no need to include the version into the mangling scheme. */
2004 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
2006 # ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
2007 # define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
2009 sum += COMPATIBLE_VERSION_SUM;
2011 fname[pos] = 'A' + (sum % 26);
2012 fname[pos + 1] = 'A' + (sum / 26 % 26);
2013 fname[pos + 2] = '\0';
2014 return (char *)fname;
2017 XS(XS_DynaLoader_mod2fname)
2021 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
2027 RETVAL = mod2fname(aTHX_ sv);
2028 sv_setpv(TARG, RETVAL);
2029 XSprePUSH; PUSHTARG;
2040 int number = SvTRUE(get_sv("OS2::nsyserror", TRUE));
2042 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
2046 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
2047 s = os2error_buf + strlen(os2error_buf);
2050 if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf),
2051 rc, "OSO001.MSG", &len)) {
2055 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
2056 s = os2error_buf + strlen(os2error_buf);
2059 case PMERR_INVALID_HWND:
2060 name = "PMERR_INVALID_HWND";
2062 case PMERR_INVALID_HMQ:
2063 name = "PMERR_INVALID_HMQ";
2065 case PMERR_CALL_FROM_WRONG_THREAD:
2066 name = "PMERR_CALL_FROM_WRONG_THREAD";
2068 case PMERR_NO_MSG_QUEUE:
2069 name = "PMERR_NO_MSG_QUEUE";
2071 case PMERR_NOT_IN_A_PM_SESSION:
2072 name = "PMERR_NOT_IN_A_PM_SESSION";
2075 sprintf(s, "%s%s[No description found in OSO001.MSG]",
2076 name, (*name ? "=" : ""));
2079 if (len && s[len - 1] == '\n')
2081 if (len && s[len - 1] == '\r')
2083 if (len && s[len - 1] == '.')
2085 if (len >= 10 && number && strnEQ(s, os2error_buf, 7)
2086 && s[7] == ':' && s[8] == ' ')
2087 /* Some messages start with SYSdddd:, some not */
2088 Move(s + 9, s, (len -= 9) + 1, char);
2090 return os2error_buf;
2100 CroakWinError(int die, char *name)
2103 if (die && Perl_rc) {
2106 Perl_croak(aTHX_ "%s: %s", (name ? name : "Win* API call"), os2error(Perl_rc));
2113 char buf[300], *p, *o = PL_origargv[0], ok = 1;
2115 if (_execname(buf, sizeof buf) != 0)
2122 if (ok && *o != '/' && *o != '\\')
2124 } else if (ok && tolower(*o) != tolower(*p))
2129 if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */
2130 strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */
2144 perllib_mangle(char *s, unsigned int l)
2146 if (!newp && !notfound) {
2147 newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION)
2148 STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION)
2151 newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION)
2152 STRINGIFY(PERL_VERSION) "_PREFIX");
2154 newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX");
2156 newp = getenv("PERLLIB_PREFIX");
2161 while (*newp && !isSPACE(*newp) && *newp != ';') {
2162 newp++; oldl++; /* Skip digits. */
2164 while (*newp && (isSPACE(*newp) || *newp == ';')) {
2165 newp++; /* Skip whitespace. */
2167 newl = strlen(newp);
2168 if (newl == 0 || oldl == 0) {
2169 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
2171 strcpy(mangle_ret, newp);
2174 if (*s == '\\') *s = '/';
2187 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
2190 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
2191 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
2193 strcpy(mangle_ret + newl, s + oldl);
2198 Perl_hab_GET() /* Needed if perl.h cannot be included */
2200 return perl_hab_GET();
2204 Create_HMQ(int serve, char *message) /* Assumes morphing */
2206 unsigned fpflag = _control87(0,0);
2208 init_PMWIN_entries();
2209 /* 64 messages if before OS/2 3.0, ignored otherwise */
2210 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
2214 SAVEINT(rmq_cnt); /* Allow catch()ing. */
2216 _exit(188); /* Panic can try to create a window. */
2217 CroakWinError(1, message ? message : "Cannot create a message queue");
2220 (*PMWIN_entries.CancelShutdown)(Perl_hmq, !serve);
2221 /* We may have loaded some modules */
2222 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
2225 #define REGISTERMQ_WILL_SERVE 1
2226 #define REGISTERMQ_IMEDIATE_UNMORPH 2
2229 Perl_Register_MQ(int serve)
2231 if (Perl_hmq_refcnt <= 0) {
2235 Perl_hmq_refcnt = 0; /* Be extra safe */
2236 DosGetInfoBlocks(&tib, &pib);
2237 if (!Perl_morph_refcnt) {
2238 Perl_os2_initial_mode = pib->pib_ultype;
2239 /* Try morphing into a PM application. */
2240 if (pib->pib_ultype != 3) /* 2 is VIO */
2241 pib->pib_ultype = 3; /* 3 is PM */
2243 Create_HMQ(-1, /* We do CancelShutdown ourselves */
2244 "Cannot create a message queue, or morph to a PM application");
2245 if ((serve & REGISTERMQ_IMEDIATE_UNMORPH)) {
2246 if (!Perl_morph_refcnt && Perl_os2_initial_mode != 3)
2247 pib->pib_ultype = Perl_os2_initial_mode;
2250 if (serve & REGISTERMQ_WILL_SERVE) {
2251 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
2252 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
2253 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
2255 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
2256 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
2258 if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH))
2259 Perl_morph_refcnt++;
2264 Perl_Serve_Messages(int force)
2269 if (Perl_hmq_servers > 0 && !force)
2271 if (Perl_hmq_refcnt <= 0)
2272 Perl_croak_nocontext("No message queue");
2273 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
2275 if (msg.msg == WM_QUIT)
2276 Perl_croak_nocontext("QUITing...");
2277 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
2283 Perl_Process_Messages(int force, I32 *cntp)
2287 if (Perl_hmq_servers > 0 && !force)
2289 if (Perl_hmq_refcnt <= 0)
2290 Perl_croak_nocontext("No message queue");
2291 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
2294 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
2295 if (msg.msg == WM_DESTROY)
2297 if (msg.msg == WM_CREATE)
2300 Perl_croak_nocontext("QUITing...");
2304 Perl_Deregister_MQ(int serve)
2306 if (serve & REGISTERMQ_WILL_SERVE)
2309 if (--Perl_hmq_refcnt <= 0) {
2310 unsigned fpflag = _control87(0,0);
2312 init_PMWIN_entries(); /* To be extra safe */
2313 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
2315 /* We may have (un)loaded some modules */
2316 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
2317 } else if ((serve & REGISTERMQ_WILL_SERVE) && Perl_hmq_servers <= 0)
2318 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); /* Last server exited */
2319 if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH) && (--Perl_morph_refcnt <= 0)) {
2320 /* Try morphing back from a PM application. */
2324 DosGetInfoBlocks(&tib, &pib);
2325 if (pib->pib_ultype == 3) /* 3 is PM */
2326 pib->pib_ultype = Perl_os2_initial_mode;
2328 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
2333 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
2334 && ((path)[2] == '/' || (path)[2] == '\\'))
2335 #define sys_is_rooted _fnisabs
2336 #define sys_is_relative _fnisrel
2337 #define current_drive _getdrive
2339 #undef chdir /* Was _chdir2. */
2340 #define sys_chdir(p) (chdir(p) == 0)
2341 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
2347 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
2349 int arg1 = SvIV(ST(0));
2350 int arg2 = SvIV(ST(1));
2351 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
2352 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
2353 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
2356 if (CheckOSError(DosError(a)))
2357 Perl_croak_nocontext("DosError(%d) failed: %s", a, os2error(Perl_rc));
2358 ST(0) = sv_newmortal();
2359 if (DOS_harderr_state >= 0)
2360 sv_setiv(ST(0), DOS_harderr_state);
2361 DOS_harderr_state = RETVAL;
2366 XS(XS_OS2_Errors2Drive)
2370 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
2374 int suppress = SvOK(sv);
2375 char *s = suppress ? SvPV(sv, n_a) : NULL;
2376 char drive = (s ? *s : 0);
2379 if (suppress && !isALPHA(drive))
2380 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
2381 if (CheckOSError(DosSuppressPopUps((suppress
2382 ? SPU_ENABLESUPPRESSION
2383 : SPU_DISABLESUPPRESSION),
2385 Perl_croak_nocontext("DosSuppressPopUps(%c) failed: %s", drive,
2387 ST(0) = sv_newmortal();
2388 if (DOS_suppression_state > 0)
2389 sv_setpvn(ST(0), &DOS_suppression_state, 1);
2390 else if (DOS_suppression_state == 0)
2391 sv_setpvn(ST(0), "", 0);
2392 DOS_suppression_state = drive;
2397 ULONG (*pDosTmrQueryFreq) (PULONG);
2398 ULONG (*pDosTmrQueryTime) (unsigned long long *);
2404 unsigned long long count;
2408 Perl_croak_nocontext("Usage: OS2::Timer()");
2410 *(PFN*)&pDosTmrQueryFreq = loadByOrdinal(ORD_DosTmrQueryFreq, 0);
2411 *(PFN*)&pDosTmrQueryTime = loadByOrdinal(ORD_DosTmrQueryTime, 0);
2412 MUTEX_LOCK(&perlos2_state_mutex);
2414 if (CheckOSError(pDosTmrQueryFreq(&freq)))
2415 croak_with_os2error("DosTmrQueryFreq");
2416 MUTEX_UNLOCK(&perlos2_state_mutex);
2418 if (CheckOSError(pDosTmrQueryTime(&count)))
2419 croak_with_os2error("DosTmrQueryTime");
2423 XSprePUSH; PUSHn(((NV)count)/freq);
2428 static const char * const dc_fields[] = {
2437 "HORIZONTAL_RESOLUTION",
2438 "VERTICAL_RESOLUTION",
2442 "SMALL_CHAR_HEIGHT",
2446 "COLOR_TABLE_SUPPORT",
2448 "FOREGROUND_MIX_SUPPORT",
2449 "BACKGROUND_MIX_SUPPORT",
2450 "VIO_LOADABLE_FONTS",
2451 "WINDOW_BYTE_ALIGNMENT",
2459 "GRAPHICS_VECTOR_SUBSET",
2461 "ADDITIONAL_GRAPHICS",
2464 "GRAPHICS_CHAR_WIDTH",
2465 "GRAPHICS_CHAR_HEIGHT",
2466 "HORIZONTAL_FONT_RES",
2467 "VERTICAL_FONT_RES",
2470 "DEVICE_POLYSET_POINTS",
2474 DevCap_dc, DevCap_hwnd
2477 HDC (*pWinOpenWindowDC) (HWND hwnd);
2478 HMF (*pDevCloseDC) (HDC hdc);
2479 HDC (*pDevOpenDC) (HAB hab, LONG lType, PCSZ pszToken, LONG lCount,
2480 PDEVOPENDATA pdopData, HDC hdcComp);
2481 BOOL (*pDevQueryCaps) (HDC hdc, LONG lStart, LONG lCount, PLONG alArray);
2488 Perl_croak_nocontext("Usage: OS2::DevCap()");
2490 /* Device Capabilities Data Buffer (10 extra w.r.t. Warp 4.5) */
2491 LONG si[CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1];
2492 int i = 0, j = 0, how = DevCap_dc;
2494 DEVOPENSTRUC doStruc= {0L, (PSZ)"DISPLAY", NULL, 0L, 0L, 0L, 0L, 0L, 0L};
2495 ULONG rc1 = NO_ERROR;
2497 static volatile int devcap_loaded;
2499 if (!devcap_loaded) {
2500 *(PFN*)&pWinOpenWindowDC = loadByOrdinal(ORD_WinOpenWindowDC, 0);
2501 *(PFN*)&pDevOpenDC = loadByOrdinal(ORD_DevOpenDC, 0);
2502 *(PFN*)&pDevCloseDC = loadByOrdinal(ORD_DevCloseDC, 0);
2503 *(PFN*)&pDevQueryCaps = loadByOrdinal(ORD_DevQueryCaps, 0);
2509 if (!items) { /* Get device contents from PM */
2510 hScreenDC = pDevOpenDC(perl_hab_GET(), OD_MEMORY, (PSZ)"*", 0,
2511 (PDEVOPENDATA)&doStruc, NULLHANDLE);
2512 if (CheckWinError(hScreenDC))
2513 croak_with_os2error("DevOpenDC() failed");
2514 } else if (how == DevCap_dc)
2515 hScreenDC = (HDC)SvIV(ST(0));
2516 else { /* DevCap_hwnd */
2518 Perl_croak(aTHX_ "Getting a window's device context without a message queue would lock PM");
2519 hwnd = (HWND)SvIV(ST(0));
2520 hScreenDC = pWinOpenWindowDC(hwnd); /* No need to DevCloseDC() */
2521 if (CheckWinError(hScreenDC))
2522 croak_with_os2error("WinOpenWindowDC() failed");
2524 if (CheckWinError(pDevQueryCaps(hScreenDC,
2525 CAPS_FAMILY, /* W3 documented caps */
2526 CAPS_DEVICE_POLYSET_POINTS
2530 if (!items && CheckWinError(pDevCloseDC(hScreenDC)))
2531 Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc));
2533 Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed");
2534 EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1));
2535 while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) {
2536 ST(j) = sv_newmortal();
2537 sv_setpv(ST(j++), dc_fields[i]);
2538 ST(j) = sv_newmortal();
2539 sv_setiv(ST(j++), si[i]);
2543 XSRETURN(2 * (CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1));
2546 LONG (*pWinQuerySysValue) (HWND hwndDesktop, LONG iSysValue);
2547 BOOL (*pWinSetSysValue) (HWND hwndDesktop, LONG iSysValue, LONG lValue);
2549 const char * const sv_keys[] = {
2601 "DESKTOPWORKAREAYTOP",
2602 "DESKTOPWORKAREAYBOTTOM",
2603 "DESKTOPWORKAREAXRIGHT",
2604 "DESKTOPWORKAREAXLEFT",
2614 "MENUROLLDOWNDELAY",
2617 "TASKLISTMOUSEACCESS",
2647 "PRINTSCREEN", /* 97, the last one on one of the DDK header */
2659 /* In recent DDK the limit is 108 */
2662 XS(XS_OS2_SysValues)
2666 Perl_croak_nocontext("Usage: OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP)");
2668 int i = 0, j = 0, which = -1;
2669 HWND hwnd = HWND_DESKTOP;
2670 static volatile int sv_loaded;
2674 *(PFN*)&pWinQuerySysValue = loadByOrdinal(ORD_WinQuerySysValue, 0);
2679 hwnd = (HWND)SvIV(ST(1));
2681 which = (int)SvIV(ST(0));
2683 EXTEND(SP,2*C_ARRAY_LENGTH(sv_keys));
2684 while (i < C_ARRAY_LENGTH(sv_keys)) {
2686 RETVAL = pWinQuerySysValue(hwnd, i);
2688 && !(sv_keys[i][0] >= '0' && sv_keys[i][0] <= '9'
2689 && i <= SV_PRINTSCREEN) ) {
2692 if (i > SV_PRINTSCREEN)
2693 break; /* May be not present on older systems */
2694 croak_with_os2error("SysValues():");
2698 ST(j) = sv_newmortal();
2699 sv_setpv(ST(j++), sv_keys[i]);
2700 ST(j) = sv_newmortal();
2701 sv_setiv(ST(j++), RETVAL);
2709 RETVAL = pWinQuerySysValue(hwnd, which);
2713 croak_with_os2error("SysValues():");
2715 XSprePUSH; PUSHi((IV)RETVAL);
2720 XS(XS_OS2_SysValues_set)
2723 if (items < 2 || items > 3)
2724 Perl_croak_nocontext("Usage: OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP)");
2726 int which = (int)SvIV(ST(0));
2727 LONG val = (LONG)SvIV(ST(1));
2728 HWND hwnd = HWND_DESKTOP;
2729 static volatile int svs_loaded;
2732 *(PFN*)&pWinSetSysValue = loadByOrdinal(ORD_WinSetSysValue, 0);
2737 hwnd = (HWND)SvIV(ST(2));
2738 if (CheckWinError(pWinSetSysValue(hwnd, which, val)))
2739 croak_with_os2error("SysValues_set()");
2744 #define QSV_MAX_WARP3 QSV_MAX_COMP_LENGTH
2746 static const char * const si_fields[] = {
2748 "MAX_TEXT_SESSIONS",
2752 "DYN_PRI_VARIATION",
2770 "FOREGROUND_FS_SESSION",
2771 "FOREGROUND_PROCESS", /* Warp 3 toolkit defines up to this */
2776 "VIRTUALADDRESSLIMIT",
2777 "INT10ENABLED", /* From $TOOLKIT-ddk\DDK\video\rel\os2c\include\base\os2\bsedos.h */
2784 Perl_croak_nocontext("Usage: OS2::SysInfo()");
2786 /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
2787 ULONG si[C_ARRAY_LENGTH(si_fields) + 10];
2788 APIRET rc = NO_ERROR; /* Return code */
2789 int i = 0, j = 0, last = QSV_MAX_WARP3;
2791 if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */
2792 last, /* info for Warp 3 */
2795 croak_with_os2error("DosQuerySysInfo() failed");
2796 while (last++ <= C_ARRAY_LENGTH(si)) {
2797 if (CheckOSError(DosQuerySysInfo(last, last, /* One entry only */
2800 if (Perl_rc != ERROR_INVALID_PARAMETER)
2801 croak_with_os2error("DosQuerySysInfo() failed");
2808 ST(j) = sv_newmortal();
2809 sv_setpv(ST(j++), si_fields[i]);
2810 ST(j) = sv_newmortal();
2811 sv_setiv(ST(j++), si[i]);
2818 XS(XS_OS2_SysInfoFor)
2821 int count = (items == 2 ? (int)SvIV(ST(1)) : 1);
2823 if (items < 1 || items > 2)
2824 Perl_croak_nocontext("Usage: OS2::SysInfoFor(id[,count])");
2826 /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
2827 ULONG si[C_ARRAY_LENGTH(si_fields) + 10];
2828 APIRET rc = NO_ERROR; /* Return code */
2830 int start = (int)SvIV(ST(0));
2832 if (count > C_ARRAY_LENGTH(si) || count <= 0)
2833 Perl_croak(aTHX_ "unexpected count %d for OS2::SysInfoFor()", count);
2834 if (CheckOSError(DosQuerySysInfo(start,
2838 croak_with_os2error("DosQuerySysInfo() failed");
2841 ST(i) = sv_newmortal();
2842 sv_setiv(ST(i), si[i]);
2849 XS(XS_OS2_BootDrive)
2853 Perl_croak_nocontext("Usage: OS2::BootDrive()");
2855 ULONG si[1] = {0}; /* System Information Data Buffer */
2856 APIRET rc = NO_ERROR; /* Return code */
2860 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
2861 (PVOID)si, sizeof(si))))
2862 croak_with_os2error("DosQuerySysInfo() failed");
2863 c = 'a' - 1 + si[0];
2864 sv_setpvn(TARG, &c, 1);
2865 XSprePUSH; PUSHTARG;
2873 if (items > 2) /* Defaults as for WinAlarm(ERROR) */
2874 Perl_croak_nocontext("Usage: OS2::Beep(freq = 440, ms = 100)");
2876 ULONG freq = (items > 0 ? (ULONG)SvUV(ST(0)) : 440);
2877 ULONG ms = (items > 1 ? (ULONG)SvUV(ST(1)) : 100);
2880 if (CheckOSError(DosBeep(freq, ms)))
2881 croak_with_os2error("SysValues_set()");
2892 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
2894 bool serve = SvOK(ST(0));
2895 unsigned long pmq = perl_hmq_GET(serve);
2898 XSprePUSH; PUSHi((IV)pmq);
2903 XS(XS_OS2_UnMorphPM)
2907 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
2909 bool serve = SvOK(ST(0));
2911 perl_hmq_UNSET(serve);
2916 XS(XS_OS2_Serve_Messages)
2920 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
2922 bool force = SvOK(ST(0));
2923 unsigned long cnt = Perl_Serve_Messages(force);
2926 XSprePUSH; PUSHi((IV)cnt);
2931 XS(XS_OS2_Process_Messages)
2934 if (items < 1 || items > 2)
2935 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
2937 bool force = SvOK(ST(0));
2945 (void)SvIV(sv); /* Force SvIVX */
2947 Perl_croak_nocontext("Can't upgrade count to IV");
2949 cnt = Perl_Process_Messages(force, &cntr);
2952 cnt = Perl_Process_Messages(force, NULL);
2954 XSprePUSH; PUSHi((IV)cnt);
2959 XS(XS_Cwd_current_drive)
2963 Perl_croak_nocontext("Usage: Cwd::current_drive()");
2968 RETVAL = current_drive();
2969 sv_setpvn(TARG, (char *)&RETVAL, 1);
2970 XSprePUSH; PUSHTARG;
2975 XS(XS_Cwd_sys_chdir)
2979 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
2982 char * path = (char *)SvPV(ST(0),n_a);
2985 RETVAL = sys_chdir(path);
2986 ST(0) = boolSV(RETVAL);
2987 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2992 XS(XS_Cwd_change_drive)
2996 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
2999 char d = (char)*SvPV(ST(0),n_a);
3002 RETVAL = change_drive(d);
3003 ST(0) = boolSV(RETVAL);
3004 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3009 XS(XS_Cwd_sys_is_absolute)
3013 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
3016 char * path = (char *)SvPV(ST(0),n_a);
3019 RETVAL = sys_is_absolute(path);
3020 ST(0) = boolSV(RETVAL);
3021 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3026 XS(XS_Cwd_sys_is_rooted)
3030 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
3033 char * path = (char *)SvPV(ST(0),n_a);
3036 RETVAL = sys_is_rooted(path);
3037 ST(0) = boolSV(RETVAL);
3038 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3043 XS(XS_Cwd_sys_is_relative)
3047 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
3050 char * path = (char *)SvPV(ST(0),n_a);
3053 RETVAL = sys_is_relative(path);
3054 ST(0) = boolSV(RETVAL);
3055 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3064 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
3069 /* Can't use TARG, since tainting behaves differently */
3070 RETVAL = _getcwd2(p, MAXPATHLEN);
3071 ST(0) = sv_newmortal();
3072 sv_setpv(ST(0), RETVAL);
3073 #ifndef INCOMPLETE_TAINTS
3074 SvTAINTED_on(ST(0));
3080 XS(XS_Cwd_sys_abspath)
3084 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path = '.', dir = NULL)");
3087 char * path = items ? (char *)SvPV(ST(0),n_a) : ".";
3088 char * dir, *s, *t, *e;
3097 dir = (char *)SvPV(ST(1),n_a);
3099 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
3103 if (_abspath(p, path, MAXPATHLEN) == 0) {
3109 /* Absolute with drive: */
3110 if ( sys_is_absolute(path) ) {
3111 if (_abspath(p, path, MAXPATHLEN) == 0) {
3116 } else if (path[0] == '/' || path[0] == '\\') {
3117 /* Rooted, but maybe on different drive. */
3118 if (isALPHA(dir[0]) && dir[1] == ':' ) {
3119 char p1[MAXPATHLEN];
3121 /* Need to prepend the drive. */
3124 Copy(path, p1 + 2, strlen(path) + 1, char);
3126 if (_abspath(p, p1, MAXPATHLEN) == 0) {
3131 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3137 /* Either path is relative, or starts with a drive letter. */
3138 /* If the path starts with a drive letter, then dir is
3140 a/b) it is absolute/x:relative on the same drive.
3141 c) path is on current drive, and dir is rooted
3142 In all the cases it is safe to drop the drive part
3144 if ( !sys_is_relative(path) ) {
3145 if ( ( ( sys_is_absolute(dir)
3146 || (isALPHA(dir[0]) && dir[1] == ':'
3147 && strnicmp(dir, path,1) == 0))
3148 && strnicmp(dir, path,1) == 0)
3149 || ( !(isALPHA(dir[0]) && dir[1] == ':')
3150 && toupper(path[0]) == current_drive())) {
3152 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3153 RETVAL = p; goto done;
3155 RETVAL = NULL; goto done;
3159 /* Need to prepend the absolute path of dir. */
3160 char p1[MAXPATHLEN];
3162 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
3165 if (p1[ l - 1 ] != '/') {
3169 Copy(path, p1 + l, strlen(path) + 1, char);
3170 if (_abspath(p, p1, MAXPATHLEN) == 0) {
3184 /* Backslashes are already converted to slashes. */
3185 /* Remove trailing slashes */
3187 while (l > 0 && RETVAL[l-1] == '/')
3189 ST(0) = sv_newmortal();
3190 sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
3191 /* Remove duplicate slashes, skipping the first three, which
3192 may be parts of a server-based path */
3193 s = t = 3 + SvPV_force(sv, n_a);
3195 /* Do not worry about multibyte chars here, this would contradict the
3196 eventual UTFization, and currently most other places break too... */
3198 if (s[0] == t[-1] && s[0] == '/')
3199 s++; /* Skip duplicate / */
3205 SvCUR_set(sv, t - SvPVX(sv));
3207 #ifndef INCOMPLETE_TAINTS
3209 SvTAINTED_on(ST(0));
3214 typedef APIRET (*PELP)(PSZ path, ULONG type);
3216 /* Kernels after 2000/09/15 understand this too: */
3217 #ifndef LIBPATHSTRICT
3218 # define LIBPATHSTRICT 3
3222 ExtLIBPATH(ULONG ord, PSZ path, IV type)
3225 PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */
3230 what = BEGIN_LIBPATH;
3232 what = LIBPATHSTRICT;
3233 return (*(PELP)f)(path, what);
3236 #define extLibpath(to,type) \
3237 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
3239 #define extLibpath_set(p,type) \
3240 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
3242 XS(XS_Cwd_extLibpath)
3245 if (items < 0 || items > 1)
3246 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
3260 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
3261 RETVAL = extLibpath(to, type);
3262 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
3263 Perl_croak_nocontext("panic Cwd::extLibpath parameter");
3264 sv_setpv(TARG, RETVAL);
3265 XSprePUSH; PUSHTARG;
3270 XS(XS_Cwd_extLibpath_set)
3273 if (items < 1 || items > 2)
3274 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
3277 char * s = (char *)SvPV(ST(0),n_a);
3288 RETVAL = extLibpath_set(s, type);
3289 ST(0) = boolSV(RETVAL);
3290 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3295 /* Input: Address, BufLen
3297 DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3298 ULONG * Offset, ULONG Address);
3301 DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
3302 (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3303 ULONG * Offset, ULONG Address),
3304 (hmod, obj, BufLen, Buf, Offset, Address))
3306 enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full,
3307 mod_name_C_function = 0x100, mod_name_HMODULE = 0x200};
3310 module_name_at(void *pp, enum module_name_how how)
3313 char buf[MAXPATHLEN];
3316 ULONG obj, offset, rc, addr = (ULONG)pp;
3318 if (how & mod_name_HMODULE) {
3319 if ((how & ~mod_name_HMODULE) == mod_name_shortname)
3320 Perl_croak(aTHX_ "Can't get short module name from a handle");
3322 how &= ~mod_name_HMODULE;
3323 } else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr))
3324 return &PL_sv_undef;
3325 if (how == mod_name_handle)
3326 return newSVuv(mod);
3328 if ( how != mod_name_shortname
3329 && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
3330 return &PL_sv_undef;
3336 return newSVpv(buf, 0);
3340 module_name_of_cv(SV *cv, enum module_name_how how)
3342 if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
3345 if (how & mod_name_C_function)
3346 return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function);
3347 else if (how & mod_name_HMODULE)
3348 return module_name_at((void*)SvIV(cv), how);
3349 Perl_croak(aTHX_ "Not an XSUB reference");
3351 return module_name_at(CvXSUB(SvRV(cv)), how);
3354 /* Find module name to which *this* subroutine is compiled */
3355 #define module_name(how) module_name_at(&module_name_at, how)
3361 Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
3367 how = mod_name_full;
3369 how = (int)SvIV(ST(0));
3372 RETVAL = module_name(how);
3374 RETVAL = module_name_of_cv(ST(1), how);
3381 DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo,
3382 (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum),
3383 (r1, r2, buf, szbuf, fnum))
3385 XS(XS_OS2__headerInfo)
3388 if (items > 4 || items < 2)
3389 Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])");
3391 ULONG req = (ULONG)SvIV(ST(0));
3392 STRLEN size = (STRLEN)SvIV(ST(1)), n_a;
3393 ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0);
3394 ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0);
3397 Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size);
3398 ST(0) = newSVpvn("",0);
3399 SvGROW(ST(0), size + 1);
3402 if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req))
3403 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3404 req, size, handle, offset, os2error(Perl_rc));
3405 SvCUR_set(ST(0), size);
3411 #define DQHI_QUERYLIBPATHSIZE 4
3412 #define DQHI_QUERYLIBPATH 5
3418 Perl_croak(aTHX_ "Usage: OS2::libPath()");
3423 if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size),
3424 DQHI_QUERYLIBPATHSIZE))
3425 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3426 DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0,
3428 ST(0) = newSVpvn("",0);
3429 SvGROW(ST(0), size + 1);
3432 /* We should be careful: apparently, this entry point does not
3433 pay attention to the size argument, so may overwrite
3435 if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size,
3437 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3438 DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc));
3439 SvCUR_set(ST(0), size);
3445 #define get_control87() _control87(0,0)
3446 #define set_control87 _control87
3448 XS(XS_OS2__control87)
3452 Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
3454 unsigned new = (unsigned)SvIV(ST(0));
3455 unsigned mask = (unsigned)SvIV(ST(1));
3459 RETVAL = _control87(new, mask);
3460 XSprePUSH; PUSHi((IV)RETVAL);
3470 if (items < 0 || items > 1)
3471 Perl_croak(aTHX_ "Usage: OS2::mytype([which])");
3473 which = (int)SvIV(ST(0));
3480 RETVAL = os2_mytype; /* Reset after fork */
3483 RETVAL = os2_mytype_ini; /* Before any fork */
3486 RETVAL = Perl_os2_initial_mode; /* Before first morphing */
3489 RETVAL = my_type(); /* Morphed type */
3492 Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which);
3494 XSprePUSH; PUSHi((IV)RETVAL);
3500 XS(XS_OS2_mytype_set)
3506 type = (int)SvIV(ST(0));
3508 Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)");
3514 XS(XS_OS2_get_control87)
3518 Perl_croak(aTHX_ "Usage: OS2::get_control87()");
3523 RETVAL = get_control87();
3524 XSprePUSH; PUSHi((IV)RETVAL);
3530 XS(XS_OS2_set_control87)
3533 if (items < 0 || items > 2)
3534 Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
3544 new = (unsigned)SvIV(ST(0));
3550 mask = (unsigned)SvIV(ST(1));
3553 RETVAL = set_control87(new, mask);
3554 XSprePUSH; PUSHi((IV)RETVAL);
3559 XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */
3562 if (items < 0 || items > 1)
3563 Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)");
3572 delta = (LONG)SvIV(ST(0));
3574 if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL)))
3575 croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error");
3576 XSprePUSH; PUSHu((UV)RETVAL);
3584 char *file = __FILE__;
3588 if (_emx_env & 0x200) { /* OS/2 */
3589 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
3590 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
3591 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
3593 newXS("OS2::Error", XS_OS2_Error, file);
3594 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
3595 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
3596 newXSproto("OS2::DevCap", XS_OS2_DevCap, file, ";$$");
3597 newXSproto("OS2::SysInfoFor", XS_OS2_SysInfoFor, file, "$;$");
3598 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
3599 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
3600 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
3601 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
3602 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
3603 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
3604 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
3605 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
3606 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
3607 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
3608 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
3609 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
3610 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
3611 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
3612 newXS("OS2::replaceModule", XS_OS2_replaceModule, file);
3613 newXS("OS2::perfSysCall", XS_OS2_perfSysCall, file);
3614 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
3615 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
3616 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
3617 newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
3618 newXSproto("OS2::mytype", XS_OS2_mytype, file, ";$");
3619 newXSproto("OS2::mytype_set", XS_OS2_mytype_set, file, "$");
3620 newXSproto("OS2::_headerInfo", XS_OS2__headerInfo, file, "$$;$$");
3621 newXSproto("OS2::libPath", XS_OS2_libPath, file, "");
3622 newXSproto("OS2::Timer", XS_OS2_Timer, file, "");
3623 newXSproto("OS2::incrMaxFHandles", XS_OS2_incrMaxFHandles, file, ";$");
3624 newXSproto("OS2::SysValues", XS_OS2_SysValues, file, ";$$");
3625 newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$");
3626 newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$");
3627 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
3630 sv_setiv(GvSV(gv), 1);
3632 gv = gv_fetchpv("OS2::is_static", TRUE, SVt_PV);
3635 sv_setiv(GvSV(gv), 1);
3637 gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
3639 sv_setiv(GvSV(gv), exe_is_aout());
3640 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
3642 sv_setiv(GvSV(gv), _emx_rev);
3643 sv_setpv(GvSV(gv), _emx_vprt);
3645 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
3647 sv_setiv(GvSV(gv), _emx_env);
3648 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
3650 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
3651 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
3653 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
3658 extern void _emx_init(void*);
3660 static void jmp_out_of_atexit(void);
3662 #define FORCE_EMX_INIT_CONTRACT_ARGV 1
3663 #define FORCE_EMX_INIT_INSTALL_ATEXIT 2
3666 my_emx_init(void *layout) {
3667 static volatile void *old_esp = 0; /* Cannot be on stack! */
3669 /* Can't just call emx_init(), since it moves the stack pointer */
3670 /* It also busts a lot of registers, so be extra careful */
3678 "popf\n" : : "r" (layout), "m" (old_esp) );
3681 struct layout_table_t {
3702 static ULONG osv_res; /* Cannot be on stack! */
3704 /* Can't just call __os_version(), since it does not follow C
3705 calling convention: it busts a lot of registers, so be extra careful */
3708 "call ___os_version\n"
3711 "popf\n" : "=m" (osv_res) );
3717 force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
3719 /* Calling emx_init() will bust the top of stack: it installs an
3720 exception handler and puts argv data there. */
3721 char *oldarg, *oldenv;
3722 void *oldstackend, *oldstack;
3725 ULONG rc, error = 0, out;
3727 static struct layout_table_t layout_table;
3729 char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
3731 EXCEPTIONREGISTRATIONRECORD xreg;
3735 layout_table.os2_dll = (ULONG)&os2_dll_fake;
3736 layout_table.flags = 0x02000002; /* flags: application, OMF */
3738 DosGetInfoBlocks(&tib, &pib);
3739 oldarg = pib->pib_pchcmd;
3740 oldenv = pib->pib_pchenv;
3741 oldstack = tib->tib_pstack;
3742 oldstackend = tib->tib_pstacklimit;
3744 /* Minimize the damage to the stack via reducing the size of argv. */
3745 if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
3746 pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */
3747 pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */
3750 newstack = alloca(sizeof(*newstack));
3751 /* Emulate the stack probe */
3752 s = ((char*)newstack) + sizeof(*newstack);
3753 while (s > (char*)newstack) {
3758 /* Reassigning stack is documented to work */
3759 tib->tib_pstack = (void*)newstack;
3760 tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
3762 /* Can't just call emx_init(), since it moves the stack pointer */
3763 my_emx_init((void*)&layout_table);
3765 /* Remove the exception handler, cannot use it - too low on the stack.
3766 Check whether it is inside the new stack. */
3768 if (tib->tib_pexchain >= tib->tib_pstacklimit
3769 || tib->tib_pexchain < tib->tib_pstack) {
3772 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
3773 (unsigned long)tib->tib_pstack,
3774 (unsigned long)tib->tib_pexchain,
3775 (unsigned long)tib->tib_pstacklimit);
3778 if (tib->tib_pexchain != &(newstack->xreg)) {
3779 sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
3780 (unsigned long)tib->tib_pexchain,
3781 (unsigned long)&(newstack->xreg));
3783 rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
3785 sprintf(buf + strlen(buf),
3786 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
3789 /* ExceptionRecords should be on stack, in a correct order. Sigh... */
3790 preg->prev_structure = 0;
3791 preg->ExceptionHandler = _emx_exception;
3792 rc = DosSetExceptionHandler(preg);
3794 sprintf(buf + strlen(buf),
3795 "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
3796 DosWrite(2, buf, strlen(buf), &out);
3797 emx_exception_init = 1; /* Do it around spawn*() calls */
3800 emx_exception_init = 1; /* Do it around spawn*() calls */
3803 /* Restore the damage */
3804 pib->pib_pchcmd = oldarg;
3805 pib->pib_pchcmd = oldenv;
3806 tib->tib_pstacklimit = oldstackend;
3807 tib->tib_pstack = oldstack;
3808 emx_runtime_init = 1;
3810 DosWrite(2, buf, strlen(buf), &out);
3816 jmp_out_of_atexit(void)
3818 if (longjmp_at_exit)
3819 longjmp(at_exit_buf, 1);
3822 extern void _CRT_term(void);
3825 Perl_OS2_term(void **p, int exitstatus, int flags)
3827 if (!emx_runtime_secondary)
3830 /* The principal executable is not running the same CRTL, so there
3831 is nobody to shutdown *this* CRTL except us... */
3832 if (flags & FORCE_EMX_DEINIT_EXIT) {
3833 if (p && !emx_exception_init)
3834 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
3835 /* Do not run the executable's CRTL's termination routines */
3836 exit(exitstatus); /* Run at-exit, flush buffers, etc */
3838 /* Run at-exit list, and jump out at the end */
3839 if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
3840 longjmp_at_exit = 1;
3841 exit(exitstatus); /* The first pass through "if" */
3844 /* Get here if we managed to jump out of exit(), or did not run atexit. */
3845 longjmp_at_exit = 0; /* Maybe exit() is called again? */
3846 #if 0 /* _atexit_n is not exported */
3847 if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
3848 _atexit_n = 0; /* Remove the atexit() handlers */
3850 /* Will segfault on program termination if we leave this dangling... */
3851 if (p && !emx_exception_init)
3852 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
3853 /* Typically there is no need to do this, done from _DLL_InitTerm() */
3854 if (flags & FORCE_EMX_DEINIT_CRT_TERM)
3855 _CRT_term(); /* Flush buffers, etc. */
3856 /* Now it is a good time to call exit() in the caller's CRTL... */
3859 #include <emx/startup.h>
3861 extern ULONG __os_version(); /* See system.doc */
3864 check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
3866 ULONG v_crt, v_emx, count = 0, rc, rc1, maybe_inited = 0;
3867 static HMTX hmtx_emx_init = NULLHANDLE;
3868 static int emx_init_done = 0;
3870 /* If _environ is not set, this code sits in a DLL which
3871 uses a CRT DLL which not compatible with the executable's
3872 CRT library. Some parts of the DLL are not initialized.
3874 if (_environ != NULL)
3875 return; /* Properly initialized */
3877 /* It is not DOS, so we may use OS/2 API now */
3878 /* Some data we manipulate is static; protect ourselves from
3879 calling the same API from a different thread. */
3880 DosEnterMustComplete(&count);
3882 rc1 = DosEnterCritSec();
3884 rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/
3889 hmtx_emx_init = NULLHANDLE;
3891 if (rc1 == NO_ERROR)
3893 DosExitMustComplete(&count);
3895 while (maybe_inited) { /* Other thread did or is doing the same now */
3898 rc = DosRequestMutexSem(hmtx_emx_init,
3899 (ULONG) SEM_INDEFINITE_WAIT); /* Timeout (none) */
3900 if (rc == ERROR_INTERRUPT)
3902 if (rc != NO_ERROR) {
3907 "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc);
3908 DosWrite(2, buf, strlen(buf), &out);
3911 DosReleaseMutexSem(hmtx_emx_init);
3915 /* If the executable does not use EMX.DLL, EMX.DLL is not completely
3916 initialized either. Uninitialized EMX.DLL returns 0 in the low
3917 nibble of __os_version(). */
3918 v_emx = my_os_version();
3920 /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
3921 (=>_CRT_init=>_entry2) via a call to __os_version(), then
3922 reset when the EXE initialization code calls _text=>_init=>_entry2.
3923 The first time they are wrongly set to 0; the second time the
3924 EXE initialization code had already called emx_init=>initialize1
3925 which correctly set version_major, version_minor used by
3927 v_crt = (_osmajor | _osminor);
3929 if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */
3930 force_init_emx_runtime( preg,
3931 FORCE_EMX_INIT_CONTRACT_ARGV
3932 | FORCE_EMX_INIT_INSTALL_ATEXIT );
3933 emx_wasnt_initialized = 1;
3934 /* Update CRTL data basing on now-valid EMX runtime data */
3935 if (!v_crt) { /* The only wrong data are the versions. */
3936 v_emx = my_os_version(); /* *Now* it works */
3937 *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
3938 *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
3941 emx_runtime_secondary = 1;
3942 /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
3943 atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */
3945 if (env == NULL) { /* Fetch from the process info block */
3951 DosGetInfoBlocks(&tib, &pib);
3952 e = pib->pib_pchenv;
3953 while (*e) { /* Get count */
3955 e = e + strlen(e) + 1;
3957 New(1307, env, c + 1, char*);
3959 e = pib->pib_pchenv;
3962 e = e + strlen(e) + 1;
3966 _environ = _org_environ = env;
3969 DosReleaseMutexSem(hmtx_emx_init);
3972 #define ENTRY_POINT 0x10000
3977 struct layout_table_t *layout;
3978 if (emx_wasnt_initialized)
3980 /* Now we know that the principal executable is an EMX application
3981 - unless somebody did already play with delayed initialization... */
3982 /* With EMX applications to determine whether it is AOUT one needs
3983 to examine the start of the executable to find "layout" */
3984 if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */
3985 || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */
3986 || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */
3987 || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */
3988 return 0; /* ! EMX executable */
3990 Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
3991 return !(layout->flags & 2);
3995 Perl_OS2_init(char **env)
3997 Perl_OS2_init3(env, 0, 0);
4001 Perl_OS2_init3(char **env, void **preg, int flags)
4005 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
4008 check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
4011 OS2_Perl_data.xs_init = &Xs_OS2_init;
4012 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
4013 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
4014 strcpy(PL_sh_path, SH_PATH);
4015 PL_sh_path[0] = shell[0];
4016 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
4017 int l = strlen(shell), i;
4018 if (shell[l-1] == '/' || shell[l-1] == '\\') {
4021 New(1304, PL_sh_path, l + 8, char);
4022 strncpy(PL_sh_path, shell, l);
4023 strcpy(PL_sh_path + l, "/sh.exe");
4024 for (i = 0; i < l; i++) {
4025 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
4028 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
4029 MUTEX_INIT(&start_thread_mutex);
4030 MUTEX_INIT(&perlos2_state_mutex);
4032 os2_mytype = my_type(); /* Do it before morphing. Needed? */
4033 os2_mytype_ini = os2_mytype;
4034 Perl_os2_initial_mode = -1; /* Uninit */
4035 /* Some DLLs reset FP flags on load. We may have been linked with them */
4036 _control87(MCW_EM, MCW_EM);
4042 static ULONG max_fh = 0;
4044 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
4045 if (fd >= max_fh) { /* Renew */
4048 if (DosSetRelMaxFH(&delta, &max_fh)) /* Assume it OK??? */
4054 /* Kernels up to Oct 2003 trap on (invalid) dup(max_fh); [off-by-one + double fault]. */
4056 dup2(int from, int to)
4058 if (fd_ok(from < to ? to : from))
4059 return _dup2(from, to);
4077 my_tmpnam (char *str)
4079 char *p = getenv("TMP"), *tpath;
4081 if (!p) p = getenv("TEMP");
4082 tpath = tempnam(p, "pltmp");
4096 if (s.st_mode & S_IWOTH) {
4099 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
4105 /* EMX flavors do not tolerate trailing slashes. t/op/mkdir.t has many
4106 trailing slashes, so we need to support this as well. */
4109 my_rmdir (__const__ char *s)
4113 STRLEN l = strlen(s);
4116 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
4118 New(1305, buf, l + 1, char);
4120 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
4134 my_mkdir (__const__ char *s, long perm)
4138 STRLEN l = strlen(s);
4141 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
4143 New(1305, buf, l + 1, char);
4145 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
4150 rc = mkdir(s, perm);
4158 /* This code was contributed by Rocco Caputo. */
4160 my_flock(int handle, int o)
4162 FILELOCK rNull, rFull;
4163 ULONG timeout, handle_type, flag_word;
4165 int blocking, shared;
4166 static int use_my_flock = -1;
4168 if (use_my_flock == -1) {
4169 MUTEX_LOCK(&perlos2_state_mutex);
4170 if (use_my_flock == -1) {
4171 char *s = getenv("USE_PERL_FLOCK");
4173 use_my_flock = atoi(s);
4177 MUTEX_UNLOCK(&perlos2_state_mutex);
4179 if (!(_emx_env & 0x200) || !use_my_flock)
4180 return flock(handle, o); /* Delegate to EMX. */
4182 /* is this a file? */
4183 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
4184 (handle_type & 0xFF))
4189 /* set lock/unlock ranges */
4190 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
4191 rFull.lRange = 0x7FFFFFFF;
4192 /* set timeout for blocking */
4193 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
4194 /* shared or exclusive? */
4195 shared = (o & LOCK_SH) ? 1 : 0;
4196 /* do not block the unlock */
4197 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
4198 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
4203 case ERROR_INVALID_HANDLE:
4206 case ERROR_SHARING_BUFFER_EXCEEDED:
4209 case ERROR_LOCK_VIOLATION:
4210 break; /* not an error */
4211 case ERROR_INVALID_PARAMETER:
4212 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
4213 case ERROR_READ_LOCKS_NOT_SUPPORTED:
4216 case ERROR_INTERRUPT:
4224 /* lock may block */
4225 if (o & (LOCK_SH | LOCK_EX)) {
4226 /* for blocking operations */
4240 case ERROR_INVALID_HANDLE:
4243 case ERROR_SHARING_BUFFER_EXCEEDED:
4246 case ERROR_LOCK_VIOLATION:
4248 errno = EWOULDBLOCK;
4252 case ERROR_INVALID_PARAMETER:
4253 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
4254 case ERROR_READ_LOCKS_NOT_SUPPORTED:
4257 case ERROR_INTERRUPT:
4264 /* give away timeslice */
4276 if (_my_pwent == -1) {
4277 char *s = getenv("USE_PERL_PWENT");
4279 _my_pwent = atoi(s);
4293 if (!use_my_pwent()) {
4294 setpwent(); /* Delegate to EMX. */
4303 if (!use_my_pwent()) {
4304 endpwent(); /* Delegate to EMX. */
4312 if (!use_my_pwent())
4313 return getpwent(); /* Delegate to EMX. */
4315 return 0; /* Return one entry only */
4334 return 0; /* Return one entry only */
4341 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
4342 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
4344 static struct passwd *
4345 passw_wrap(struct passwd *p)
4349 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
4352 s = getenv("PW_PASSWD");
4354 s = (char*)pw_p; /* Make match impossible */
4361 my_getpwuid (uid_t id)
4363 return passw_wrap(getpwuid(id));
4367 my_getpwnam (__const__ char *n)
4369 return passw_wrap(getpwnam(n));
4373 gcvt_os2 (double value, int digits, char *buffer)
4375 double absv = value > 0 ? value : -value;
4376 /* EMX implementation is lousy between 0.1 and 0.0001 (uses exponents below
4377 0.1), 1-digit stuff is ok below 0.001; multi-digit below 0.0001. */
4381 buggy = (absv < 1000 && (absv >= 10 || (absv > 1 && floor(absv) != absv)));
4386 sprintf(pat, "%%.%dg", digits);
4387 sprintf(buffer, pat, value);
4390 return gcvt (value, digits, buffer);
4394 int fork_with_resources()
4396 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
4398 void *ctx = PERL_GET_CONTEXT;
4400 unsigned fpflag = _control87(0,0);
4403 if (rc == 0) { /* child */
4404 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
4405 ALLOC_THREAD_KEY; /* Acquire the thread-local memory */
4406 PERL_SET_CONTEXT(ctx); /* Reinit the thread-local memory */
4409 { /* Reload loaded-on-demand DLLs */
4410 struct dll_handle_t *dlls = dll_handles;
4412 while (dlls->modname) {
4413 char dllname[260], fail[260];
4416 if (!dlls->handle) { /* Was not loaded */
4420 /* It was loaded in the parent. We need to reload it. */
4422 rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname);
4424 Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx",
4425 dlls->modname, (int)dlls->handle, rc, rc);
4429 rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle);
4431 Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'",
4437 { /* Support message queue etc. */
4438 os2_mytype = my_type();
4439 /* Apparently, subprocesses (in particular, fork()) do not
4440 inherit the morphed state, so os2_mytype is the same as
4443 if (Perl_os2_initial_mode != -1
4444 && Perl_os2_initial_mode != os2_mytype) {
4449 (void)_obtain_Perl_HAB;
4450 if (Perl_hmq_refcnt) {
4453 Create_HMQ(Perl_hmq_servers != 0,
4454 "Cannot create a message queue on fork");
4457 /* We may have loaded some modules */
4458 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */