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>
15 #include <sys/emxload.h>
17 #include <sys/uflags.h>
20 * Various Unix compatibility functions for OS/2
31 #define PERLIO_NOT_STDIO 0
36 enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full,
37 mod_name_C_function = 0x100, mod_name_HMODULE = 0x200};
39 /* Find module name to which *this* subroutine is compiled */
40 #define module_name(how) module_name_at(&module_name_at, how)
42 static SV* module_name_at(void *pp, enum module_name_how how);
45 croak_with_os2error(char *s)
47 Perl_croak_nocontext("%s: %s", s, os2error(Perl_rc));
50 struct PMWIN_entries_t PMWIN_entries;
52 /*****************************************************************************/
53 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
61 static struct dll_handle_t dll_handles[] = {
87 #define doscalls_handle (dll_handles[dll_handle_doscalls])
88 #define tcp_handle (dll_handles[dll_handle_tcp32dll])
89 #define pmwin_handle (dll_handles[dll_handle_pmwin])
90 #define rexx_handle (dll_handles[dll_handle_rexx])
91 #define rexxapi_handle (dll_handles[dll_handle_rexxapi])
92 #define sesmgr_handle (dll_handles[dll_handle_sesmgr])
93 #define pmshapi_handle (dll_handles[dll_handle_pmshapi])
94 #define pmwp_handle (dll_handles[dll_handle_pmwp])
95 #define pmgpi_handle (dll_handles[dll_handle_pmgpi])
97 /* The following local-scope data is not yet included:
98 fargs.140 // const => OK
99 ino.165 // locked - and the access is almost cosmetic
100 layout_table.260 // startup only, locked
101 osv_res.257 // startup only, locked
102 old_esp.254 // startup only, locked
103 priors // const ==> OK
104 use_my_flock.283 // locked
105 emx_init_done.268 // locked
106 dll_handles // locked
107 hmtx_emx_init.267 // THIS is the lock for startup
108 perlos2_state_mutex // THIS is the lock for all the rest
110 perlos2_state // see below
112 /* The following global-scope data is not yet included:
114 pthreads_states // const now?
116 thread_join_count // protected
117 thread_join_data // protected
122 Perl_OS2_init3() - should it be protected?
124 OS2_Perl_data_t OS2_Perl_data;
126 static struct perlos2_state_t {
127 int po2__my_pwent; /* = -1; */
128 int po2_DOS_harderr_state; /* = -1; */
129 signed char po2_DOS_suppression_state; /* = -1; */
131 PFN po2_ExtFCN[ORD_NENTRIES]; /* Labeled by ord ORD_*. */
132 /* struct PMWIN_entries_t po2_PMWIN_entries; */
134 int po2_emx_wasnt_initialized;
146 char po2_mangle_ret[STATIC_FILE_LENGTH+1];
147 ULONG po2_os2_dll_fake;
148 ULONG po2_os2_mytype;
149 ULONG po2_os2_mytype_ini;
150 int po2_pidtid_lookup;
151 struct passwd po2_pw;
154 char po2_pthreads_state_buf[80];
155 char po2_os2error_buf[300];
156 /* There is no big sense to make it thread-specific, since signals
157 are delivered to thread 1 only. XXXX Maybe make it into an array? */
159 int po2_spawn_killed;
161 jmp_buf po2_at_exit_buf;
162 int po2_longjmp_at_exit;
163 int po2_emx_runtime_init; /* If 1, we need to manually init it */
164 int po2_emx_exception_init; /* If 1, we need to manually set it */
165 int po2_emx_runtime_secondary;
166 char* (*po2_perllib_mangle_installed)(char *s, unsigned int l);
167 char* po2_perl_sh_installed;
168 PGINFOSEG po2_gTable;
169 PLINFOSEG po2_lTable;
171 -1, /* po2__my_pwent */
172 -1, /* po2_DOS_harderr_state */
173 -1, /* po2_DOS_suppression_state */
176 #define Perl_po2() (&perlos2_state)
178 #define ExtFCN (Perl_po2()->po2_ExtFCN)
179 /* #define PMWIN_entries (Perl_po2()->po2_PMWIN_entries) */
180 #define emx_wasnt_initialized (Perl_po2()->po2_emx_wasnt_initialized)
181 #define fname (Perl_po2()->po2_fname)
182 #define rmq_cnt (Perl_po2()->po2_rmq_cnt)
183 #define grent_cnt (Perl_po2()->po2_grent_cnt)
184 #define newp (Perl_po2()->po2_newp)
185 #define oldp (Perl_po2()->po2_oldp)
186 #define newl (Perl_po2()->po2_newl)
187 #define oldl (Perl_po2()->po2_oldl)
188 #define notfound (Perl_po2()->po2_notfound)
189 #define mangle_ret (Perl_po2()->po2_mangle_ret)
190 #define os2_dll_fake (Perl_po2()->po2_os2_dll_fake)
191 #define os2_mytype (Perl_po2()->po2_os2_mytype)
192 #define os2_mytype_ini (Perl_po2()->po2_os2_mytype_ini)
193 #define pidtid_lookup (Perl_po2()->po2_pidtid_lookup)
194 #define pw (Perl_po2()->po2_pw)
195 #define pwent_cnt (Perl_po2()->po2_pwent_cnt)
196 #define _my_pwent (Perl_po2()->po2__my_pwent)
197 #define pthreads_state_buf (Perl_po2()->po2_pthreads_state_buf)
198 #define os2error_buf (Perl_po2()->po2_os2error_buf)
199 /* There is no big sense to make it thread-specific, since signals
200 are delivered to thread 1 only. XXXX Maybe make it into an array? */
201 #define spawn_pid (Perl_po2()->po2_spawn_pid)
202 #define spawn_killed (Perl_po2()->po2_spawn_killed)
203 #define DOS_harderr_state (Perl_po2()->po2_DOS_harderr_state)
204 #define DOS_suppression_state (Perl_po2()->po2_DOS_suppression_state)
206 #define at_exit_buf (Perl_po2()->po2_at_exit_buf)
207 #define longjmp_at_exit (Perl_po2()->po2_longjmp_at_exit)
208 #define emx_runtime_init (Perl_po2()->po2_emx_runtime_init)
209 #define emx_exception_init (Perl_po2()->po2_emx_exception_init)
210 #define emx_runtime_secondary (Perl_po2()->po2_emx_runtime_secondary)
211 #define perllib_mangle_installed (Perl_po2()->po2_perllib_mangle_installed)
212 #define perl_sh_installed (Perl_po2()->po2_perl_sh_installed)
213 #define gTable (Perl_po2()->po2_gTable)
214 #define lTable (Perl_po2()->po2_lTable)
216 const Perl_PFN * const pExtFCN = (Perl_po2()->po2_ExtFCN);
218 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
220 typedef void (*emx_startroutine)(void *);
221 typedef void* (*pthreads_startroutine)(void *);
223 enum pthreads_state {
224 pthreads_st_none = 0,
227 pthreads_st_detached,
230 pthreads_st_exited_waited,
232 const char * const pthreads_states[] = {
239 "exited, then waited on",
242 enum pthread_exists { pthread_not_existant = -0xff };
245 pthreads_state_string(enum pthreads_state state)
247 if (state < 0 || state >= sizeof(pthreads_states)/sizeof(*pthreads_states)) {
248 snprintf(pthreads_state_buf, sizeof(pthreads_state_buf),
249 "unknown thread state %d", (int)state);
250 return pthreads_state_buf;
252 return pthreads_states[state];
258 enum pthreads_state state;
261 thread_join_t *thread_join_data;
262 int thread_join_count;
263 perl_mutex start_thread_mutex;
264 static perl_mutex perlos2_state_mutex;
268 pthread_join(perl_os_thread tid, void **status)
270 MUTEX_LOCK(&start_thread_mutex);
271 if (tid < 1 || tid >= thread_join_count) {
272 MUTEX_UNLOCK(&start_thread_mutex);
273 if (tid != pthread_not_existant)
274 Perl_croak_nocontext("panic: join with a thread with strange ordinal %d", (int)tid);
275 Perl_warn_nocontext("panic: join with a thread which could not start");
279 switch (thread_join_data[tid].state) {
280 case pthreads_st_exited:
281 thread_join_data[tid].state = pthreads_st_exited_waited;
282 *status = thread_join_data[tid].status;
283 MUTEX_UNLOCK(&start_thread_mutex);
284 COND_SIGNAL(&thread_join_data[tid].cond);
286 case pthreads_st_waited:
287 MUTEX_UNLOCK(&start_thread_mutex);
288 Perl_croak_nocontext("join with a thread with a waiter");
290 case pthreads_st_norun:
292 int state = (int)thread_join_data[tid].status;
294 thread_join_data[tid].state = pthreads_st_none;
295 MUTEX_UNLOCK(&start_thread_mutex);
296 Perl_croak_nocontext("panic: join with a thread which could not run"
297 " due to attempt of tid reuse (state='%s')",
298 pthreads_state_string(state));
301 case pthreads_st_run:
305 thread_join_data[tid].state = pthreads_st_waited;
306 thread_join_data[tid].status = (void *)status;
307 COND_INIT(&thread_join_data[tid].cond);
308 cond = thread_join_data[tid].cond;
309 COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
311 MUTEX_UNLOCK(&start_thread_mutex);
315 MUTEX_UNLOCK(&start_thread_mutex);
316 Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'",
317 pthreads_state_string(thread_join_data[tid].state));
324 pthreads_startroutine sub;
330 a) Since we temporarily usurp the caller interp, so malloc() may
331 use it to decide on debugging the call;
332 b) Since *args is on the caller's stack.
335 pthread_startit(void *arg1)
337 /* Thread is already started, we need to transfer control only */
338 pthr_startit args = *(pthr_startit *)arg1;
339 int tid = pthread_self();
344 /* Can't croak, the setjmp() is not in scope... */
347 snprintf(buf, sizeof(buf),
348 "panic: thread with strange ordinal %d created\n\r", tid);
349 write(2,buf,strlen(buf));
350 MUTEX_UNLOCK(&start_thread_mutex);
353 /* Until args.sub resets it, makes debugging Perl_malloc() work: */
355 if (tid >= thread_join_count) {
356 int oc = thread_join_count;
358 thread_join_count = tid + 5 + tid/5;
359 if (thread_join_data) {
360 Renew(thread_join_data, thread_join_count, thread_join_t);
361 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
363 Newxz(thread_join_data, thread_join_count, thread_join_t);
366 if (thread_join_data[tid].state != pthreads_st_none) {
367 /* Can't croak, the setjmp() is not in scope... */
370 snprintf(buf, sizeof(buf),
371 "panic: attempt to reuse thread id %d (state='%s')\n\r",
372 tid, pthreads_state_string(thread_join_data[tid].state));
373 write(2,buf,strlen(buf));
374 thread_join_data[tid].status = (void*)thread_join_data[tid].state;
375 thread_join_data[tid].state = pthreads_st_norun;
376 MUTEX_UNLOCK(&start_thread_mutex);
379 thread_join_data[tid].state = pthreads_st_run;
380 /* Now that we copied/updated the guys, we may release the caller... */
381 MUTEX_UNLOCK(&start_thread_mutex);
382 rc = (*args.sub)(args.arg);
383 MUTEX_LOCK(&start_thread_mutex);
384 switch (thread_join_data[tid].state) {
385 case pthreads_st_waited:
386 COND_SIGNAL(&thread_join_data[tid].cond);
387 thread_join_data[tid].state = pthreads_st_none;
388 *((void**)thread_join_data[tid].status) = rc;
390 case pthreads_st_detached:
391 thread_join_data[tid].state = pthreads_st_none;
393 case pthreads_st_run:
394 /* Somebody can wait on us; cannot exit, since OS can reuse the tid
395 and our waiter will get somebody else's status. */
396 thread_join_data[tid].state = pthreads_st_exited;
397 thread_join_data[tid].status = rc;
398 COND_INIT(&thread_join_data[tid].cond);
399 COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
400 COND_DESTROY(&thread_join_data[tid].cond);
401 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
404 state = thread_join_data[tid].state;
405 MUTEX_UNLOCK(&start_thread_mutex);
406 Perl_croak_nocontext("panic: unexpected thread state on exit: '%s'",
407 pthreads_state_string(state));
409 MUTEX_UNLOCK(&start_thread_mutex);
413 pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr,
414 void *(*start_routine)(void*), void *arg)
419 args.sub = (void*)start_routine;
421 args.ctx = PERL_GET_CONTEXT;
423 MUTEX_LOCK(&start_thread_mutex);
424 /* Test suite creates 31 extra threads;
425 on machine without shared-memory-hogs this stack sizeis OK with 31: */
426 *tidp = _beginthread(pthread_startit, /*stack*/ NULL,
427 /*stacksize*/ 4*1024*1024, (void*)&args);
429 *tidp = pthread_not_existant;
430 MUTEX_UNLOCK(&start_thread_mutex);
433 MUTEX_LOCK(&start_thread_mutex); /* Wait for init to proceed */
434 MUTEX_UNLOCK(&start_thread_mutex);
439 pthread_detach(perl_os_thread tid)
441 MUTEX_LOCK(&start_thread_mutex);
442 if (tid < 1 || tid >= thread_join_count) {
443 MUTEX_UNLOCK(&start_thread_mutex);
444 if (tid != pthread_not_existant)
445 Perl_croak_nocontext("panic: detach of a thread with strange ordinal %d", (int)tid);
446 Perl_warn_nocontext("detach of a thread which could not start");
449 switch (thread_join_data[tid].state) {
450 case pthreads_st_waited:
451 MUTEX_UNLOCK(&start_thread_mutex);
452 Perl_croak_nocontext("detach on a thread with a waiter");
454 case pthreads_st_run:
455 thread_join_data[tid].state = pthreads_st_detached;
456 MUTEX_UNLOCK(&start_thread_mutex);
458 case pthreads_st_exited:
459 MUTEX_UNLOCK(&start_thread_mutex);
460 COND_SIGNAL(&thread_join_data[tid].cond);
462 case pthreads_st_detached:
463 MUTEX_UNLOCK(&start_thread_mutex);
464 Perl_warn_nocontext("detach on an already detached thread");
466 case pthreads_st_norun:
468 int state = (int)thread_join_data[tid].status;
470 thread_join_data[tid].state = pthreads_st_none;
471 MUTEX_UNLOCK(&start_thread_mutex);
472 Perl_croak_nocontext("panic: detaching thread which could not run"
473 " due to attempt of tid reuse (state='%s')",
474 pthreads_state_string(state));
478 MUTEX_UNLOCK(&start_thread_mutex);
479 Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'",
480 pthreads_state_string(thread_join_data[tid].state));
486 /* This is a very bastardized version; may be OK due to edge trigger of Wait */
488 os2_cond_wait(perl_cond *c, perl_mutex *m)
492 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
493 Perl_rc = CheckOSError(rc), croak_with_os2error("panic: COND_WAIT-reset");
494 if (m) MUTEX_UNLOCK(m);
495 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
496 && (rc != ERROR_INTERRUPT))
497 croak_with_os2error("panic: COND_WAIT");
498 if (rc == ERROR_INTERRUPT)
500 if (m) MUTEX_LOCK(m);
505 static int exe_is_aout(void);
507 /* This should match enum entries_ordinals defined in os2ish.h. */
508 static const struct {
509 struct dll_handle_t *dll;
510 const char *entryname;
513 {&doscalls_handle, NULL, 874}, /* DosQueryExtLibpath */
514 {&doscalls_handle, NULL, 873}, /* DosSetExtLibpath */
515 {&doscalls_handle, NULL, 460}, /* DosVerifyPidTid */
516 {&tcp_handle, "SETHOSTENT", 0},
517 {&tcp_handle, "SETNETENT" , 0},
518 {&tcp_handle, "SETPROTOENT", 0},
519 {&tcp_handle, "SETSERVENT", 0},
520 {&tcp_handle, "GETHOSTENT", 0},
521 {&tcp_handle, "GETNETENT" , 0},
522 {&tcp_handle, "GETPROTOENT", 0},
523 {&tcp_handle, "GETSERVENT", 0},
524 {&tcp_handle, "ENDHOSTENT", 0},
525 {&tcp_handle, "ENDNETENT", 0},
526 {&tcp_handle, "ENDPROTOENT", 0},
527 {&tcp_handle, "ENDSERVENT", 0},
528 {&pmwin_handle, NULL, 763}, /* WinInitialize */
529 {&pmwin_handle, NULL, 716}, /* WinCreateMsgQueue */
530 {&pmwin_handle, NULL, 726}, /* WinDestroyMsgQueue */
531 {&pmwin_handle, NULL, 918}, /* WinPeekMsg */
532 {&pmwin_handle, NULL, 915}, /* WinGetMsg */
533 {&pmwin_handle, NULL, 912}, /* WinDispatchMsg */
534 {&pmwin_handle, NULL, 753}, /* WinGetLastError */
535 {&pmwin_handle, NULL, 705}, /* WinCancelShutdown */
536 /* These are needed in extensions.
537 How to protect PMSHAPI: it comes through EMX functions? */
538 {&rexx_handle, "RexxStart", 0},
539 {&rexx_handle, "RexxVariablePool", 0},
540 {&rexxapi_handle, "RexxRegisterFunctionExe", 0},
541 {&rexxapi_handle, "RexxDeregisterFunction", 0},
542 {&sesmgr_handle, "DOSSMSETTITLE", 0}, /* Would not work runtime-loaded */
543 {&pmshapi_handle, "PRF32QUERYPROFILESIZE", 0},
544 {&pmshapi_handle, "PRF32OPENPROFILE", 0},
545 {&pmshapi_handle, "PRF32CLOSEPROFILE", 0},
546 {&pmshapi_handle, "PRF32QUERYPROFILE", 0},
547 {&pmshapi_handle, "PRF32RESET", 0},
548 {&pmshapi_handle, "PRF32QUERYPROFILEDATA", 0},
549 {&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0},
551 /* At least some of these do not work by name, since they need
552 WIN32 instead of WIN... */
554 These were generated with
555 nm I:\emx\lib\os2.a | fgrep -f API-list | grep = > API-list-entries
556 perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( ORD_$1,)" API-list-entries > API-list-ORD_
557 perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( {${2}_handle, NULL, $3},\t\t/* $1 */)" WinSwitch-API-list-entries >API-list-entry
559 {&pmshapi_handle, NULL, 123}, /* WinChangeSwitchEntry */
560 {&pmshapi_handle, NULL, 124}, /* WinQuerySwitchEntry */
561 {&pmshapi_handle, NULL, 125}, /* WinQuerySwitchHandle */
562 {&pmshapi_handle, NULL, 126}, /* WinQuerySwitchList */
563 {&pmshapi_handle, NULL, 131}, /* WinSwitchToProgram */
564 {&pmwin_handle, NULL, 702}, /* WinBeginEnumWindows */
565 {&pmwin_handle, NULL, 737}, /* WinEndEnumWindows */
566 {&pmwin_handle, NULL, 740}, /* WinEnumDlgItem */
567 {&pmwin_handle, NULL, 756}, /* WinGetNextWindow */
568 {&pmwin_handle, NULL, 768}, /* WinIsChild */
569 {&pmwin_handle, NULL, 799}, /* WinQueryActiveWindow */
570 {&pmwin_handle, NULL, 805}, /* WinQueryClassName */
571 {&pmwin_handle, NULL, 817}, /* WinQueryFocus */
572 {&pmwin_handle, NULL, 834}, /* WinQueryWindow */
573 {&pmwin_handle, NULL, 837}, /* WinQueryWindowPos */
574 {&pmwin_handle, NULL, 838}, /* WinQueryWindowProcess */
575 {&pmwin_handle, NULL, 841}, /* WinQueryWindowText */
576 {&pmwin_handle, NULL, 842}, /* WinQueryWindowTextLength */
577 {&pmwin_handle, NULL, 860}, /* WinSetFocus */
578 {&pmwin_handle, NULL, 875}, /* WinSetWindowPos */
579 {&pmwin_handle, NULL, 877}, /* WinSetWindowText */
580 {&pmwin_handle, NULL, 883}, /* WinShowWindow */
581 {&pmwin_handle, NULL, 772}, /* WinIsWindow */
582 {&pmwin_handle, NULL, 899}, /* WinWindowFromId */
583 {&pmwin_handle, NULL, 900}, /* WinWindowFromPoint */
584 {&pmwin_handle, NULL, 919}, /* WinPostMsg */
585 {&pmwin_handle, NULL, 735}, /* WinEnableWindow */
586 {&pmwin_handle, NULL, 736}, /* WinEnableWindowUpdate */
587 {&pmwin_handle, NULL, 773}, /* WinIsWindowEnabled */
588 {&pmwin_handle, NULL, 774}, /* WinIsWindowShowing */
589 {&pmwin_handle, NULL, 775}, /* WinIsWindowVisible */
590 {&pmwin_handle, NULL, 839}, /* WinQueryWindowPtr */
591 {&pmwin_handle, NULL, 843}, /* WinQueryWindowULong */
592 {&pmwin_handle, NULL, 844}, /* WinQueryWindowUShort */
593 {&pmwin_handle, NULL, 874}, /* WinSetWindowBits */
594 {&pmwin_handle, NULL, 876}, /* WinSetWindowPtr */
595 {&pmwin_handle, NULL, 878}, /* WinSetWindowULong */
596 {&pmwin_handle, NULL, 879}, /* WinSetWindowUShort */
597 {&pmwin_handle, NULL, 813}, /* WinQueryDesktopWindow */
598 {&pmwin_handle, NULL, 851}, /* WinSetActiveWindow */
599 {&doscalls_handle, NULL, 360}, /* DosQueryModFromEIP */
600 {&doscalls_handle, NULL, 582}, /* Dos32QueryHeaderInfo */
601 {&doscalls_handle, NULL, 362}, /* DosTmrQueryFreq */
602 {&doscalls_handle, NULL, 363}, /* DosTmrQueryTime */
603 {&pmwp_handle, NULL, 262}, /* WinQueryActiveDesktopPathname */
604 {&pmwin_handle, NULL, 765}, /* WinInvalidateRect */
605 {&pmwin_handle, NULL, 906}, /* WinCreateFrameControl */
606 {&pmwin_handle, NULL, 807}, /* WinQueryClipbrdFmtInfo */
607 {&pmwin_handle, NULL, 808}, /* WinQueryClipbrdOwner */
608 {&pmwin_handle, NULL, 809}, /* WinQueryClipbrdViewer */
609 {&pmwin_handle, NULL, 806}, /* WinQueryClipbrdData */
610 {&pmwin_handle, NULL, 793}, /* WinOpenClipbrd */
611 {&pmwin_handle, NULL, 707}, /* WinCloseClipbrd */
612 {&pmwin_handle, NULL, 854}, /* WinSetClipbrdData */
613 {&pmwin_handle, NULL, 855}, /* WinSetClipbrdOwner */
614 {&pmwin_handle, NULL, 856}, /* WinSetClipbrdViewer */
615 {&pmwin_handle, NULL, 739}, /* WinEnumClipbrdFmts */
616 {&pmwin_handle, NULL, 733}, /* WinEmptyClipbrd */
617 {&pmwin_handle, NULL, 700}, /* WinAddAtom */
618 {&pmwin_handle, NULL, 744}, /* WinFindAtom */
619 {&pmwin_handle, NULL, 721}, /* WinDeleteAtom */
620 {&pmwin_handle, NULL, 803}, /* WinQueryAtomUsage */
621 {&pmwin_handle, NULL, 802}, /* WinQueryAtomName */
622 {&pmwin_handle, NULL, 801}, /* WinQueryAtomLength */
623 {&pmwin_handle, NULL, 830}, /* WinQuerySystemAtomTable */
624 {&pmwin_handle, NULL, 714}, /* WinCreateAtomTable */
625 {&pmwin_handle, NULL, 724}, /* WinDestroyAtomTable */
626 {&pmwin_handle, NULL, 794}, /* WinOpenWindowDC */
627 {&pmgpi_handle, NULL, 610}, /* DevOpenDC */
628 {&pmgpi_handle, NULL, 606}, /* DevQueryCaps */
629 {&pmgpi_handle, NULL, 604}, /* DevCloseDC */
630 {&pmwin_handle, NULL, 789}, /* WinMessageBox */
631 {&pmwin_handle, NULL, 1015}, /* WinMessageBox2 */
632 {&pmwin_handle, NULL, 829}, /* WinQuerySysValue */
633 {&pmwin_handle, NULL, 873}, /* WinSetSysValue */
634 {&pmwin_handle, NULL, 701}, /* WinAlarm */
635 {&pmwin_handle, NULL, 745}, /* WinFlashWindow */
636 {&pmwin_handle, NULL, 780}, /* WinLoadPointer */
637 {&pmwin_handle, NULL, 828}, /* WinQuerySysPointer */
638 {&doscalls_handle, NULL, 417}, /* DosReplaceModule */
639 {&doscalls_handle, NULL, 976}, /* DosPerfSysCall */
640 {&rexxapi_handle, "RexxRegisterSubcomExe", 0},
644 loadModule(const char *modname, int fail)
646 HMODULE h = (HMODULE)dlopen(modname, 0);
649 Perl_croak_nocontext("Error loading module '%s': %s",
654 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
663 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
664 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
667 return (pib->pib_ultype);
671 my_type_set(int type)
677 if (!(_emx_env & 0x200))
678 Perl_croak_nocontext("Can't set type on DOS"); /* not OS/2. */
679 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
680 croak_with_os2error("Error getting info blocks");
681 pib->pib_ultype = type;
685 loadByOrdinal(enum entries_ordinals ord, int fail)
687 if (sizeof(loadOrdinals)/sizeof(loadOrdinals[0]) != ORD_NENTRIES)
688 Perl_croak_nocontext(
689 "Wrong size of loadOrdinals array: expected %d, actual %d",
690 sizeof(loadOrdinals)/sizeof(loadOrdinals[0]), ORD_NENTRIES);
691 if (ExtFCN[ord] == NULL) {
695 if (!loadOrdinals[ord].dll->handle) {
696 if (loadOrdinals[ord].dll->requires_pm && my_type() < 2) { /* FS */
697 char *s = getenv("PERL_ASIF_PM");
699 if (!s || !atoi(s)) {
700 /* The module will not function well without PM.
701 The usual way to detect PM is the existence of the mutex
702 \SEM32\PMDRAG.SEM. */
705 if (CheckOSError(DosOpenMutexSem("\\SEM32\\PMDRAG.SEM",
707 Perl_croak_nocontext("Looks like we have no PM; will not load DLL %s without $ENV{PERL_ASIF_PM}",
708 loadOrdinals[ord].dll->modname);
709 DosCloseMutexSem(hMtx);
712 MUTEX_LOCK(&perlos2_state_mutex);
713 loadOrdinals[ord].dll->handle
714 = loadModule(loadOrdinals[ord].dll->modname, fail);
715 MUTEX_UNLOCK(&perlos2_state_mutex);
717 if (!loadOrdinals[ord].dll->handle)
718 return 0; /* Possible with FAIL==0 only */
719 if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle,
720 loadOrdinals[ord].entrypoint,
721 loadOrdinals[ord].entryname,&fcn))) {
722 char buf[20], *s = (char*)loadOrdinals[ord].entryname;
727 sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint);
728 Perl_croak_nocontext(
729 "This version of OS/2 does not support %s.%s",
730 loadOrdinals[ord].dll->modname, s);
734 if ((long)ExtFCN[ord] == -1)
735 Perl_croak_nocontext("panic queryaddr");
740 init_PMWIN_entries(void)
744 for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++)
745 ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1);
748 /*****************************************************/
749 /* socket forwarders without linking with tcpip DLLs */
751 DeclFuncByORD(struct hostent *, gethostent, ORD_GETHOSTENT, (void), ())
752 DeclFuncByORD(struct netent *, getnetent, ORD_GETNETENT, (void), ())
753 DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ())
754 DeclFuncByORD(struct servent *, getservent, ORD_GETSERVENT, (void), ())
756 DeclVoidFuncByORD(sethostent, ORD_SETHOSTENT, (int x), (x))
757 DeclVoidFuncByORD(setnetent, ORD_SETNETENT, (int x), (x))
758 DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x))
759 DeclVoidFuncByORD(setservent, ORD_SETSERVENT, (int x), (x))
761 DeclVoidFuncByORD(endhostent, ORD_ENDHOSTENT, (void), ())
762 DeclVoidFuncByORD(endnetent, ORD_ENDNETENT, (void), ())
763 DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ())
764 DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ())
767 static const signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
769 #define QSS_INI_BUFFER 1024
771 ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
774 get_sysinfo(ULONG pid, ULONG flags)
777 ULONG rc, buf_len = QSS_INI_BUFFER;
781 if (!pidtid_lookup) {
783 *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0);
785 if (pDosVerifyPidTid) { /* Warp3 or later */
786 /* Up to some fixpak QuerySysState() kills the system if a non-existent
788 if (CheckOSError(pDosVerifyPidTid(pid, 1)))
792 Newx(pbuffer, buf_len, char);
793 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
794 rc = QuerySysState(flags, pid, pbuffer, buf_len);
795 while (rc == ERROR_BUFFER_OVERFLOW) {
796 Renew(pbuffer, buf_len *= 2, char);
797 rc = QuerySysState(flags, pid, pbuffer, buf_len);
804 psi = (PQTOPLEVEL)pbuffer;
805 if (psi && pid && psi->procdata && pid != psi->procdata->pid) {
807 Perl_croak_nocontext("panic: wrong pid in sysinfo");
812 #define PRIO_ERR 0x1111
822 psi = get_sysinfo(pid, QSS_PROCESS);
825 prio = psi->procdata->threads->priority;
831 setpriority(int which, int pid, int val)
833 ULONG rc, prio = sys_prio(pid);
835 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
836 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
837 /* Do not change class. */
838 return CheckOSError(DosSetPriority((pid < 0)
839 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
841 (32 - val) % 32 - (prio & 0xFF),
844 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
845 /* Documentation claims one can change both class and basevalue,
846 * but I find it wrong. */
847 /* Change class, but since delta == 0 denotes absolute 0, correct. */
848 if (CheckOSError(DosSetPriority((pid < 0)
849 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
850 priors[(32 - val) >> 5] + 1,
854 if ( ((32 - val) % 32) == 0 ) return 0;
855 return CheckOSError(DosSetPriority((pid < 0)
856 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
865 getpriority(int which /* ignored */, int pid)
869 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
871 if (ret == PRIO_ERR) {
874 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
877 /*****************************************************************************/
883 spawn_sighandler(int sig)
885 /* Some programs do not arrange for the keyboard signals to be
886 delivered to them. We need to deliver the signal manually. */
887 /* We may get a signal only if
888 a) kid does not receive keyboard signal: deliver it;
889 b) kid already died, and we get a signal. We may only hope
890 that the pid number was not reused.
894 sig = SIGKILL; /* Try harder. */
895 kill(spawn_pid, sig);
900 result(pTHX_ int flag, int pid)
903 Signal_t (*ihand)(); /* place to save signal during system() */
904 Signal_t (*qhand)(); /* place to save signal during system() */
910 if (pid < 0 || flag != 0)
916 ihand = rsignal(SIGINT, &spawn_sighandler);
917 qhand = rsignal(SIGQUIT, &spawn_sighandler);
919 r = wait4pid(pid, &status, 0);
920 } while (r == -1 && errno == EINTR);
921 rsignal(SIGINT, ihand);
922 rsignal(SIGQUIT, qhand);
924 PL_statusvalue = (U16)status;
927 return status & 0xFFFF;
929 ihand = rsignal(SIGINT, SIG_IGN);
930 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
931 rsignal(SIGINT, ihand);
932 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
935 return PL_statusvalue;
949 file_type(char *path)
954 if (!(_emx_env & 0x200))
955 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
956 if (CheckOSError(DosQueryAppType(path, &apptype))) {
958 case ERROR_FILE_NOT_FOUND:
959 case ERROR_PATH_NOT_FOUND:
961 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
963 default: /* Found, but not an
964 executable, or some other
972 /* Spawn/exec a program, revert to shell if needed. */
973 /* global PL_Argv[] contains arguments. */
975 extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
976 EXCEPTIONREGISTRATIONRECORD *,
981 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
985 char *real_name = NULL; /* Shut down the warning */
986 char const * args[4];
987 static const char * const fargs[4]
988 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
989 const char * const *argsp = fargs;
992 int new_stderr = -1, nostderr = 0;
1000 if (really && !*(real_name = SvPV(really, n_a)))
1004 if (strEQ(PL_Argv[0],"/bin/sh"))
1005 PL_Argv[0] = PL_sh_path;
1007 /* We should check PERL_SH* and PERLLIB_* as well? */
1008 if (!really || pass >= 2)
1009 real_name = PL_Argv[0];
1010 if (real_name[0] != '/' && real_name[0] != '\\'
1011 && !(real_name[0] && real_name[1] == ':'
1012 && (real_name[2] == '/' || real_name[2] != '\\'))
1013 ) /* will spawnvp use PATH? */
1014 TAINT_ENV(); /* testing IFS here is overkill, probably */
1018 if (_emx_env & 0x200) { /* OS/2. */
1019 int type = file_type(real_name);
1021 if (type == -1) { /* Not found */
1026 else if (type == -2) { /* Not an EXE */
1031 else if (type == -3) { /* Is a directory? */
1032 /* Special-case this */
1034 int l = strlen(real_name);
1036 if (l + 5 <= sizeof tbuf) {
1037 strcpy(tbuf, real_name);
1038 strcpy(tbuf + l, ".exe");
1039 type = file_type(tbuf);
1049 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
1050 case FAPPTYP_WINDOWAPI:
1051 { /* Apparently, kids are started basing on startup type, not the morphed type */
1052 if (os2_mytype != 3) { /* not PM */
1053 if (flag == P_NOWAIT)
1055 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
1056 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d",
1061 case FAPPTYP_NOTWINDOWCOMPAT:
1063 if (os2_mytype != 0) { /* not full screen */
1064 if (flag == P_NOWAIT)
1066 else if ((flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
1067 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d",
1072 case FAPPTYP_NOTSPEC:
1073 /* Let the shell handle this... */
1075 buf = ""; /* Pacify a warning */
1076 file = 0; /* Pacify a warning */
1084 new_stderr = dup(2); /* Preserve stderr */
1085 if (new_stderr == -1) {
1093 fl_stderr = fcntl(2, F_GETFD);
1097 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
1101 rc = result(aTHX_ trueflag, spawnvp(flag,real_name,PL_Argv));
1103 if (execf == EXECF_TRUEEXEC)
1104 rc = execvp(real_name,PL_Argv);
1105 else if (execf == EXECF_EXEC)
1106 rc = spawnvp(trueflag | P_OVERLAY,real_name,PL_Argv);
1107 else if (execf == EXECF_SPAWN_NOWAIT)
1108 rc = spawnvp(flag,real_name,PL_Argv);
1109 else if (execf == EXECF_SYNC)
1110 rc = spawnvp(trueflag,real_name,PL_Argv);
1111 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
1112 rc = result(aTHX_ trueflag,
1113 spawnvp(flag,real_name,PL_Argv));
1115 if (rc < 0 && pass == 1) {
1117 if (real_name == PL_Argv[0]) {
1120 if (err == ENOENT || err == ENOEXEC) {
1121 /* No such file, or is a script. */
1122 /* Try adding script extensions to the file name, and
1124 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
1128 SV *scrsv = sv_2mortal(newSVpv(scr, 0));
1129 SV *bufsv = sv_newmortal();
1132 scr = SvPV(scrsv, n_a); /* free()ed later */
1134 file = PerlIO_open(scr, "r");
1139 buf = sv_gets(bufsv, file, 0 /* No append */);
1141 buf = ""; /* XXX Needed? */
1142 if (!buf[0]) { /* Empty... */
1144 /* Special case: maybe from -Zexe build, so
1145 there is an executable around (contrary to
1146 documentation, DosQueryAppType sometimes (?)
1147 does not append ".exe", so we could have
1148 reached this place). */
1149 sv_catpv(scrsv, ".exe");
1150 PL_Argv[0] = scr = SvPV(scrsv, n_a); /* Reload */
1151 if (PerlLIO_stat(scr,&PL_statbuf) >= 0
1152 && !S_ISDIR(PL_statbuf.st_mode)) { /* Found */
1156 } else { /* Restore */
1157 SvCUR_set(scrsv, SvCUR(scrsv) - 4);
1161 if (PerlIO_close(file) != 0) { /* Failure */
1163 if (ckWARN(WARN_EXEC))
1164 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
1165 scr, Strerror(errno));
1166 buf = ""; /* Not #! */
1169 if (buf[0] == '#') {
1172 } else if (buf[0] == 'e') {
1173 if (strnEQ(buf, "extproc", 7)
1176 } else if (buf[0] == 'E') {
1177 if (strnEQ(buf, "EXTPROC", 7)
1182 buf = ""; /* Not #! */
1190 /* Do better than pdksh: allow a few args,
1191 strip trailing whitespace. */
1201 while (*s && !isSPACE(*s))
1208 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"",
1209 s1 - buf, buf, scr);
1213 /* Can jump from far, buf/file invalid if force_shell: */
1217 const char *exec_args[2];
1220 || (!buf[0] && file)) { /* File without magic */
1221 /* In fact we tried all what pdksh would
1222 try. There is no point in calling
1223 pdksh, we may just emulate its logic. */
1224 char *shell = getenv("EXECSHELL");
1225 char *shell_opt = NULL;
1231 shell = getenv("OS2_SHELL");
1232 if (inicmd) { /* No spaces at start! */
1234 while (*s && !isSPACE(*s)) {
1236 inicmd = NULL; /* Cannot use */
1244 /* Dosish shells will choke on slashes
1245 in paths, fortunately, this is
1246 important for zeroth arg only. */
1253 /* If EXECSHELL is set, we do not set */
1256 shell = ((_emx_env & 0x200)
1258 : "c:/command.com");
1259 nargs = shell_opt ? 2 : 1; /* shell file args */
1260 exec_args[0] = shell;
1261 exec_args[1] = shell_opt;
1263 if (nargs == 2 && inicmd) {
1264 /* Use the original cmd line */
1265 /* XXXX This is good only until we refuse
1266 quoted arguments... */
1267 PL_Argv[0] = inicmd;
1270 } else if (!buf[0] && inicmd) { /* No file */
1271 /* Start with the original cmdline. */
1272 /* XXXX This is good only until we refuse
1273 quoted arguments... */
1275 PL_Argv[0] = inicmd;
1277 nargs = 2; /* shell -c */
1280 while (a[1]) /* Get to the end */
1282 a++; /* Copy finil NULL too */
1283 while (a >= PL_Argv) {
1284 *(a + nargs) = *a; /* PL_Argv was preallocated to be
1288 while (--nargs >= 0) /* XXXX Discard const... */
1289 PL_Argv[nargs] = (char*)argsp[nargs];
1290 /* Enable pathless exec if #! (as pdksh). */
1291 pass = (buf[0] == '#' ? 2 : 3);
1295 /* Not found: restore errno */
1298 } else if (errno == ENOEXEC) { /* Cannot transfer `real_name' via shell. */
1299 if (rc < 0 && ckWARN(WARN_EXEC))
1300 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s script `%s' with ARGV[0] being `%s'",
1301 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1302 ? "spawn" : "exec"),
1303 real_name, PL_Argv[0]);
1305 } else if (errno == ENOENT) { /* Cannot transfer `real_name' via shell. */
1306 if (rc < 0 && ckWARN(WARN_EXEC))
1307 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)",
1308 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1309 ? "spawn" : "exec"),
1310 real_name, PL_Argv[0]);
1313 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
1314 char *no_dir = strrchr(PL_Argv[0], '/');
1316 /* Do as pdksh port does: if not found with /, try without
1319 PL_Argv[0] = no_dir + 1;
1324 if (rc < 0 && ckWARN(WARN_EXEC))
1325 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n",
1326 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1327 ? "spawn" : "exec"),
1328 real_name, Strerror(errno));
1330 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
1331 && ((trueflag & 0xFF) == P_WAIT))
1335 if (new_stderr != -1) { /* How can we use error codes? */
1336 dup2(new_stderr, 2);
1338 fcntl(2, F_SETFD, fl_stderr);
1339 } else if (nostderr)
1344 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
1346 do_spawn3(pTHX_ char *cmd, int execf, int flag)
1350 char *shell, *copt, *news = NULL;
1351 int rc, seenspace = 0, mergestderr = 0;
1354 if ((shell = getenv("EMXSHELL")) != NULL)
1356 else if ((shell = getenv("SHELL")) != NULL)
1358 else if ((shell = getenv("COMSPEC")) != NULL)
1363 /* Consensus on perl5-porters is that it is _very_ important to
1364 have a shell which will not change between computers with the
1365 same architecture, to avoid "action on a distance".
1366 And to have simple build, this shell should be sh. */
1371 while (*cmd && isSPACE(*cmd))
1374 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
1375 STRLEN l = strlen(PL_sh_path);
1377 Newx(news, strlen(cmd) - 7 + l + 1, char);
1378 strcpy(news, PL_sh_path);
1379 strcpy(news + l, cmd + 7);
1383 /* save an extra exec if possible */
1384 /* see if there are shell metacharacters in it */
1386 if (*cmd == '.' && isSPACE(cmd[1]))
1389 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1392 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
1396 for (s = cmd; *s; s++) {
1397 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
1398 if (*s == '\n' && s[1] == '\0') {
1401 } else if (*s == '\\' && !seenspace) {
1402 continue; /* Allow backslashes in names */
1403 } else if (*s == '>' && s >= cmd + 3
1404 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
1405 && isSPACE(s[-2]) ) {
1408 while (*t && isSPACE(*t))
1413 break; /* Allow 2>&1 as the last thing */
1416 /* We do not convert this to do_spawn_ve since shell
1417 should be smart enough to start itself gloriously. */
1419 if (execf == EXECF_TRUEEXEC)
1420 rc = execl(shell,shell,copt,cmd,(char*)0);
1421 else if (execf == EXECF_EXEC)
1422 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
1423 else if (execf == EXECF_SPAWN_NOWAIT)
1424 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
1425 else if (execf == EXECF_SPAWN_BYFLAG)
1426 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
1428 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
1429 if (execf == EXECF_SYNC)
1430 rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0);
1432 rc = result(aTHX_ P_WAIT,
1433 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
1434 if (rc < 0 && ckWARN(WARN_EXEC))
1435 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
1436 (execf == EXECF_SPAWN ? "spawn" : "exec"),
1437 shell, Strerror(errno));
1444 } else if (*s == ' ' || *s == '\t') {
1449 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
1450 Newx(PL_Argv, (s - cmd + 11) / 2, char*);
1451 PL_Cmd = savepvn(cmd, s-cmd);
1453 for (s = PL_Cmd; *s;) {
1454 while (*s && isSPACE(*s)) s++;
1457 while (*s && !isSPACE(*s)) s++;
1463 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
1472 #define ASPAWN_WAIT 0
1473 #define ASPAWN_EXEC 1
1474 #define ASPAWN_NOWAIT 2
1476 /* Array spawn/exec. */
1478 os2_aspawn_4(pTHX_ SV *really, SV **args, I32 cnt, int execing)
1480 SV **argp = (SV **)args;
1481 SV **last = argp + cnt;
1484 int flag = P_WAIT, flag_set = 0;
1488 Newx(PL_Argv, cnt + 3, char*); /* 3 extra to expand #! */
1491 if (cnt > 1 && SvNIOKp(*argp) && !SvPOKp(*argp)) {
1492 flag = SvIVx(*argp);
1497 while (++argp < last) {
1499 *a++ = SvPVx(*argp, n_a);
1505 if ( flag_set && (a == PL_Argv + 1)
1506 && !really && execing == ASPAWN_WAIT ) { /* One arg? */
1507 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
1509 const int execf[3] = {EXECF_SPAWN, EXECF_EXEC, EXECF_SPAWN_NOWAIT};
1511 rc = do_spawn_ve(aTHX_ really, flag, execf[execing], NULL, 0);
1521 os2_do_aspawn(pTHX_ SV *really, SV **vmark, SV **vsp)
1523 return os2_aspawn_4(aTHX_ really, vmark + 1, vsp - vmark, ASPAWN_WAIT);
1528 Perl_do_aexec(pTHX_ SV* really, SV** vmark, SV** vsp)
1530 return os2_aspawn_4(aTHX_ really, vmark + 1, vsp - vmark, ASPAWN_EXEC);
1534 os2_do_spawn(pTHX_ char *cmd)
1536 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
1540 do_spawn_nowait(pTHX_ char *cmd)
1542 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1546 Perl_do_exec(pTHX_ const char *cmd)
1548 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1553 os2exec(pTHX_ char *cmd)
1555 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1559 my_syspopen4(pTHX_ char *cmd, char *mode, I32 cnt, SV** args)
1563 I32 this, that, newfd;
1566 int fh_fl = 0; /* Pacify the warning */
1568 /* `this' is what we use in the parent, `that' in the child. */
1569 this = (*mode == 'w');
1573 taint_proper("Insecure %s%s", "EXEC");
1577 /* Now we need to spawn the child. */
1578 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1579 int new = dup(p[this]);
1586 newfd = dup(*mode == 'r'); /* Preserve std* */
1588 /* This cannot happen due to fh being bad after pipe(), since
1589 pipe() should have created fh 0 and 1 even if they were
1590 initially closed. But we closed p[this] before. */
1591 if (errno != EBADF) {
1598 fh_fl = fcntl(*mode == 'r', F_GETFD);
1599 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1600 dup2(p[that], *mode == 'r');
1603 /* Where is `this' and newfd now? */
1604 fcntl(p[this], F_SETFD, FD_CLOEXEC);
1606 fcntl(newfd, F_SETFD, FD_CLOEXEC);
1607 if (cnt) { /* Args: "Real cmd", before first arg, the last, execing */
1608 pid = os2_aspawn_4(aTHX_ NULL, args, cnt, ASPAWN_NOWAIT);
1610 pid = do_spawn_nowait(aTHX_ cmd);
1612 close(*mode == 'r'); /* It was closed initially */
1613 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1614 dup2(newfd, *mode == 'r'); /* Return std* back. */
1616 fcntl(*mode == 'r', F_SETFD, fh_fl);
1618 fcntl(*mode == 'r', F_SETFD, fh_fl);
1619 if (p[that] == (*mode == 'r'))
1625 if (p[that] < p[this]) { /* Make fh as small as possible */
1626 dup2(p[this], p[that]);
1630 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1631 (void)SvUPGRADE(sv,SVt_IV);
1633 PL_forkprocess = pid;
1634 return PerlIO_fdopen(p[this], mode);
1636 #else /* USE_POPEN */
1642 Perl_croak(aTHX_ "List form of piped open not implemented");
1645 res = popen(cmd, mode);
1647 char *shell = getenv("EMXSHELL");
1649 my_setenv("EMXSHELL", PL_sh_path);
1650 res = popen(cmd, mode);
1651 my_setenv("EMXSHELL", shell);
1653 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1654 (void)SvUPGRADE(sv,SVt_IV);
1655 SvIVX(sv) = -1; /* A cooky. */
1658 #endif /* USE_POPEN */
1663 my_syspopen(pTHX_ char *cmd, char *mode)
1665 return my_syspopen4(aTHX_ cmd, mode, 0, NULL);
1668 /******************************************************************/
1674 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1680 /*******************************************************************/
1681 /* not implemented in EMX 0.9d */
1683 char * ctermid(char *s) { return 0; }
1685 #ifdef MYTTYNAME /* was not in emx0.9a */
1686 void * ttyname(x) { return 0; }
1689 /*****************************************************************************/
1690 /* not implemented in C Set++ */
1693 int setuid(x) { errno = EINVAL; return -1; }
1694 int setgid(x) { errno = EINVAL; return -1; }
1697 /*****************************************************************************/
1698 /* stat() hack for char/block device */
1702 enum os2_stat_extra { /* EMX 0.9d fix 4 defines up to 0100000 */
1703 os2_stat_archived = 0x1000000, /* 0100000000 */
1704 os2_stat_hidden = 0x2000000, /* 0200000000 */
1705 os2_stat_system = 0x4000000, /* 0400000000 */
1706 os2_stat_force = 0x8000000, /* Do not ignore flags on chmod */
1709 #define OS2_STAT_SPECIAL (os2_stat_system | os2_stat_archived | os2_stat_hidden)
1712 massage_os2_attr(struct stat *st)
1714 if ( ((st->st_mode & S_IFMT) != S_IFREG
1715 && (st->st_mode & S_IFMT) != S_IFDIR)
1716 || !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM)))
1719 if ( st->st_attr & FILE_ARCHIVED )
1720 st->st_mode |= (os2_stat_archived | os2_stat_force);
1721 if ( st->st_attr & FILE_HIDDEN )
1722 st->st_mode |= (os2_stat_hidden | os2_stat_force);
1723 if ( st->st_attr & FILE_SYSTEM )
1724 st->st_mode |= (os2_stat_system | os2_stat_force);
1727 /* First attempt used DosQueryFSAttach which crashed the system when
1728 used with 5.001. Now just look for /dev/. */
1730 os2_stat(const char *name, struct stat *st)
1732 static int ino = SHRT_MAX;
1733 STRLEN l = strlen(name);
1735 if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0
1736 || ( stricmp(name + 5, "con") != 0
1737 && stricmp(name + 5, "tty") != 0
1738 && stricmp(name + 5, "nul") != 0
1739 && stricmp(name + 5, "null") != 0) ) {
1740 int s = stat(name, st);
1744 massage_os2_attr(st);
1748 memset(st, 0, sizeof *st);
1749 st->st_mode = S_IFCHR|0666;
1750 MUTEX_LOCK(&perlos2_state_mutex);
1751 st->st_ino = (ino-- & 0x7FFF);
1752 MUTEX_UNLOCK(&perlos2_state_mutex);
1758 os2_fstat(int handle, struct stat *st)
1760 int s = fstat(handle, st);
1764 massage_os2_attr(st);
1770 os2_chmod (const char *name, int pmode) /* Modelled after EMX src/lib/io/chmod.c */
1774 if (!(pmode & os2_stat_force))
1775 return chmod(name, pmode);
1777 attr = __chmod (name, 0, 0); /* Get attributes */
1780 if (pmode & S_IWRITE)
1781 attr &= ~FILE_READONLY;
1783 attr |= FILE_READONLY;
1785 attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM);
1787 if ( pmode & os2_stat_archived )
1788 attr |= FILE_ARCHIVED;
1789 if ( pmode & os2_stat_hidden )
1790 attr |= FILE_HIDDEN;
1791 if ( pmode & os2_stat_system )
1792 attr |= FILE_SYSTEM;
1794 rc = __chmod (name, 1, attr);
1795 if (rc >= 0) rc = 0;
1801 #ifdef USE_PERL_SBRK
1803 /* SBRK() emulation, mostly moved to malloc.c. */
1806 sys_alloc(int size) {
1808 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1810 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1813 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1817 #endif /* USE_PERL_SBRK */
1821 const char *tmppath = TMPPATH1;
1826 char *p = getenv("TMP"), *tpath;
1829 if (!p) p = getenv("TEMP");
1830 if (!p) p = getenv("TMPDIR");
1833 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1837 strcpy(tpath + len + 1, TMPPATH1);
1844 XS(XS_File__Copy_syscopy)
1847 if (items < 2 || items > 3)
1848 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1851 char * src = (char *)SvPV(ST(0),n_a);
1852 char * dst = (char *)SvPV(ST(1),n_a);
1860 flag = (unsigned long)SvIV(ST(2));
1863 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1864 XSprePUSH; PUSHi((IV)RETVAL);
1869 /* APIRET APIENTRY DosReplaceModule (PCSZ pszOld, PCSZ pszNew, PCSZ pszBackup); */
1871 DeclOSFuncByORD(ULONG,replaceModule,ORD_DosReplaceModule,
1872 (char *old, char *new, char *backup), (old, new, backup))
1874 XS(XS_OS2_replaceModule); /* prototype to pass -Wmissing-prototypes */
1875 XS(XS_OS2_replaceModule)
1878 if (items < 1 || items > 3)
1879 Perl_croak(aTHX_ "Usage: OS2::replaceModule(target [, source [, backup]])");
1881 char * target = (char *)SvPV_nolen(ST(0));
1882 char * source = (items < 2) ? NULL : (char *)SvPV_nolen(ST(1));
1883 char * backup = (items < 3) ? NULL : (char *)SvPV_nolen(ST(2));
1885 if (!replaceModule(target, source, backup))
1886 croak_with_os2error("replaceModule() error");
1891 /* APIRET APIENTRY DosPerfSysCall(ULONG ulCommand, ULONG ulParm1,
1892 ULONG ulParm2, ULONG ulParm3); */
1894 DeclOSFuncByORD(ULONG,perfSysCall,ORD_DosPerfSysCall,
1895 (ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3),
1896 (ulCommand, ulParm1, ulParm2, ulParm3))
1898 #ifndef CMD_KI_RDCNT
1899 # define CMD_KI_RDCNT 0x63
1901 #ifndef CMD_KI_GETQTY
1902 # define CMD_KI_GETQTY 0x41
1904 #ifndef QSV_NUMPROCESSORS
1905 # define QSV_NUMPROCESSORS 26
1908 typedef unsigned long long myCPUUTIL[4]; /* time/idle/busy/intr */
1912 perfSysCall(ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3)
1917 croak_with_os2error("perfSysCall() error");
1925 if (DosQuerySysInfo(QSV_NUMPROCESSORS, QSV_NUMPROCESSORS, (PVOID)&res, sizeof(res)))
1926 return 1; /* Old system? */
1930 XS(XS_OS2_perfSysCall); /* prototype to pass -Wmissing-prototypes */
1931 XS(XS_OS2_perfSysCall)
1934 if (items < 0 || items > 4)
1935 Perl_croak(aTHX_ "Usage: OS2::perfSysCall(ulCommand = CMD_KI_RDCNT, ulParm1= 0, ulParm2= 0, ulParm3= 0)");
1939 ULONG RETVAL, ulCommand, ulParm1, ulParm2, ulParm3, res;
1941 int total = 0, tot2 = 0;
1944 ulCommand = CMD_KI_RDCNT;
1946 ulCommand = (ULONG)SvUV(ST(0));
1950 total = (ulCommand == CMD_KI_RDCNT ? numprocessors() : 0);
1951 ulParm1 = (total ? (ULONG)u : 0);
1953 if (total > C_ARRAY_LENGTH(u))
1954 croak("Unexpected number of processors: %d", total);
1956 ulParm1 = (ULONG)SvUV(ST(1));
1960 tot2 = (ulCommand == CMD_KI_GETQTY);
1961 ulParm2 = (tot2 ? (ULONG)&res : 0);
1963 ulParm2 = (ULONG)SvUV(ST(2));
1969 ulParm3 = (ULONG)SvUV(ST(3));
1972 RETVAL = perfSysCall(ulCommand, ulParm1, ulParm2, ulParm3);
1974 croak_with_os2error("perfSysCall() error");
1979 if (GIMME_V != G_ARRAY) {
1980 PUSHn(u[0][0]); /* Total ticks on the first processor */
1983 EXTEND(SP, 4*total);
1984 for (i=0; i < total; i++)
1985 for (j=0; j < 4; j++)
1986 PUSHs(sv_2mortal(newSVnv(u[i][j])));
1997 #define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */
1998 #include "patchlevel.h"
1999 #undef PERL_PATCHLEVEL_H_IMPLICIT
2002 mod2fname(pTHX_ SV *sv)
2004 int pos = 6, len, avlen;
2005 unsigned int sum = 0;
2009 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
2011 if (SvTYPE(sv) != SVt_PVAV)
2012 Perl_croak_nocontext("Not array reference given to mod2fname");
2014 avlen = av_tindex((AV*)sv);
2016 Perl_croak_nocontext("Empty array reference given to mod2fname");
2018 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
2019 strncpy(fname, s, 8);
2021 if (len < 6) pos = len;
2023 sum = 33 * sum + *(s++); /* Checksumming first chars to
2024 * get the capitalization into c.s. */
2027 while (avlen >= 0) {
2028 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
2030 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
2034 /* We always load modules as *specific* DLLs, and with the full name.
2035 When loading a specific DLL by its full name, one cannot get a
2036 different DLL, even if a DLL with the same basename is loaded already.
2037 Thus there is no need to include the version into the mangling scheme. */
2039 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
2041 # ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
2042 # define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
2044 sum += COMPATIBLE_VERSION_SUM;
2046 fname[pos] = 'A' + (sum % 26);
2047 fname[pos + 1] = 'A' + (sum / 26 % 26);
2048 fname[pos + 2] = '\0';
2049 return (char *)fname;
2052 XS(XS_DynaLoader_mod2fname)
2056 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
2062 RETVAL = mod2fname(aTHX_ sv);
2063 sv_setpv(TARG, RETVAL);
2064 XSprePUSH; PUSHTARG;
2075 int number = SvTRUE(get_sv("OS2::nsyserror", GV_ADD));
2077 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
2081 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
2082 s = os2error_buf + strlen(os2error_buf);
2085 if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf),
2086 rc, "OSO001.MSG", &len)) {
2090 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
2091 s = os2error_buf + strlen(os2error_buf);
2094 case PMERR_INVALID_HWND:
2095 name = "PMERR_INVALID_HWND";
2097 case PMERR_INVALID_HMQ:
2098 name = "PMERR_INVALID_HMQ";
2100 case PMERR_CALL_FROM_WRONG_THREAD:
2101 name = "PMERR_CALL_FROM_WRONG_THREAD";
2103 case PMERR_NO_MSG_QUEUE:
2104 name = "PMERR_NO_MSG_QUEUE";
2106 case PMERR_NOT_IN_A_PM_SESSION:
2107 name = "PMERR_NOT_IN_A_PM_SESSION";
2109 case PMERR_INVALID_ATOM:
2110 name = "PMERR_INVALID_ATOM";
2112 case PMERR_INVALID_HATOMTBL:
2113 name = "PMERR_INVALID_HATOMTMB";
2115 case PMERR_INVALID_INTEGER_ATOM:
2116 name = "PMERR_INVALID_INTEGER_ATOM";
2118 case PMERR_INVALID_ATOM_NAME:
2119 name = "PMERR_INVALID_ATOM_NAME";
2121 case PMERR_ATOM_NAME_NOT_FOUND:
2122 name = "PMERR_ATOM_NAME_NOT_FOUND";
2125 sprintf(s, "%s%s[No description found in OSO001.MSG]",
2126 name, (*name ? "=" : ""));
2129 if (len && s[len - 1] == '\n')
2131 if (len && s[len - 1] == '\r')
2133 if (len && s[len - 1] == '.')
2135 if (len >= 10 && number && strnEQ(s, os2error_buf, 7)
2136 && s[7] == ':' && s[8] == ' ')
2137 /* Some messages start with SYSdddd:, some not */
2138 Move(s + 9, s, (len -= 9) + 1, char);
2140 return os2error_buf;
2150 CroakWinError(int die, char *name)
2154 croak_with_os2error(name ? name : "Win* API call");
2158 dllname2buffer(pTHX_ char *buf, STRLEN l)
2164 dll = module_name(mod_name_full);
2169 return (ll >= l ? "???" : buf);
2173 execname2buffer(char *buf, STRLEN l, char *oname)
2175 char *p, *orig = oname, ok = oname != NULL;
2177 if (_execname(buf, l) != 0) {
2178 if (!oname || strlen(oname) >= l)
2188 if (ok && *oname != '/' && *oname != '\\')
2190 } else if (ok && tolower(*oname) != tolower(*p))
2195 if (ok) { /* orig matches the real name. Use orig: */
2196 strcpy(buf, orig); /* _execname() is always uppercased */
2210 char buf[300], *p = execname2buffer(buf, sizeof buf, PL_origargv[0]);
2218 Perl_OS2_handler_install(void *handler, enum Perlos2_handler how)
2223 case Perlos2_handler_mangle:
2224 perllib_mangle_installed = (char *(*)(char *s, unsigned int l))handler;
2226 case Perlos2_handler_perl_sh:
2227 s = (char *)handler;
2228 s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perl_sh");
2229 perl_sh_installed = savepv(s);
2231 case Perlos2_handler_perllib_from:
2232 s = (char *)handler;
2233 s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_from");
2237 case Perlos2_handler_perllib_to:
2238 s = (char *)handler;
2239 s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_to");
2242 strcpy(mangle_ret, newp);
2253 /* Returns a malloc()ed copy */
2255 dir_subst(char *s, unsigned int l, char *b, unsigned int bl, enum dir_subst_e flags, char *msg)
2257 char *from, *to = b, *e = b; /* `to' assignment: shut down the warning */
2258 STRLEN froml = 0, tol = 0, rest = 0; /* froml: likewise */
2260 if (l >= 2 && s[0] == '~') {
2263 from = "installprefix"; break;
2265 from = "dll"; break;
2267 from = "exe"; break;
2270 froml = l + 1; /* Will not match */
2274 froml = strlen(from) + 1;
2275 if (l >= froml && strnicmp(s + 2, from + 1, froml - 2) == 0) {
2281 tol = strlen(INSTALL_PREFIX);
2283 if (flags & dir_subst_fatal)
2284 Perl_croak_nocontext("INSTALL_PREFIX too long: `%s'", INSTALL_PREFIX);
2288 memcpy(b, INSTALL_PREFIX, tol + 1);
2293 if (flags & dir_subst_fatal) {
2296 to = dllname2buffer(aTHX_ b, bl);
2297 } else { /* No Perl present yet */
2298 HMODULE self = find_myself();
2299 APIRET rc = DosQueryModuleName(self, bl, b);
2311 if (flags & dir_subst_fatal) {
2314 to = execname2buffer(b, bl, PL_origargv[0]);
2316 to = execname2buffer(b, bl, NULL);
2322 e = strrchr(to, '/');
2323 if (!e && (flags & dir_subst_fatal))
2324 Perl_croak_nocontext("%s: Can't parse EXE/DLL name: '%s'", msg, to);
2329 s += froml; l -= froml;
2335 while (l >= 3 && (s[0] == '/' || s[0] == '\\')
2336 && s[1] == '.' && s[2] == '.'
2337 && (l == 3 || s[3] == '/' || s[3] == '\\' || s[3] == ';')) {
2338 e = strrchr(b, '/');
2339 if (!e && (flags & dir_subst_fatal))
2340 Perl_croak_nocontext("%s: Error stripping dirs from EXE/DLL/INSTALLDIR name", msg);
2346 if (l && s[0] != '/' && s[0] != '\\' && s[0] != ';')
2349 } /* Else: copy as is */
2350 if (l && (flags & dir_subst_pathlike)) {
2353 while ( i < l - 2 && s[i] != ';') /* May have ~char after `;' */
2355 if (i < l - 2) { /* Found */
2360 if (e + l >= b + bl) {
2361 if (flags & dir_subst_fatal)
2362 Perl_croak_nocontext("%s: name `%s%s' too long", msg, b, s);
2368 e = dir_subst(s + l, rest, e + l, bl - (e + l - b), flags, msg);
2376 perllib_mangle_with(char *s, unsigned int l, char *from, unsigned int froml, char *to, unsigned int tol)
2382 if (l < froml || strnicmp(from, s, froml) != 0)
2384 if (l + tol - froml > STATIC_FILE_LENGTH || tol > STATIC_FILE_LENGTH)
2385 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
2386 if (to && to != mangle_ret)
2387 memcpy(mangle_ret, to, tol);
2388 strcpy(mangle_ret + tol, s + froml);
2393 perllib_mangle(char *s, unsigned int l)
2397 if (perllib_mangle_installed && (name = perllib_mangle_installed(s,l)))
2399 if (!newp && !notfound) {
2400 newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION)
2401 STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION)
2404 newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION)
2405 STRINGIFY(PERL_VERSION) "_PREFIX");
2407 newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX");
2409 newp = getenv(name = "PERLLIB_PREFIX");
2414 while (*newp && !isSPACE(*newp) && *newp != ';')
2415 newp++; /* Skip old name. */
2417 s = dir_subst(oldp, oldl, b, sizeof b, dir_subst_fatal, name);
2420 while (*newp && (isSPACE(*newp) || *newp == ';'))
2421 newp++; /* Skip whitespace. */
2422 Perl_OS2_handler_install((void *)newp, Perlos2_handler_perllib_to);
2423 if (newl == 0 || oldl == 0)
2424 Perl_croak_nocontext("Malformed %s", name);
2432 if (l < oldl || strnicmp(oldp, s, oldl) != 0)
2434 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH)
2435 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
2436 strcpy(mangle_ret + newl, s + oldl);
2441 Perl_hab_GET() /* Needed if perl.h cannot be included */
2443 return perl_hab_GET();
2447 Create_HMQ(int serve, char *message) /* Assumes morphing */
2449 unsigned fpflag = _control87(0,0);
2451 init_PMWIN_entries();
2452 /* 64 messages if before OS/2 3.0, ignored otherwise */
2453 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
2457 SAVEINT(rmq_cnt); /* Allow catch()ing. */
2459 _exit(188); /* Panic can try to create a window. */
2460 CroakWinError(1, message ? message : "Cannot create a message queue");
2463 (*PMWIN_entries.CancelShutdown)(Perl_hmq, !serve);
2464 /* We may have loaded some modules */
2465 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
2468 #define REGISTERMQ_WILL_SERVE 1
2469 #define REGISTERMQ_IMEDIATE_UNMORPH 2
2472 Perl_Register_MQ(int serve)
2474 if (Perl_hmq_refcnt <= 0) {
2478 Perl_hmq_refcnt = 0; /* Be extra safe */
2479 DosGetInfoBlocks(&tib, &pib);
2480 if (!Perl_morph_refcnt) {
2481 Perl_os2_initial_mode = pib->pib_ultype;
2482 /* Try morphing into a PM application. */
2483 if (pib->pib_ultype != 3) /* 2 is VIO */
2484 pib->pib_ultype = 3; /* 3 is PM */
2486 Create_HMQ(-1, /* We do CancelShutdown ourselves */
2487 "Cannot create a message queue, or morph to a PM application");
2488 if ((serve & REGISTERMQ_IMEDIATE_UNMORPH)) {
2489 if (!Perl_morph_refcnt && Perl_os2_initial_mode != 3)
2490 pib->pib_ultype = Perl_os2_initial_mode;
2493 if (serve & REGISTERMQ_WILL_SERVE) {
2494 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
2495 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
2496 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
2498 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
2499 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
2501 if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH))
2502 Perl_morph_refcnt++;
2507 Perl_Serve_Messages(int force)
2512 if (Perl_hmq_servers > 0 && !force)
2514 if (Perl_hmq_refcnt <= 0)
2515 Perl_croak_nocontext("No message queue");
2516 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
2518 if (msg.msg == WM_QUIT)
2519 Perl_croak_nocontext("QUITing...");
2520 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
2526 Perl_Process_Messages(int force, I32 *cntp)
2530 if (Perl_hmq_servers > 0 && !force)
2532 if (Perl_hmq_refcnt <= 0)
2533 Perl_croak_nocontext("No message queue");
2534 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
2537 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
2538 if (msg.msg == WM_DESTROY)
2540 if (msg.msg == WM_CREATE)
2543 Perl_croak_nocontext("QUITing...");
2547 Perl_Deregister_MQ(int serve)
2549 if (serve & REGISTERMQ_WILL_SERVE)
2552 if (--Perl_hmq_refcnt <= 0) {
2553 unsigned fpflag = _control87(0,0);
2555 init_PMWIN_entries(); /* To be extra safe */
2556 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
2558 /* We may have (un)loaded some modules */
2559 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
2560 } else if ((serve & REGISTERMQ_WILL_SERVE) && Perl_hmq_servers <= 0)
2561 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); /* Last server exited */
2562 if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH) && (--Perl_morph_refcnt <= 0)) {
2563 /* Try morphing back from a PM application. */
2567 DosGetInfoBlocks(&tib, &pib);
2568 if (pib->pib_ultype == 3) /* 3 is PM */
2569 pib->pib_ultype = Perl_os2_initial_mode;
2571 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
2576 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
2577 && ((path)[2] == '/' || (path)[2] == '\\'))
2578 #define sys_is_rooted _fnisabs
2579 #define sys_is_relative _fnisrel
2580 #define current_drive _getdrive
2582 #undef chdir /* Was _chdir2. */
2583 #define sys_chdir(p) (chdir(p) == 0)
2584 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
2590 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
2592 int arg1 = SvIV(ST(0));
2593 int arg2 = SvIV(ST(1));
2594 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
2595 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
2596 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
2599 if (CheckOSError(DosError(a)))
2600 Perl_croak_nocontext("DosError(%d) failed: %s", a, os2error(Perl_rc));
2601 ST(0) = sv_newmortal();
2602 if (DOS_harderr_state >= 0)
2603 sv_setiv(ST(0), DOS_harderr_state);
2604 DOS_harderr_state = RETVAL;
2609 XS(XS_OS2_Errors2Drive)
2613 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
2617 int suppress = SvOK(sv);
2618 char *s = suppress ? SvPV(sv, n_a) : NULL;
2619 char drive = (s ? *s : 0);
2622 if (suppress && !isALPHA(drive))
2623 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
2624 if (CheckOSError(DosSuppressPopUps((suppress
2625 ? SPU_ENABLESUPPRESSION
2626 : SPU_DISABLESUPPRESSION),
2628 Perl_croak_nocontext("DosSuppressPopUps(%c) failed: %s", drive,
2630 ST(0) = sv_newmortal();
2631 if (DOS_suppression_state > 0)
2632 sv_setpvn(ST(0), &DOS_suppression_state, 1);
2633 else if (DOS_suppression_state == 0)
2634 sv_setpvn(ST(0), "", 0);
2635 DOS_suppression_state = drive;
2641 async_mssleep(ULONG ms, int switch_priority) {
2642 /* This is similar to DosSleep(), but has 8ms granularity in time-critical
2643 threads even on Warp3. */
2644 HEV hevEvent1 = 0; /* Event semaphore handle */
2645 HTIMER htimerEvent1 = 0; /* Timer handle */
2646 APIRET rc = NO_ERROR; /* Return code */
2648 ULONG priority = 0, nesting; /* Shut down the warnings */
2654 if (!(_emx_env & 0x200)) /* DOS */
2655 return !_sleep2(ms);
2657 os2cp_croak(DosCreateEventSem(NULL, /* Unnamed */
2658 &hevEvent1, /* Handle of semaphore returned */
2659 DC_SEM_SHARED, /* Shared needed for DosAsyncTimer */
2660 FALSE), /* Semaphore is in RESET state */
2661 "DosCreateEventSem");
2663 if (ms >= switch_priority)
2664 switch_priority = 0;
2665 if (switch_priority) {
2666 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
2667 switch_priority = 0;
2669 /* In Warp3, to switch scheduling to 8ms step, one needs to do
2670 DosAsyncTimer() in time-critical thread. On laters versions,
2671 more and more cases of wait-for-something are covered.
2673 It turns out that on Warp3fp42 it is the priority at the time
2674 of DosAsyncTimer() which matters. Let's hope that this works
2675 with later versions too... XXXX
2677 priority = (tib->tib_ptib2->tib2_ulpri);
2678 if ((priority & 0xFF00) == 0x0300) /* already time-critical */
2679 switch_priority = 0;
2680 /* Make us time-critical. Just modifying TIB is not enough... */
2681 /* tib->tib_ptib2->tib2_ulpri = 0x0300;*/
2682 /* We do not want to run at high priority if a signal causes us
2683 to longjmp() out of this section... */
2684 if (DosEnterMustComplete(&nesting))
2685 switch_priority = 0;
2687 DosSetPriority(PRTYS_THREAD, PRTYC_TIMECRITICAL, 0, 0);
2691 if ((badrc = DosAsyncTimer(ms,
2692 (HSEM) hevEvent1, /* Semaphore to post */
2693 &htimerEvent1))) /* Timer handler (returned) */
2694 e = "DosAsyncTimer";
2696 if (switch_priority && tib->tib_ptib2->tib2_ulpri == 0x0300) {
2697 /* Nobody switched priority while we slept... Ignore errors... */
2698 /* tib->tib_ptib2->tib2_ulpri = priority; */ /* Get back... */
2699 if (!(rc = DosSetPriority(PRTYS_THREAD, (priority>>8) & 0xFF, 0, 0)))
2700 rc = DosSetPriority(PRTYS_THREAD, 0, priority & 0xFF, 0);
2702 if (switch_priority)
2703 rc = DosExitMustComplete(&nesting); /* Ignore errors */
2705 /* The actual blocking call is made with "normal" priority. This way we
2706 should not bother with DosSleep(0) etc. to compensate for us interrupting
2707 higher-priority threads. The goal is to prohibit the system spending too
2708 much time halt()ing, not to run us "no matter what". */
2709 if (!e) /* Wait for AsyncTimer event */
2710 badrc = DosWaitEventSem(hevEvent1, SEM_INDEFINITE_WAIT);
2712 if (e) ; /* Do nothing */
2713 else if (badrc == ERROR_INTERRUPT)
2716 e = "DosWaitEventSem";
2717 if ((rc = DosCloseEventSem(hevEvent1)) && !e) { /* Get rid of semaphore */
2718 e = "DosCloseEventSem";
2722 os2cp_croak(badrc, e);
2726 XS(XS_OS2_ms_sleep) /* for testing only... */
2731 if (items > 2 || items < 1)
2732 Perl_croak_nocontext("Usage: OS2::ms_sleep(wait_ms [, high_priority_limit])");
2734 lim = items > 1 ? SvUV(ST(1)) : ms + 1;
2735 async_mssleep(ms, lim);
2739 ULONG (*pDosTmrQueryFreq) (PULONG);
2740 ULONG (*pDosTmrQueryTime) (unsigned long long *);
2746 unsigned long long count;
2750 Perl_croak_nocontext("Usage: OS2::Timer()");
2752 *(PFN*)&pDosTmrQueryFreq = loadByOrdinal(ORD_DosTmrQueryFreq, 0);
2753 *(PFN*)&pDosTmrQueryTime = loadByOrdinal(ORD_DosTmrQueryTime, 0);
2754 MUTEX_LOCK(&perlos2_state_mutex);
2756 if (CheckOSError(pDosTmrQueryFreq(&freq)))
2757 croak_with_os2error("DosTmrQueryFreq");
2758 MUTEX_UNLOCK(&perlos2_state_mutex);
2760 if (CheckOSError(pDosTmrQueryTime(&count)))
2761 croak_with_os2error("DosTmrQueryTime");
2765 XSprePUSH; PUSHn(((NV)count)/freq);
2770 XS(XS_OS2_msCounter)
2775 Perl_croak_nocontext("Usage: OS2::msCounter()");
2779 XSprePUSH; PUSHu(msCounter());
2784 XS(XS_OS2__InfoTable)
2790 Perl_croak_nocontext("Usage: OS2::_infoTable([isLocal])");
2792 is_local = (int)SvIV(ST(0));
2796 XSprePUSH; PUSHu(InfoTable(is_local));
2801 static const char * const dc_fields[] = {
2810 "HORIZONTAL_RESOLUTION",
2811 "VERTICAL_RESOLUTION",
2815 "SMALL_CHAR_HEIGHT",
2819 "COLOR_TABLE_SUPPORT",
2821 "FOREGROUND_MIX_SUPPORT",
2822 "BACKGROUND_MIX_SUPPORT",
2823 "VIO_LOADABLE_FONTS",
2824 "WINDOW_BYTE_ALIGNMENT",
2832 "GRAPHICS_VECTOR_SUBSET",
2834 "ADDITIONAL_GRAPHICS",
2837 "GRAPHICS_CHAR_WIDTH",
2838 "GRAPHICS_CHAR_HEIGHT",
2839 "HORIZONTAL_FONT_RES",
2840 "VERTICAL_FONT_RES",
2843 "DEVICE_POLYSET_POINTS",
2847 DevCap_dc, DevCap_hwnd
2850 HDC (*pWinOpenWindowDC) (HWND hwnd);
2851 HMF (*pDevCloseDC) (HDC hdc);
2852 HDC (*pDevOpenDC) (HAB hab, LONG lType, PCSZ pszToken, LONG lCount,
2853 PDEVOPENDATA pdopData, HDC hdcComp);
2854 BOOL (*pDevQueryCaps) (HDC hdc, LONG lStart, LONG lCount, PLONG alArray);
2861 Perl_croak_nocontext("Usage: OS2::DevCap()");
2863 /* Device Capabilities Data Buffer (10 extra w.r.t. Warp 4.5) */
2864 LONG si[CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1];
2865 int i = 0, j = 0, how = DevCap_dc;
2867 DEVOPENSTRUC doStruc= {0L, (PSZ)"DISPLAY", NULL, 0L, 0L, 0L, 0L, 0L, 0L};
2868 ULONG rc1 = NO_ERROR;
2870 static volatile int devcap_loaded;
2872 if (!devcap_loaded) {
2873 *(PFN*)&pWinOpenWindowDC = loadByOrdinal(ORD_WinOpenWindowDC, 0);
2874 *(PFN*)&pDevOpenDC = loadByOrdinal(ORD_DevOpenDC, 0);
2875 *(PFN*)&pDevCloseDC = loadByOrdinal(ORD_DevCloseDC, 0);
2876 *(PFN*)&pDevQueryCaps = loadByOrdinal(ORD_DevQueryCaps, 0);
2882 if (!items) { /* Get device contents from PM */
2883 hScreenDC = pDevOpenDC(perl_hab_GET(), OD_MEMORY, (PSZ)"*", 0,
2884 (PDEVOPENDATA)&doStruc, NULLHANDLE);
2885 if (CheckWinError(hScreenDC))
2886 croak_with_os2error("DevOpenDC() failed");
2887 } else if (how == DevCap_dc)
2888 hScreenDC = (HDC)SvIV(ST(0));
2889 else { /* DevCap_hwnd */
2891 Perl_croak(aTHX_ "Getting a window's device context without a message queue would lock PM");
2892 hwnd = (HWND)SvIV(ST(0));
2893 hScreenDC = pWinOpenWindowDC(hwnd); /* No need to DevCloseDC() */
2894 if (CheckWinError(hScreenDC))
2895 croak_with_os2error("WinOpenWindowDC() failed");
2897 if (CheckWinError(pDevQueryCaps(hScreenDC,
2898 CAPS_FAMILY, /* W3 documented caps */
2899 CAPS_DEVICE_POLYSET_POINTS
2904 EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1));
2905 while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) {
2906 ST(j) = sv_newmortal();
2907 sv_setpv(ST(j++), dc_fields[i]);
2908 ST(j) = sv_newmortal();
2909 sv_setiv(ST(j++), si[i]);
2912 i = CAPS_DEVICE_POLYSET_POINTS + 1;
2913 while (i < CAPS_DEVICE_POLYSET_POINTS + 11) { /* Just in case... */
2916 if (CheckWinError(pDevQueryCaps(hScreenDC, i, 1, &l)))
2919 ST(j) = sv_newmortal();
2920 sv_setiv(ST(j++), i);
2921 ST(j) = sv_newmortal();
2922 sv_setiv(ST(j++), l);
2926 if (!items && CheckWinError(pDevCloseDC(hScreenDC)))
2927 Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc));
2929 Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed");
2934 LONG (*pWinQuerySysValue) (HWND hwndDesktop, LONG iSysValue);
2935 BOOL (*pWinSetSysValue) (HWND hwndDesktop, LONG iSysValue, LONG lValue);
2937 const char * const sv_keys[] = {
2989 "DESKTOPWORKAREAYTOP",
2990 "DESKTOPWORKAREAYBOTTOM",
2991 "DESKTOPWORKAREAXRIGHT",
2992 "DESKTOPWORKAREAXLEFT",
3002 "MENUROLLDOWNDELAY",
3005 "TASKLISTMOUSEACCESS",
3035 "PRINTSCREEN", /* 97, the last one on one of the DDK header */
3047 /* In recent DDK the limit is 108 */
3050 XS(XS_OS2_SysValues)
3054 Perl_croak_nocontext("Usage: OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP)");
3056 int i = 0, j = 0, which = -1;
3057 HWND hwnd = HWND_DESKTOP;
3058 static volatile int sv_loaded;
3062 *(PFN*)&pWinQuerySysValue = loadByOrdinal(ORD_WinQuerySysValue, 0);
3067 hwnd = (HWND)SvIV(ST(1));
3069 which = (int)SvIV(ST(0));
3071 EXTEND(SP,2*C_ARRAY_LENGTH(sv_keys));
3072 while (i < C_ARRAY_LENGTH(sv_keys)) {
3074 RETVAL = pWinQuerySysValue(hwnd, i);
3076 && !(sv_keys[i][0] >= '0' && sv_keys[i][0] <= '9'
3077 && i <= SV_PRINTSCREEN) ) {
3080 if (i > SV_PRINTSCREEN)
3081 break; /* May be not present on older systems */
3082 croak_with_os2error("SysValues():");
3086 ST(j) = sv_newmortal();
3087 sv_setpv(ST(j++), sv_keys[i]);
3088 ST(j) = sv_newmortal();
3089 sv_setiv(ST(j++), RETVAL);
3097 RETVAL = pWinQuerySysValue(hwnd, which);
3101 croak_with_os2error("SysValues():");
3103 XSprePUSH; PUSHi((IV)RETVAL);
3108 XS(XS_OS2_SysValues_set)
3111 if (items < 2 || items > 3)
3112 Perl_croak_nocontext("Usage: OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP)");
3114 int which = (int)SvIV(ST(0));
3115 LONG val = (LONG)SvIV(ST(1));
3116 HWND hwnd = HWND_DESKTOP;
3117 static volatile int svs_loaded;
3120 *(PFN*)&pWinSetSysValue = loadByOrdinal(ORD_WinSetSysValue, 0);
3125 hwnd = (HWND)SvIV(ST(2));
3126 if (CheckWinError(pWinSetSysValue(hwnd, which, val)))
3127 croak_with_os2error("SysValues_set()");
3132 #define QSV_MAX_WARP3 QSV_MAX_COMP_LENGTH
3134 static const char * const si_fields[] = {
3136 "MAX_TEXT_SESSIONS",
3140 "DYN_PRI_VARIATION",
3158 "FOREGROUND_FS_SESSION",
3159 "FOREGROUND_PROCESS", /* Warp 3 toolkit defines up to this */
3164 "VIRTUALADDRESSLIMIT",
3165 "INT10ENABLED", /* From $TOOLKIT-ddk\DDK\video\rel\os2c\include\base\os2\bsedos.h */
3172 Perl_croak_nocontext("Usage: OS2::SysInfo()");
3174 /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
3175 ULONG si[C_ARRAY_LENGTH(si_fields) + 10];
3176 APIRET rc = NO_ERROR; /* Return code */
3177 int i = 0, j = 0, last = QSV_MAX_WARP3;
3179 if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */
3180 last, /* info for Warp 3 */
3183 croak_with_os2error("DosQuerySysInfo() failed");
3184 while (++last <= C_ARRAY_LENGTH(si)) {
3185 if (CheckOSError(DosQuerySysInfo(last, last, /* One entry only */
3188 if (Perl_rc != ERROR_INVALID_PARAMETER)
3189 croak_with_os2error("DosQuerySysInfo() failed");
3193 last--; /* Count of successfully processed offsets */
3196 ST(j) = sv_newmortal();
3197 if (i < C_ARRAY_LENGTH(si_fields))
3198 sv_setpv(ST(j++), si_fields[i]);
3200 sv_setiv(ST(j++), i + 1);
3201 ST(j) = sv_newmortal();
3202 sv_setuv(ST(j++), si[i]);
3209 XS(XS_OS2_SysInfoFor)
3212 int count = (items == 2 ? (int)SvIV(ST(1)) : 1);
3214 if (items < 1 || items > 2)
3215 Perl_croak_nocontext("Usage: OS2::SysInfoFor(id[,count])");
3217 /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
3218 ULONG si[C_ARRAY_LENGTH(si_fields) + 10];
3219 APIRET rc = NO_ERROR; /* Return code */
3221 int start = (int)SvIV(ST(0));
3223 if (count > C_ARRAY_LENGTH(si) || count <= 0)
3224 Perl_croak(aTHX_ "unexpected count %d for OS2::SysInfoFor()", count);
3225 if (CheckOSError(DosQuerySysInfo(start,
3229 croak_with_os2error("DosQuerySysInfo() failed");
3232 ST(i) = sv_newmortal();
3233 sv_setiv(ST(i), si[i]);
3240 XS(XS_OS2_BootDrive)
3244 Perl_croak_nocontext("Usage: OS2::BootDrive()");
3246 ULONG si[1] = {0}; /* System Information Data Buffer */
3247 APIRET rc = NO_ERROR; /* Return code */
3251 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
3252 (PVOID)si, sizeof(si))))
3253 croak_with_os2error("DosQuerySysInfo() failed");
3254 c = 'a' - 1 + si[0];
3255 sv_setpvn(TARG, &c, 1);
3256 XSprePUSH; PUSHTARG;
3264 if (items > 2) /* Defaults as for WinAlarm(ERROR) */
3265 Perl_croak_nocontext("Usage: OS2::Beep(freq = 440, ms = 100)");
3267 ULONG freq = (items > 0 ? (ULONG)SvUV(ST(0)) : 440);
3268 ULONG ms = (items > 1 ? (ULONG)SvUV(ST(1)) : 100);
3271 if (CheckOSError(DosBeep(freq, ms)))
3272 croak_with_os2error("SysValues_set()");
3283 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
3285 bool serve = SvOK(ST(0));
3286 unsigned long pmq = perl_hmq_GET(serve);
3289 XSprePUSH; PUSHi((IV)pmq);
3294 XS(XS_OS2_UnMorphPM)
3298 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
3300 bool serve = SvOK(ST(0));
3302 perl_hmq_UNSET(serve);
3307 XS(XS_OS2_Serve_Messages)
3311 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
3313 bool force = SvOK(ST(0));
3314 unsigned long cnt = Perl_Serve_Messages(force);
3317 XSprePUSH; PUSHi((IV)cnt);
3322 XS(XS_OS2_Process_Messages)
3325 if (items < 1 || items > 2)
3326 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
3328 bool force = SvOK(ST(0));
3336 (void)SvIV(sv); /* Force SvIVX */
3338 Perl_croak_nocontext("Can't upgrade count to IV");
3340 cnt = Perl_Process_Messages(force, &cntr);
3343 cnt = Perl_Process_Messages(force, NULL);
3345 XSprePUSH; PUSHi((IV)cnt);
3350 XS(XS_Cwd_current_drive)
3354 Perl_croak_nocontext("Usage: Cwd::current_drive()");
3359 RETVAL = current_drive();
3360 sv_setpvn(TARG, (char *)&RETVAL, 1);
3361 XSprePUSH; PUSHTARG;
3366 XS(XS_Cwd_sys_chdir)
3370 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
3373 char * path = (char *)SvPV(ST(0),n_a);
3376 RETVAL = sys_chdir(path);
3377 ST(0) = boolSV(RETVAL);
3378 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3383 XS(XS_Cwd_change_drive)
3387 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
3390 char d = (char)*SvPV(ST(0),n_a);
3393 RETVAL = change_drive(d);
3394 ST(0) = boolSV(RETVAL);
3395 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3400 XS(XS_Cwd_sys_is_absolute)
3404 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
3407 char * path = (char *)SvPV(ST(0),n_a);
3410 RETVAL = sys_is_absolute(path);
3411 ST(0) = boolSV(RETVAL);
3412 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3417 XS(XS_Cwd_sys_is_rooted)
3421 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
3424 char * path = (char *)SvPV(ST(0),n_a);
3427 RETVAL = sys_is_rooted(path);
3428 ST(0) = boolSV(RETVAL);
3429 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3434 XS(XS_Cwd_sys_is_relative)
3438 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
3441 char * path = (char *)SvPV(ST(0),n_a);
3444 RETVAL = sys_is_relative(path);
3445 ST(0) = boolSV(RETVAL);
3446 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3455 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
3460 /* Can't use TARG, since tainting behaves differently */
3461 RETVAL = _getcwd2(p, MAXPATHLEN);
3462 ST(0) = sv_newmortal();
3463 sv_setpv(ST(0), RETVAL);
3464 SvTAINTED_on(ST(0));
3469 XS(XS_Cwd_sys_abspath)
3473 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path = '.', dir = NULL)");
3476 char * path = items ? (char *)SvPV(ST(0),n_a) : ".";
3477 char * dir, *s, *t, *e;
3486 dir = (char *)SvPV(ST(1),n_a);
3488 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
3492 if (_abspath(p, path, MAXPATHLEN) == 0) {
3498 /* Absolute with drive: */
3499 if ( sys_is_absolute(path) ) {
3500 if (_abspath(p, path, MAXPATHLEN) == 0) {
3505 } else if (path[0] == '/' || path[0] == '\\') {
3506 /* Rooted, but maybe on different drive. */
3507 if (isALPHA(dir[0]) && dir[1] == ':' ) {
3508 char p1[MAXPATHLEN];
3510 /* Need to prepend the drive. */
3513 Copy(path, p1 + 2, strlen(path) + 1, char);
3515 if (_abspath(p, p1, MAXPATHLEN) == 0) {
3520 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3526 /* Either path is relative, or starts with a drive letter. */
3527 /* If the path starts with a drive letter, then dir is
3529 a/b) it is absolute/x:relative on the same drive.
3530 c) path is on current drive, and dir is rooted
3531 In all the cases it is safe to drop the drive part
3533 if ( !sys_is_relative(path) ) {
3534 if ( ( ( sys_is_absolute(dir)
3535 || (isALPHA(dir[0]) && dir[1] == ':'
3536 && strnicmp(dir, path,1) == 0))
3537 && strnicmp(dir, path,1) == 0)
3538 || ( !(isALPHA(dir[0]) && dir[1] == ':')
3539 && toupper(path[0]) == current_drive())) {
3541 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3542 RETVAL = p; goto done;
3544 RETVAL = NULL; goto done;
3548 /* Need to prepend the absolute path of dir. */
3549 char p1[MAXPATHLEN];
3551 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
3554 if (p1[ l - 1 ] != '/') {
3558 Copy(path, p1 + l, strlen(path) + 1, char);
3559 if (_abspath(p, p1, MAXPATHLEN) == 0) {
3573 /* Backslashes are already converted to slashes. */
3574 /* Remove trailing slashes */
3576 while (l > 0 && RETVAL[l-1] == '/')
3578 ST(0) = sv_newmortal();
3579 sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
3580 /* Remove duplicate slashes, skipping the first three, which
3581 may be parts of a server-based path */
3582 s = t = 3 + SvPV_force(sv, n_a);
3584 /* Do not worry about multibyte chars here, this would contradict the
3585 eventual UTFization, and currently most other places break too... */
3587 if (s[0] == t[-1] && s[0] == '/')
3588 s++; /* Skip duplicate / */
3594 SvCUR_set(sv, t - SvPVX(sv));
3597 SvTAINTED_on(ST(0));
3601 typedef APIRET (*PELP)(PSZ path, ULONG type);
3603 /* Kernels after 2000/09/15 understand this too: */
3604 #ifndef LIBPATHSTRICT
3605 # define LIBPATHSTRICT 3
3609 ExtLIBPATH(ULONG ord, PSZ path, IV type, int fatal)
3612 PFN f = loadByOrdinal(ord, fatal); /* if fatal: load or die! */
3614 if (!f) /* Impossible with fatal */
3619 what = BEGIN_LIBPATH;
3621 what = LIBPATHSTRICT;
3622 return (*(PELP)f)(path, what);
3625 #define extLibpath(to,type, fatal) \
3626 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type), fatal)) ? NULL : (to) )
3628 #define extLibpath_set(p,type, fatal) \
3629 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type), fatal)))
3632 early_error(char *msg1, char *msg2, char *msg3)
3633 { /* Buffer overflow detected; there is very little we can do... */
3636 DosWrite(2, msg1, strlen(msg1), &rc);
3637 DosWrite(2, msg2, strlen(msg2), &rc);
3638 DosWrite(2, msg3, strlen(msg3), &rc);
3639 DosExit(EXIT_PROCESS, 2);
3642 XS(XS_Cwd_extLibpath)
3645 if (items < 0 || items > 1)
3646 Perl_croak_nocontext("Usage: OS2::extLibpath(type = 0)");
3661 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
3662 RETVAL = extLibpath(to, type, 1); /* Make errors fatal */
3663 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
3664 Perl_croak_nocontext("panic OS2::extLibpath parameter");
3666 if (l >= sizeof(to))
3667 early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `",
3668 to, "'\r\n"); /* Will not return */
3669 sv_setpv(TARG, RETVAL);
3670 XSprePUSH; PUSHTARG;
3675 XS(XS_Cwd_extLibpath_set)
3678 if (items < 1 || items > 2)
3679 Perl_croak_nocontext("Usage: OS2::extLibpath_set(s, type = 0)");
3682 char * s = (char *)SvPV(ST(0),n_a);
3693 RETVAL = extLibpath_set(s, type, 1); /* Make errors fatal */
3694 ST(0) = boolSV(RETVAL);
3695 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3701 fill_extLibpath(int type, char *pre, char *post, int replace, char *msg)
3703 char buf[2048], *to = buf, buf1[300], *s;
3710 pre = dir_subst(pre, strlen(pre), buf1, sizeof buf1, dir_subst_pathlike, msg);
3712 return ERROR_INVALID_PARAMETER;
3714 if (l >= sizeof(buf)/2)
3715 return ERROR_BUFFER_OVERFLOW;
3719 *s = '\\'; /* Be extra cautious */
3721 if (!l || to[l-1] != ';')
3727 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
3728 rc = ExtLIBPATH(ORD_DosQueryExtLibpath, to, type, 0); /* Do not croak */
3731 if (to[0] == 1 && to[1] == 0)
3732 return ERROR_INVALID_PARAMETER;
3734 if (buf + sizeof(buf) - 1 <= to) /* Buffer overflow */
3735 early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `",
3736 buf, "'\r\n"); /* Will not return */
3737 if (to > buf && to[-1] != ';')
3741 post = dir_subst(post, strlen(post), buf1, sizeof buf1, dir_subst_pathlike, msg);
3743 return ERROR_INVALID_PARAMETER;
3745 if (l + to - buf >= sizeof(buf) - 1)
3746 return ERROR_BUFFER_OVERFLOW;
3750 *s = '\\'; /* Be extra cautious */
3751 memcpy(to, post, l);
3752 if (!l || to[l-1] != ';')
3757 rc = ExtLIBPATH(ORD_DosSetExtLibpath, buf, type, 0); /* Do not croak */
3761 /* Input: Address, BufLen
3763 DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3764 ULONG * Offset, ULONG Address);
3767 DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
3768 (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3769 ULONG * Offset, ULONG Address),
3770 (hmod, obj, BufLen, Buf, Offset, Address))
3773 module_name_at(void *pp, enum module_name_how how)
3776 char buf[MAXPATHLEN];
3779 ULONG obj, offset, rc, addr = (ULONG)pp;
3781 if (how & mod_name_HMODULE) {
3782 if ((how & ~mod_name_HMODULE) == mod_name_shortname)
3783 Perl_croak(aTHX_ "Can't get short module name from a handle");
3785 how &= ~mod_name_HMODULE;
3786 } else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr))
3787 return &PL_sv_undef;
3788 if (how == mod_name_handle)
3789 return newSVuv(mod);
3791 if ( how != mod_name_shortname
3792 && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
3793 return &PL_sv_undef;
3799 return newSVpv(buf, 0);
3803 module_name_of_cv(SV *cv, enum module_name_how how)
3805 if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
3808 if (how & mod_name_C_function)
3809 return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function);
3810 else if (how & mod_name_HMODULE)
3811 return module_name_at((void*)SvIV(cv), how);
3812 Perl_croak(aTHX_ "Not an XSUB reference");
3814 return module_name_at(CvXSUB(SvRV(cv)), how);
3821 Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
3827 how = mod_name_full;
3829 how = (int)SvIV(ST(0));
3832 RETVAL = module_name(how);
3834 RETVAL = module_name_of_cv(ST(1), how);
3841 DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo,
3842 (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum),
3843 (r1, r2, buf, szbuf, fnum))
3845 XS(XS_OS2__headerInfo)
3848 if (items > 4 || items < 2)
3849 Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])");
3851 ULONG req = (ULONG)SvIV(ST(0));
3852 STRLEN size = (STRLEN)SvIV(ST(1)), n_a;
3853 ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0);
3854 ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0);
3857 Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size);
3858 ST(0) = newSVpvs("");
3859 SvGROW(ST(0), size + 1);
3862 if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req))
3863 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3864 req, size, handle, offset, os2error(Perl_rc));
3865 SvCUR_set(ST(0), size);
3871 #define DQHI_QUERYLIBPATHSIZE 4
3872 #define DQHI_QUERYLIBPATH 5
3878 Perl_croak(aTHX_ "Usage: OS2::libPath()");
3883 if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size),
3884 DQHI_QUERYLIBPATHSIZE))
3885 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3886 DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0,
3888 ST(0) = newSVpvs("");
3889 SvGROW(ST(0), size + 1);
3892 /* We should be careful: apparently, this entry point does not
3893 pay attention to the size argument, so may overwrite
3895 if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size,
3897 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3898 DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc));
3899 SvCUR_set(ST(0), size);
3905 #define get_control87() _control87(0,0)
3906 #define set_control87 _control87
3908 XS(XS_OS2__control87)
3912 Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
3914 unsigned new = (unsigned)SvIV(ST(0));
3915 unsigned mask = (unsigned)SvIV(ST(1));
3919 RETVAL = _control87(new, mask);
3920 XSprePUSH; PUSHi((IV)RETVAL);
3930 if (items < 0 || items > 1)
3931 Perl_croak(aTHX_ "Usage: OS2::mytype([which])");
3933 which = (int)SvIV(ST(0));
3940 RETVAL = os2_mytype; /* Reset after fork */
3943 RETVAL = os2_mytype_ini; /* Before any fork */
3946 RETVAL = Perl_os2_initial_mode; /* Before first morphing */
3949 RETVAL = my_type(); /* Morphed type */
3952 Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which);
3954 XSprePUSH; PUSHi((IV)RETVAL);
3960 XS(XS_OS2_mytype_set)
3966 type = (int)SvIV(ST(0));
3968 Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)");
3974 XS(XS_OS2_get_control87)
3978 Perl_croak(aTHX_ "Usage: OS2::get_control87()");
3983 RETVAL = get_control87();
3984 XSprePUSH; PUSHi((IV)RETVAL);
3990 XS(XS_OS2_set_control87)
3993 if (items < 0 || items > 2)
3994 Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
4004 new = (unsigned)SvIV(ST(0));
4010 mask = (unsigned)SvIV(ST(1));
4013 RETVAL = set_control87(new, mask);
4014 XSprePUSH; PUSHi((IV)RETVAL);
4019 XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */
4022 if (items < 0 || items > 1)
4023 Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)");
4032 delta = (LONG)SvIV(ST(0));
4034 if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL)))
4035 croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error");
4036 XSprePUSH; PUSHu((UV)RETVAL);
4041 /* wait>0: force wait, wait<0: force nowait;
4042 if restore, save/restore flags; otherwise flags are in oflags.
4044 Returns 1 if connected, 0 if not (due to nowait); croaks on error. */
4046 connectNPipe(ULONG hpipe, int wait, ULONG restore, ULONG oflags)
4048 ULONG ret = ERROR_INTERRUPT, rc, flags;
4050 if (restore && wait)
4051 os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()");
4052 /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */
4053 oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE);
4054 flags = (oflags & ~NP_NOWAIT) | (wait > 0 ? NP_WAIT : NP_NOWAIT);
4055 /* We know (o)flags unless wait == 0 && restore */
4056 if (wait && (flags != oflags))
4057 os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()");
4058 while (ret == ERROR_INTERRUPT)
4059 ret = DosConnectNPipe(hpipe);
4060 (void)CheckOSError(ret);
4061 if (restore && wait && (flags != oflags))
4062 os2cp_croak(DosSetNPHState(hpipe, oflags), "DosSetNPHState() back");
4063 /* We know flags unless wait == 0 && restore */
4064 if ( ((wait || restore) ? (flags & NP_NOWAIT) : 1)
4065 && (ret == ERROR_PIPE_NOT_CONNECTED) )
4066 return 0; /* normal return value */
4067 if (ret == NO_ERROR)
4069 croak_with_os2error("DosConnectNPipe()");
4072 /* With a lot of manual editing:
4074 DosCreateNPipe(PCSZ pszName, OUTLIST HPIPE hpipe, ULONG ulOpenMode, int connect = 1, int count = 1, ULONG ulInbufLength = 8192, ULONG ulOutbufLength = ulInbufLength, ULONG ulPipeMode = count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ULONG ulTimeout = 0)
4078 pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout
4080 if (CheckOSError(RETVAL))
4081 croak_with_os2error("OS2::mkpipe() error");
4083 XS(XS_OS2_pipe); /* prototype to pass -Wmissing-prototypes */
4087 if (items < 2 || items > 8)
4088 Perl_croak(aTHX_ "Usage: OS2::pipe(pszName, ulOpenMode, connect= 1, count= 1, ulInbufLength= 8192, ulOutbufLength= ulInbufLength, ulPipeMode= count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ulTimeout= 0)");
4091 PCSZ pszName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL );
4093 SV *OpenMode = ST(1);
4095 int connect = 0, count, message_r = 0, message = 0, b = 0;
4096 ULONG ulInbufLength, ulOutbufLength, ulPipeMode, ulTimeout, rc;
4098 char *s, buf[10], *s1, *perltype = NULL;
4102 if (!pszName || !*pszName)
4103 Perl_croak(aTHX_ "OS2::pipe(): empty pipe name");
4104 s = SvPV(OpenMode, len);
4105 if (len == 4 && strEQ(s, "wait")) { /* DosWaitNPipe() */
4106 ULONG ms = 0xFFFFFFFF, ret = ERROR_INTERRUPT; /* Indefinite */
4109 timeout = (double)SvNV(ST(2));
4110 ms = timeout * 1000;
4112 ms = 0xFFFFFFFF; /* Indefinite */
4113 else if (timeout && !ms)
4115 } else if (items > 3)
4116 Perl_croak(aTHX_ "OS2::pipe(): too many arguments for wait-for-connect: %ld", (long)items);
4118 while (ret == ERROR_INTERRUPT)
4119 ret = DosWaitNPipe(pszName, ms); /* XXXX Update ms? */
4120 os2cp_croak(ret, "DosWaitNPipe()");
4123 if (len == 4 && strEQ(s, "call")) { /* DosCallNPipe() */
4124 ULONG ms = 0xFFFFFFFF, got; /* Indefinite */
4128 STRLEN ll = sizeof(buf);
4131 if (items < 3 || items > 5)
4132 Perl_croak(aTHX_ "usage: OS2::pipe(pszName, 'call', write [, timeout= 0xFFFFFFFF, buffsize = 8192])");
4135 timeout = (double)SvNV(ST(3));
4136 ms = timeout * 1000;
4138 ms = 0xFFFFFFFF; /* Indefinite */
4139 else if (timeout && !ms)
4143 STRLEN lll = SvUV(ST(4));
4144 SV *sv = NEWSV(914, lll);
4151 os2cp_croak(DosCallNPipe(pszName, s, l, b, ll, &got, ms),
4153 XSRETURN_PVN(b, got);
4156 if (len && len <= 3 && !(*s >= '0' && *s <= '9')) {
4159 r = strchr(s, 'r') != 0;
4160 w = strchr(s, 'w') != 0;
4161 R = strchr(s, 'R') != 0;
4162 W = strchr(s, 'W') != 0;
4163 b = strchr(s, 'b') != 0;
4164 if (r + w + R + W + b != len || (r && R) || (w && W))
4165 Perl_croak(aTHX_ "OS2::pipe(): unknown OpenMode argument: `%s'", s);
4166 if ((r || R) && (w || W))
4167 ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_DUPLEX;
4169 ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_INBOUND;
4171 ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_OUTBOUND;
4173 message = message_r = 1;
4177 Perl_croak(aTHX_ "OS2::pipe(): can't have message read mode for non-message pipes");
4179 ulOpenMode = (ULONG)SvUV(OpenMode); /* ST(1) */
4181 if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX
4182 || (ulOpenMode & 0x3) == NP_ACCESS_INBOUND )
4184 if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX )
4186 if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND )
4191 if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX )
4193 else if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND )
4199 connect = -1; /* no wait */
4200 else if (SvTRUE(ST(2))) {
4201 s = SvPV(ST(2), len);
4202 if (len == 6 && strEQ(s, "nowait"))
4203 connect = -1; /* no wait */
4204 else if (len == 4 && strEQ(s, "wait"))
4205 connect = 1; /* wait */
4207 Perl_croak(aTHX_ "OS2::pipe(): unknown connect argument: `%s'", s);
4213 count = (int)SvIV(ST(3));
4216 ulInbufLength = 8192;
4218 ulInbufLength = (ULONG)SvUV(ST(4));
4221 ulOutbufLength = ulInbufLength;
4223 ulOutbufLength = (ULONG)SvUV(ST(5));
4225 if (count < -1 || count == 0 || count >= 255)
4226 Perl_croak(aTHX_ "OS2::pipe(): count should be -1 or between 1 and 254: %ld", (long)count);
4228 count = 255; /* Unlimited */
4232 ulPipeMode |= (NP_WAIT
4233 | (message ? NP_TYPE_MESSAGE : NP_TYPE_BYTE)
4234 | (message_r ? NP_READMODE_MESSAGE : NP_READMODE_BYTE));
4236 ulPipeMode |= (ULONG)SvUV(ST(6));
4241 timeout = (double)SvNV(ST(7));
4242 ulTimeout = timeout * 1000;
4244 ulTimeout = 0xFFFFFFFF; /* Indefinite */
4245 else if (timeout && !ulTimeout)
4248 RETVAL = DosCreateNPipe(pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout);
4249 if (CheckOSError(RETVAL))
4250 croak_with_os2error("OS2::pipe(): DosCreateNPipe() error");
4253 connectNPipe(hpipe, connect, 1, 0); /* XXXX wait, retval */
4254 hpipe = __imphandle(hpipe);
4256 perlio = PerlIO_fdopen(hpipe, buf);
4257 ST(0) = sv_newmortal();
4259 GV *gv = newGVgen("OS2::pipe");
4260 if ( do_open6(gv, perltype, strlen(perltype), perlio, NULL, 0) )
4261 sv_setsv(ST(0), sv_bless(newRV((SV*)gv), gv_stashpv("IO::Handle",1)));
4263 ST(0) = &PL_sv_undef;
4269 XS(XS_OS2_pipeCntl); /* prototype to pass -Wmissing-prototypes */
4273 if (items < 2 || items > 3)
4274 Perl_croak(aTHX_ "Usage: OS2::pipeCntl(pipe, op [, wait])");
4277 PerlIO *perlio = IoIFP(sv_2io(ST(0)));
4278 IV fn = PerlIO_fileno(perlio);
4279 HPIPE hpipe = (HPIPE)fn;
4281 char *s = SvPV(ST(1), len);
4282 int wait = 0, disconnect = 0, connect = 0, message = -1, query = 0;
4283 int peek = 0, state = 0, info = 0;
4286 Perl_croak(aTHX_ "OS2::pipeCntl(): not a pipe");
4288 wait = (SvTRUE(ST(2)) ? 1 : -1);
4292 if (strEQ(s, "byte"))
4294 else if (strEQ(s, "peek"))
4296 else if (strEQ(s, "info"))
4302 if (strEQ(s, "reset"))
4303 disconnect = connect = 1;
4304 else if (strEQ(s, "state"))
4310 if (strEQ(s, "connect"))
4312 else if (strEQ(s, "message"))
4318 if (!strEQ(s, "readstate"))
4323 if (!strEQ(s, "disconnect"))
4329 Perl_croak(aTHX_ "OS2::pipeCntl(): unknown argument: `%s'", s);
4333 if (items == 3 && !connect)
4334 Perl_croak(aTHX_ "OS2::pipeCntl(): no wait argument for `%s'", s);
4336 XSprePUSH; /* Do not need arguments any more */
4338 os2cp_croak(DosDisConnectNPipe(hpipe), "OS2::pipeCntl(): DosDisConnectNPipe()");
4339 PerlIO_clearerr(perlio);
4342 if (!connectNPipe(hpipe, wait , 1, 0))
4348 os2cp_croak(DosQueryNPHState(hpipe, &flags), "DosQueryNPHState()");
4351 if (peek || state || info) {
4352 ULONG BytesRead, PipeState;
4353 AVAILDATA BytesAvail;
4355 os2cp_croak( DosPeekNPipe(hpipe, NULL, 0, &BytesRead, &BytesAvail,
4356 &PipeState), "DosPeekNPipe() for state");
4360 /* Bytes (available/in-message) */
4361 mPUSHi(BytesAvail.cbpipe);
4362 mPUSHi(BytesAvail.cbmessage);
4366 ID of the (remote) computer
4368 instances (max/actual)
4370 struct pipe_info_t {
4371 ULONG id; /* char id[4]; */
4377 os2cp_croak( DosQueryNPipeInfo(hpipe, 1, &b.pInfo, sizeof(b) - STRUCT_OFFSET(struct pipe_info_t, pInfo)),
4378 "DosQueryNPipeInfo(1)");
4379 os2cp_croak( DosQueryNPipeInfo(hpipe, 2, &b.id, sizeof(b.id)),
4380 "DosQueryNPipeInfo(2)");
4381 size = b.pInfo.cbName;
4382 /* Trailing 0 is included in cbName - undocumented; so
4383 one should always extract with Z* */
4384 if (size) /* name length 254 or less */
4387 size = strlen(b.pInfo.szName);
4389 mPUSHp(b.pInfo.szName, size);
4391 mPUSHi(b.pInfo.cbOut);
4392 mPUSHi(b.pInfo.cbIn);
4393 mPUSHi(b.pInfo.cbMaxInst);
4394 mPUSHi(b.pInfo.cbCurInst);
4396 } else if (BytesAvail.cbpipe == 0) {
4399 SV *tmp = NEWSV(914, BytesAvail.cbpipe);
4400 char *s = SvPVX(tmp);
4403 os2cp_croak( DosPeekNPipe(hpipe, s, BytesAvail.cbpipe, &BytesRead,
4404 &BytesAvail, &PipeState), "DosPeekNPipe()");
4405 SvCUR_set(tmp, BytesRead);
4408 XSprePUSH; PUSHs(tmp);
4413 ULONG oflags, flags;
4415 os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()");
4416 /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */
4417 oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE);
4418 flags = (oflags & NP_NOWAIT)
4419 | (message ? NP_READMODE_MESSAGE : NP_READMODE_BYTE);
4420 if (flags != oflags)
4421 os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()");
4429 DosOpen(PCSZ pszFileName, OUTLIST HFILE hFile, OUTLIST ULONG ulAction, ULONG ulOpenFlags, ULONG ulOpenMode = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ULONG ulAttribute = FILE_NORMAL, ULONG ulFileSize = 0, PEAOP2 pEABuf = NULL);
4433 pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf
4435 if (CheckOSError(RETVAL))
4436 croak_with_os2error("OS2::open() error");
4438 XS(XS_OS2_open); /* prototype to pass -Wmissing-prototypes */
4442 if (items < 2 || items > 6)
4443 Perl_croak(aTHX_ "Usage: OS2::open(pszFileName, ulOpenMode, ulOpenFlags= OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ulAttribute= FILE_NORMAL, ulFileSize= 0, pEABuf= NULL)");
4449 PCSZ pszFileName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL );
4452 ULONG ulOpenMode = (ULONG)SvUV(ST(1));
4459 ulOpenFlags = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW;
4461 ulOpenFlags = (ULONG)SvUV(ST(2));
4465 ulAttribute = FILE_NORMAL;
4467 ulAttribute = (ULONG)SvUV(ST(3));
4473 ulFileSize = (ULONG)SvUV(ST(4));
4479 pEABuf = (PEAOP2)SvUV(ST(5));
4482 RETVAL = DosOpen(pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf);
4483 if (CheckOSError(RETVAL))
4484 croak_with_os2error("OS2::open() error");
4485 XSprePUSH; EXTEND(SP,2);
4486 PUSHs(sv_newmortal());
4487 sv_setuv(ST(0), (UV)hFile);
4488 PUSHs(sv_newmortal());
4489 sv_setuv(ST(1), (UV)ulAction);
4497 char *file = __FILE__;
4501 if (_emx_env & 0x200) { /* OS/2 */
4502 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
4503 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
4504 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
4505 newXS("OS2::extLibpath", XS_Cwd_extLibpath, file);
4506 newXS("OS2::extLibpath_set", XS_Cwd_extLibpath_set, file);
4508 newXS("OS2::Error", XS_OS2_Error, file);
4509 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
4510 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
4511 newXSproto("OS2::DevCap", XS_OS2_DevCap, file, ";$$");
4512 newXSproto("OS2::SysInfoFor", XS_OS2_SysInfoFor, file, "$;$");
4513 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
4514 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
4515 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
4516 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
4517 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
4518 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
4519 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
4520 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
4521 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
4522 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
4523 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
4524 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
4525 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
4526 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
4527 newXS("OS2::replaceModule", XS_OS2_replaceModule, file);
4528 newXS("OS2::perfSysCall", XS_OS2_perfSysCall, file);
4529 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
4530 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
4531 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
4532 newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
4533 newXSproto("OS2::mytype", XS_OS2_mytype, file, ";$");
4534 newXSproto("OS2::mytype_set", XS_OS2_mytype_set, file, "$");
4535 newXSproto("OS2::_headerInfo", XS_OS2__headerInfo, file, "$$;$$");
4536 newXSproto("OS2::libPath", XS_OS2_libPath, file, "");
4537 newXSproto("OS2::Timer", XS_OS2_Timer, file, "");
4538 newXSproto("OS2::msCounter", XS_OS2_msCounter, file, "");
4539 newXSproto("OS2::ms_sleep", XS_OS2_ms_sleep, file, "$;$");
4540 newXSproto("OS2::_InfoTable", XS_OS2__InfoTable, file, ";$");
4541 newXSproto("OS2::incrMaxFHandles", XS_OS2_incrMaxFHandles, file, ";$");
4542 newXSproto("OS2::SysValues", XS_OS2_SysValues, file, ";$$");
4543 newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$");
4544 newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$");
4545 newXSproto("OS2::pipe", XS_OS2_pipe, file, "$$;$$$$$$");
4546 newXSproto("OS2::pipeCntl", XS_OS2_pipeCntl, file, "$$;$");
4547 newXSproto("OS2::open", XS_OS2_open, file, "$$;$$$$");
4548 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
4551 sv_setiv(GvSV(gv), 1);
4553 gv = gv_fetchpv("OS2::is_static", TRUE, SVt_PV);
4556 sv_setiv(GvSV(gv), 1);
4558 gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
4560 sv_setiv(GvSV(gv), exe_is_aout());
4561 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
4563 sv_setiv(GvSV(gv), _emx_rev);
4564 sv_setpv(GvSV(gv), _emx_vprt);
4566 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
4568 sv_setiv(GvSV(gv), _emx_env);
4569 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
4571 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
4572 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
4574 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
4579 extern void _emx_init(void*);
4581 static void jmp_out_of_atexit(void);
4583 #define FORCE_EMX_INIT_CONTRACT_ARGV 1
4584 #define FORCE_EMX_INIT_INSTALL_ATEXIT 2
4587 my_emx_init(void *layout) {
4588 static volatile void *old_esp = 0; /* Cannot be on stack! */
4590 /* Can't just call emx_init(), since it moves the stack pointer */
4591 /* It also busts a lot of registers, so be extra careful */
4599 "popf\n" : : "r" (layout), "m" (old_esp) );
4602 struct layout_table_t {
4623 static ULONG osv_res; /* Cannot be on stack! */
4625 /* Can't just call __os_version(), since it does not follow C
4626 calling convention: it busts a lot of registers, so be extra careful */
4629 "call ___os_version\n"
4632 "popf\n" : "=m" (osv_res) );
4638 force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
4640 /* Calling emx_init() will bust the top of stack: it installs an
4641 exception handler and puts argv data there. */
4642 char *oldarg, *oldenv;
4643 void *oldstackend, *oldstack;
4646 ULONG rc, error = 0, out;
4648 static struct layout_table_t layout_table;
4650 char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
4652 EXCEPTIONREGISTRATIONRECORD xreg;
4656 layout_table.os2_dll = (ULONG)&os2_dll_fake;
4657 layout_table.flags = 0x02000002; /* flags: application, OMF */
4659 DosGetInfoBlocks(&tib, &pib);
4660 oldarg = pib->pib_pchcmd;
4661 oldenv = pib->pib_pchenv;
4662 oldstack = tib->tib_pstack;
4663 oldstackend = tib->tib_pstacklimit;
4665 if ( (char*)&s < (char*)oldstack + 4*1024
4666 || (char *)oldstackend < (char*)oldstack + 52*1024 )
4667 early_error("It is a lunacy to try to run EMX Perl ",
4668 "with less than 64K of stack;\r\n",
4669 " at least with non-EMX starter...\r\n");
4671 /* Minimize the damage to the stack via reducing the size of argv. */
4672 if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
4673 pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */
4674 pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */
4677 newstack = alloca(sizeof(*newstack));
4678 /* Emulate the stack probe */
4679 s = ((char*)newstack) + sizeof(*newstack);
4680 while (s > (char*)newstack) {
4685 /* Reassigning stack is documented to work */
4686 tib->tib_pstack = (void*)newstack;
4687 tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
4689 /* Can't just call emx_init(), since it moves the stack pointer */
4690 my_emx_init((void*)&layout_table);
4692 /* Remove the exception handler, cannot use it - too low on the stack.
4693 Check whether it is inside the new stack. */
4695 if (tib->tib_pexchain >= tib->tib_pstacklimit
4696 || tib->tib_pexchain < tib->tib_pstack) {
4699 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
4700 (unsigned long)tib->tib_pstack,
4701 (unsigned long)tib->tib_pexchain,
4702 (unsigned long)tib->tib_pstacklimit);
4705 if (tib->tib_pexchain != &(newstack->xreg)) {
4706 sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
4707 (unsigned long)tib->tib_pexchain,
4708 (unsigned long)&(newstack->xreg));
4710 rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
4712 sprintf(buf + strlen(buf),
4713 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
4716 /* ExceptionRecords should be on stack, in a correct order. Sigh... */
4717 preg->prev_structure = 0;
4718 preg->ExceptionHandler = _emx_exception;
4719 rc = DosSetExceptionHandler(preg);
4721 sprintf(buf + strlen(buf),
4722 "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
4723 DosWrite(2, buf, strlen(buf), &out);
4724 emx_exception_init = 1; /* Do it around spawn*() calls */
4727 emx_exception_init = 1; /* Do it around spawn*() calls */
4730 /* Restore the damage */
4731 pib->pib_pchcmd = oldarg;
4732 pib->pib_pchcmd = oldenv;
4733 tib->tib_pstacklimit = oldstackend;
4734 tib->tib_pstack = oldstack;
4735 emx_runtime_init = 1;
4737 DosWrite(2, buf, strlen(buf), &out);
4743 jmp_out_of_atexit(void)
4745 if (longjmp_at_exit)
4746 longjmp(at_exit_buf, 1);
4749 extern void _CRT_term(void);
4752 Perl_OS2_term(void **p, int exitstatus, int flags)
4754 if (!emx_runtime_secondary)
4757 /* The principal executable is not running the same CRTL, so there
4758 is nobody to shutdown *this* CRTL except us... */
4759 if (flags & FORCE_EMX_DEINIT_EXIT) {
4760 if (p && !emx_exception_init)
4761 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
4762 /* Do not run the executable's CRTL's termination routines */
4763 exit(exitstatus); /* Run at-exit, flush buffers, etc */
4765 /* Run at-exit list, and jump out at the end */
4766 if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
4767 longjmp_at_exit = 1;
4768 exit(exitstatus); /* The first pass through "if" */
4771 /* Get here if we managed to jump out of exit(), or did not run atexit. */
4772 longjmp_at_exit = 0; /* Maybe exit() is called again? */
4773 #if 0 /* _atexit_n is not exported */
4774 if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
4775 _atexit_n = 0; /* Remove the atexit() handlers */
4777 /* Will segfault on program termination if we leave this dangling... */
4778 if (p && !emx_exception_init)
4779 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
4780 /* Typically there is no need to do this, done from _DLL_InitTerm() */
4781 if (flags & FORCE_EMX_DEINIT_CRT_TERM)
4782 _CRT_term(); /* Flush buffers, etc. */
4783 /* Now it is a good time to call exit() in the caller's CRTL... */
4786 #include <emx/startup.h>
4788 extern ULONG __os_version(); /* See system.doc */
4791 check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
4793 ULONG v_crt, v_emx, count = 0, rc = NO_ERROR, rc1, maybe_inited = 0;
4794 static HMTX hmtx_emx_init = NULLHANDLE;
4795 static int emx_init_done = 0;
4797 /* If _environ is not set, this code sits in a DLL which
4798 uses a CRT DLL which not compatible with the executable's
4799 CRT library. Some parts of the DLL are not initialized.
4801 if (_environ != NULL)
4802 return; /* Properly initialized */
4804 /* It is not DOS, so we may use OS/2 API now */
4805 /* Some data we manipulate is static; protect ourselves from
4806 calling the same API from a different thread. */
4807 DosEnterMustComplete(&count);
4809 rc1 = DosEnterCritSec();
4811 rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/
4816 hmtx_emx_init = NULLHANDLE;
4818 if (rc1 == NO_ERROR)
4820 DosExitMustComplete(&count);
4822 while (maybe_inited) { /* Other thread did or is doing the same now */
4825 rc = DosRequestMutexSem(hmtx_emx_init,
4826 (ULONG) SEM_INDEFINITE_WAIT); /* Timeout (none) */
4827 if (rc == ERROR_INTERRUPT)
4829 if (rc != NO_ERROR) {
4834 "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc);
4835 DosWrite(2, buf, strlen(buf), &out);
4838 DosReleaseMutexSem(hmtx_emx_init);
4842 /* If the executable does not use EMX.DLL, EMX.DLL is not completely
4843 initialized either. Uninitialized EMX.DLL returns 0 in the low
4844 nibble of __os_version(). */
4845 v_emx = my_os_version();
4847 /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
4848 (=>_CRT_init=>_entry2) via a call to __os_version(), then
4849 reset when the EXE initialization code calls _text=>_init=>_entry2.
4850 The first time they are wrongly set to 0; the second time the
4851 EXE initialization code had already called emx_init=>initialize1
4852 which correctly set version_major, version_minor used by
4854 v_crt = (_osmajor | _osminor);
4856 if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */
4857 force_init_emx_runtime( preg,
4858 FORCE_EMX_INIT_CONTRACT_ARGV
4859 | FORCE_EMX_INIT_INSTALL_ATEXIT );
4860 emx_wasnt_initialized = 1;
4861 /* Update CRTL data basing on now-valid EMX runtime data */
4862 if (!v_crt) { /* The only wrong data are the versions. */
4863 v_emx = my_os_version(); /* *Now* it works */
4864 *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
4865 *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
4868 emx_runtime_secondary = 1;
4869 /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
4870 atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */
4872 if (env == NULL) { /* Fetch from the process info block */
4878 DosGetInfoBlocks(&tib, &pib);
4879 e = pib->pib_pchenv;
4880 while (*e) { /* Get count */
4882 e = e + strlen(e) + 1;
4884 Newx(env, c + 1, char*);
4886 e = pib->pib_pchenv;
4889 e = e + strlen(e) + 1;
4893 _environ = _org_environ = env;
4896 DosReleaseMutexSem(hmtx_emx_init);
4899 #define ENTRY_POINT 0x10000
4904 struct layout_table_t *layout;
4905 if (emx_wasnt_initialized)
4907 /* Now we know that the principal executable is an EMX application
4908 - unless somebody did already play with delayed initialization... */
4909 /* With EMX applications to determine whether it is AOUT one needs
4910 to examine the start of the executable to find "layout" */
4911 if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */
4912 || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */
4913 || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */
4914 || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */
4915 return 0; /* ! EMX executable */
4917 Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
4918 return !(layout->flags & 2);
4922 Perl_OS2_init(char **env)
4924 Perl_OS2_init3(env, 0, 0);
4928 Perl_OS2_init3(char **env, void **preg, int flags)
4933 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
4936 check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
4939 OS2_Perl_data.xs_init = &Xs_OS2_init;
4940 if (perl_sh_installed) {
4941 int l = strlen(perl_sh_installed);
4943 Newx(PL_sh_path, l + 1, char);
4944 memcpy(PL_sh_path, perl_sh_installed, l + 1);
4945 } else if ( (shell = getenv("PERL_SH_DRIVE")) ) {
4946 Newx(PL_sh_path, strlen(SH_PATH) + 1, char);
4947 strcpy(PL_sh_path, SH_PATH);
4948 PL_sh_path[0] = shell[0];
4949 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
4950 int l = strlen(shell), i;
4952 while (l && (shell[l-1] == '/' || shell[l-1] == '\\'))
4954 Newx(PL_sh_path, l + 8, char);
4955 strncpy(PL_sh_path, shell, l);
4956 strcpy(PL_sh_path + l, "/sh.exe");
4957 for (i = 0; i < l; i++) {
4958 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
4961 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
4962 MUTEX_INIT(&start_thread_mutex);
4963 MUTEX_INIT(&perlos2_state_mutex);
4965 os2_mytype = my_type(); /* Do it before morphing. Needed? */
4966 os2_mytype_ini = os2_mytype;
4967 Perl_os2_initial_mode = -1; /* Uninit */
4969 s = getenv("PERL_BEGINLIBPATH");
4971 rc = fill_extLibpath(0, s, NULL, 1, "PERL_BEGINLIBPATH");
4973 rc = fill_extLibpath(0, getenv("PERL_PRE_BEGINLIBPATH"), getenv("PERL_POST_BEGINLIBPATH"), 0, "PERL_(PRE/POST)_BEGINLIBPATH");
4975 s = getenv("PERL_ENDLIBPATH");
4977 rc = fill_extLibpath(1, s, NULL, 1, "PERL_ENDLIBPATH");
4979 rc = fill_extLibpath(1, getenv("PERL_PRE_ENDLIBPATH"), getenv("PERL_POST_ENDLIBPATH"), 0, "PERL_(PRE/POST)_ENDLIBPATH");
4984 snprintf(buf, sizeof buf, "Error setting BEGIN/ENDLIBPATH: %s\n",
4986 DosWrite(2, buf, strlen(buf), &rc);
4990 _emxload_env("PERL_EMXLOAD_SECS");
4991 /* Some DLLs reset FP flags on load. We may have been linked with them */
4992 _control87(MCW_EM, MCW_EM);
4998 static ULONG max_fh = 0;
5000 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
5001 if (fd >= max_fh) { /* Renew */
5004 if (DosSetRelMaxFH(&delta, &max_fh)) /* Assume it OK??? */
5010 /* Kernels up to Oct 2003 trap on (invalid) dup(max_fh); [off-by-one + double fault]. */
5012 dup2(int from, int to)
5014 if (fd_ok(from < to ? to : from))
5015 return _dup2(from, to);
5033 my_tmpnam (char *str)
5035 char *p = getenv("TMP"), *tpath;
5037 if (!p) p = getenv("TEMP");
5038 tpath = tempnam(p, "pltmp");
5052 if (s.st_mode & S_IWOTH) {
5055 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
5061 /* EMX flavors do not tolerate trailing slashes. t/op/mkdir.t has many
5062 trailing slashes, so we need to support this as well. */
5065 my_rmdir (__const__ char *s)
5069 STRLEN l = strlen(s);
5072 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
5074 Newx(buf, l + 1, char);
5076 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
5090 my_mkdir (__const__ char *s, long perm)
5094 STRLEN l = strlen(s);
5097 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
5099 Newx(buf, l + 1, char);
5101 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
5106 rc = mkdir(s, perm);
5114 /* This code was contributed by Rocco Caputo. */
5116 my_flock(int handle, int o)
5118 FILELOCK rNull, rFull;
5119 ULONG timeout, handle_type, flag_word;
5121 int blocking, shared;
5122 static int use_my_flock = -1;
5124 if (use_my_flock == -1) {
5125 MUTEX_LOCK(&perlos2_state_mutex);
5126 if (use_my_flock == -1) {
5127 char *s = getenv("USE_PERL_FLOCK");
5129 use_my_flock = atoi(s);
5133 MUTEX_UNLOCK(&perlos2_state_mutex);
5135 if (!(_emx_env & 0x200) || !use_my_flock)
5136 return flock(handle, o); /* Delegate to EMX. */
5138 /* is this a file? */
5139 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
5140 (handle_type & 0xFF))
5145 /* set lock/unlock ranges */
5146 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
5147 rFull.lRange = 0x7FFFFFFF;
5148 /* set timeout for blocking */
5149 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
5150 /* shared or exclusive? */
5151 shared = (o & LOCK_SH) ? 1 : 0;
5152 /* do not block the unlock */
5153 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
5154 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
5159 case ERROR_INVALID_HANDLE:
5162 case ERROR_SHARING_BUFFER_EXCEEDED:
5165 case ERROR_LOCK_VIOLATION:
5166 break; /* not an error */
5167 case ERROR_INVALID_PARAMETER:
5168 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
5169 case ERROR_READ_LOCKS_NOT_SUPPORTED:
5172 case ERROR_INTERRUPT:
5180 /* lock may block */
5181 if (o & (LOCK_SH | LOCK_EX)) {
5182 /* for blocking operations */
5196 case ERROR_INVALID_HANDLE:
5199 case ERROR_SHARING_BUFFER_EXCEEDED:
5202 case ERROR_LOCK_VIOLATION:
5204 errno = EWOULDBLOCK;
5208 case ERROR_INVALID_PARAMETER:
5209 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
5210 case ERROR_READ_LOCKS_NOT_SUPPORTED:
5213 case ERROR_INTERRUPT:
5220 /* give away timeslice */
5232 if (_my_pwent == -1) {
5233 char *s = getenv("USE_PERL_PWENT");
5235 _my_pwent = atoi(s);
5249 if (!use_my_pwent()) {
5250 setpwent(); /* Delegate to EMX. */
5259 if (!use_my_pwent()) {
5260 endpwent(); /* Delegate to EMX. */
5268 if (!use_my_pwent())
5269 return getpwent(); /* Delegate to EMX. */
5271 return 0; /* Return one entry only */
5290 return 0; /* Return one entry only */
5297 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
5298 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
5300 static struct passwd *
5301 passw_wrap(struct passwd *p)
5305 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
5308 s = getenv("PW_PASSWD");
5310 s = (char*)pw_p; /* Make match impossible */
5317 my_getpwuid (uid_t id)
5319 return passw_wrap(getpwuid(id));
5323 my_getpwnam (__const__ char *n)
5325 return passw_wrap(getpwnam(n));
5329 gcvt_os2 (double value, int digits, char *buffer)
5331 double absv = value > 0 ? value : -value;
5332 /* EMX implementation is lousy between 0.1 and 0.0001 (uses exponents below
5333 0.1), 1-digit stuff is ok below 0.001; multi-digit below 0.0001. */
5337 buggy = (absv < 1000 && (absv >= 10 || (absv > 1 && floor(absv) != absv)));
5342 sprintf(pat, "%%.%dg", digits);
5343 sprintf(buffer, pat, value);
5346 return gcvt (value, digits, buffer);
5350 int fork_with_resources()
5352 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
5354 void *ctx = PERL_GET_CONTEXT;
5356 unsigned fpflag = _control87(0,0);
5359 if (rc == 0) { /* child */
5360 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
5361 ALLOC_THREAD_KEY; /* Acquire the thread-local memory */
5362 PERL_SET_CONTEXT(ctx); /* Reinit the thread-local memory */
5365 { /* Reload loaded-on-demand DLLs */
5366 struct dll_handle_t *dlls = dll_handles;
5368 while (dlls->modname) {
5369 char dllname[260], fail[260];
5372 if (!dlls->handle) { /* Was not loaded */
5376 /* It was loaded in the parent. We need to reload it. */
5378 rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname);
5380 Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx",
5381 dlls->modname, (int)dlls->handle, rc, rc);
5385 rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle);
5387 Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'",
5393 { /* Support message queue etc. */
5394 os2_mytype = my_type();
5395 /* Apparently, subprocesses (in particular, fork()) do not
5396 inherit the morphed state, so os2_mytype is the same as
5399 if (Perl_os2_initial_mode != -1
5400 && Perl_os2_initial_mode != os2_mytype) {
5405 (void)_obtain_Perl_HAB;
5406 if (Perl_hmq_refcnt) {
5409 Create_HMQ(Perl_hmq_servers != 0,
5410 "Cannot create a message queue on fork");
5413 /* We may have loaded some modules */
5414 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
5419 /* APIRET APIENTRY DosGetInfoSeg(PSEL pselGlobal, PSEL pselLocal); */
5421 ULONG _THUNK_FUNCTION(Dos16GetInfoSeg)(USHORT *pGlobal, USHORT *pLocal);
5424 myDosGetInfoSeg(PGINFOSEG *pGlobal, PLINFOSEG *pLocal)
5427 USHORT gSel, lSel; /* Will not cross 64K boundary */
5430 (_THUNK_PROLOG (4+4);
5431 _THUNK_FLAT (&gSel);
5432 _THUNK_FLAT (&lSel);
5433 _THUNK_CALL (Dos16GetInfoSeg)));
5436 *pGlobal = MAKEPGINFOSEG(gSel);
5437 *pLocal = MAKEPLINFOSEG(lSel);
5446 MUTEX_LOCK(&perlos2_state_mutex);
5448 rc = myDosGetInfoSeg(&gTable, &lTable);
5449 MUTEX_UNLOCK(&perlos2_state_mutex);
5450 os2cp_croak(rc, "Dos16GetInfoSeg");
5455 { /* XXXX Is not lTable thread-specific? */
5458 return gTable->SIS_MsCount;
5462 InfoTable(int local)
5466 return local ? (ULONG)lTable : (ULONG)gTable;