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. */
974 extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
975 EXCEPTIONREGISTRATIONRECORD *,
980 do_spawn_ve(pTHX_ SV *really, const char **argv, U32 flag, U32 execf, char *inicmd, U32 addflag)
984 char *real_name = NULL; /* Shut down the warning */
985 char const * args[4];
986 static const char * const fargs[4]
987 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
988 const char * const *argsp = fargs;
991 int new_stderr = -1, nostderr = 0;
1000 real_name = SvPV(really, n_a);
1001 real_name = savepv(real_name);
1002 SAVEFREEPV(real_name);
1008 if (strEQ(argv[0],"/bin/sh"))
1009 argv[0] = PL_sh_path;
1011 /* We should check PERL_SH* and PERLLIB_* as well? */
1012 if (!really || pass >= 2)
1013 real_name = argv[0];
1014 if (real_name[0] != '/' && real_name[0] != '\\'
1015 && !(real_name[0] && real_name[1] == ':'
1016 && (real_name[2] == '/' || real_name[2] != '\\'))
1017 ) /* will spawnvp use PATH? */
1018 TAINT_ENV(); /* testing IFS here is overkill, probably */
1022 if (_emx_env & 0x200) { /* OS/2. */
1023 int type = file_type(real_name);
1025 if (type == -1) { /* Not found */
1030 else if (type == -2) { /* Not an EXE */
1035 else if (type == -3) { /* Is a directory? */
1036 /* Special-case this */
1038 int l = strlen(real_name);
1040 if (l + 5 <= sizeof tbuf) {
1041 strcpy(tbuf, real_name);
1042 strcpy(tbuf + l, ".exe");
1043 type = file_type(tbuf);
1053 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
1054 case FAPPTYP_WINDOWAPI:
1055 { /* Apparently, kids are started basing on startup type, not the morphed type */
1056 if (os2_mytype != 3) { /* not PM */
1057 if (flag == P_NOWAIT)
1059 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
1060 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d",
1065 case FAPPTYP_NOTWINDOWCOMPAT:
1067 if (os2_mytype != 0) { /* not full screen */
1068 if (flag == P_NOWAIT)
1070 else if ((flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
1071 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d",
1076 case FAPPTYP_NOTSPEC:
1077 /* Let the shell handle this... */
1079 buf = ""; /* Pacify a warning */
1080 file = 0; /* Pacify a warning */
1088 new_stderr = dup(2); /* Preserve stderr */
1089 if (new_stderr == -1) {
1097 fl_stderr = fcntl(2, F_GETFD);
1101 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
1105 rc = result(aTHX_ trueflag, spawnvp(flag,real_name,argv));
1107 if (execf == EXECF_TRUEEXEC)
1108 rc = execvp(real_name,argv);
1109 else if (execf == EXECF_EXEC)
1110 rc = spawnvp(trueflag | P_OVERLAY,real_name,argv);
1111 else if (execf == EXECF_SPAWN_NOWAIT)
1112 rc = spawnvp(flag,real_name,argv);
1113 else if (execf == EXECF_SYNC)
1114 rc = spawnvp(trueflag,real_name,argv);
1115 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
1116 rc = result(aTHX_ trueflag,
1117 spawnvp(flag,real_name,argv));
1119 if (rc < 0 && pass == 1) {
1121 if (real_name == argv[0]) {
1124 if (err == ENOENT || err == ENOEXEC) {
1125 /* No such file, or is a script. */
1126 /* Try adding script extensions to the file name, and
1128 char *scr = find_script(argv[0], TRUE, NULL, 0);
1132 SV *scrsv = sv_2mortal(newSVpv(scr, 0));
1133 SV *bufsv = sv_newmortal();
1136 scr = SvPV(scrsv, n_a); /* free()ed later */
1138 file = PerlIO_open(scr, "r");
1143 buf = sv_gets(bufsv, file, 0 /* No append */);
1145 buf = ""; /* XXX Needed? */
1146 if (!buf[0]) { /* Empty... */
1147 struct stat statbuf;
1149 /* Special case: maybe from -Zexe build, so
1150 there is an executable around (contrary to
1151 documentation, DosQueryAppType sometimes (?)
1152 does not append ".exe", so we could have
1153 reached this place). */
1154 sv_catpvs(scrsv, ".exe");
1155 argv[0] = scr = SvPV(scrsv, n_a); /* Reload */
1156 if (PerlLIO_stat(scr,&statbuf) >= 0
1157 && !S_ISDIR(statbuf.st_mode)) { /* Found */
1161 } else { /* Restore */
1162 SvCUR_set(scrsv, SvCUR(scrsv) - 4);
1166 if (PerlIO_close(file) != 0) { /* Failure */
1168 if (ckWARN(WARN_EXEC))
1169 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
1170 scr, Strerror(errno));
1171 buf = ""; /* Not #! */
1174 if (buf[0] == '#') {
1177 } else if (buf[0] == 'e') {
1178 if (strBEGINs(buf, "extproc")
1181 } else if (buf[0] == 'E') {
1182 if (strBEGINs(buf, "EXTPROC")
1187 buf = ""; /* Not #! */
1195 /* Do better than pdksh: allow a few args,
1196 strip trailing whitespace. */
1206 while (*s && !isSPACE(*s))
1213 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"",
1214 s1 - buf, buf, scr);
1218 /* Can jump from far, buf/file invalid if force_shell: */
1222 const char *exec_args[2];
1225 || (!buf[0] && file)) { /* File without magic */
1226 /* In fact we tried all what pdksh would
1227 try. There is no point in calling
1228 pdksh, we may just emulate its logic. */
1229 char *shell = getenv("EXECSHELL");
1230 char *shell_opt = NULL;
1236 shell = getenv("OS2_SHELL");
1237 if (inicmd) { /* No spaces at start! */
1239 while (*s && !isSPACE(*s)) {
1241 inicmd = NULL; /* Cannot use */
1249 /* Dosish shells will choke on slashes
1250 in paths, fortunately, this is
1251 important for zeroth arg only. */
1258 /* If EXECSHELL is set, we do not set */
1261 shell = ((_emx_env & 0x200)
1263 : "c:/command.com");
1264 nargs = shell_opt ? 2 : 1; /* shell file args */
1265 exec_args[0] = shell;
1266 exec_args[1] = shell_opt;
1268 if (nargs == 2 && inicmd) {
1269 /* Use the original cmd line */
1270 /* XXXX This is good only until we refuse
1271 quoted arguments... */
1275 } else if (!buf[0] && inicmd) { /* No file */
1276 /* Start with the original cmdline. */
1277 /* XXXX This is good only until we refuse
1278 quoted arguments... */
1282 nargs = 2; /* shell -c */
1285 while (a[1]) /* Get to the end */
1287 a++; /* Copy finil NULL too */
1289 *(a + nargs) = *a; /* argv was preallocated to be
1293 while (--nargs >= 0) /* XXXX Discard const... */
1294 argv[nargs] = (char*)argsp[nargs];
1295 /* Enable pathless exec if #! (as pdksh). */
1296 pass = (buf[0] == '#' ? 2 : 3);
1300 /* Not found: restore errno */
1303 } else if (errno == ENOEXEC) { /* Cannot transfer `real_name' via shell. */
1304 if (rc < 0 && ckWARN(WARN_EXEC))
1305 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s script `%s' with ARGV[0] being `%s'",
1306 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1307 ? "spawn" : "exec"),
1308 real_name, argv[0]);
1310 } else if (errno == ENOENT) { /* Cannot transfer `real_name' via shell. */
1311 if (rc < 0 && ckWARN(WARN_EXEC))
1312 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)",
1313 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1314 ? "spawn" : "exec"),
1315 real_name, argv[0]);
1318 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
1319 char *no_dir = strrchr(argv[0], '/');
1321 /* Do as pdksh port does: if not found with /, try without
1324 argv[0] = no_dir + 1;
1329 if (rc < 0 && ckWARN(WARN_EXEC))
1330 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n",
1331 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1332 ? "spawn" : "exec"),
1333 real_name, Strerror(errno));
1335 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
1336 && ((trueflag & 0xFF) == P_WAIT))
1340 if (new_stderr != -1) { /* How can we use error codes? */
1341 dup2(new_stderr, 2);
1343 fcntl(2, F_SETFD, fl_stderr);
1344 } else if (nostderr)
1349 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
1351 do_spawn3(pTHX_ char *cmd, int execf, int flag)
1355 char *shell, *copt, *news = NULL;
1356 int rc, seenspace = 0, mergestderr = 0;
1360 if ((shell = getenv("EMXSHELL")) != NULL)
1362 else if ((shell = getenv("SHELL")) != NULL)
1364 else if ((shell = getenv("COMSPEC")) != NULL)
1369 /* Consensus on perl5-porters is that it is _very_ important to
1370 have a shell which will not change between computers with the
1371 same architecture, to avoid "action on a distance".
1372 And to have simple build, this shell should be sh. */
1377 while (*cmd && isSPACE(*cmd))
1380 if (strBEGINs(cmd,"/bin/sh") && isSPACE(cmd[7])) {
1381 STRLEN l = strlen(PL_sh_path);
1383 Newx(news, strlen(cmd) - 7 + l + 1, char);
1384 strcpy(news, PL_sh_path);
1385 strcpy(news + l, cmd + 7);
1389 /* save an extra exec if possible */
1390 /* see if there are shell metacharacters in it */
1392 if (*cmd == '.' && isSPACE(cmd[1]))
1395 if (strBEGINs(cmd,"exec") && isSPACE(cmd[4]))
1398 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
1402 for (s = cmd; *s; s++) {
1403 if (*s != ' ' && !isALPHA(*s) && memCHRs("$&*(){}[]'\";\\|?<>~`\n",*s)) {
1404 if (*s == '\n' && s[1] == '\0') {
1407 } else if (*s == '\\' && !seenspace) {
1408 continue; /* Allow backslashes in names */
1409 } else if (*s == '>' && s >= cmd + 3
1410 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
1411 && isSPACE(s[-2]) ) {
1414 while (*t && isSPACE(*t))
1419 break; /* Allow 2>&1 as the last thing */
1422 /* We do not convert this to do_spawn_ve since shell
1423 should be smart enough to start itself gloriously. */
1425 if (execf == EXECF_TRUEEXEC)
1426 rc = execl(shell,shell,copt,cmd,(char*)0);
1427 else if (execf == EXECF_EXEC)
1428 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
1429 else if (execf == EXECF_SPAWN_NOWAIT)
1430 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
1431 else if (execf == EXECF_SPAWN_BYFLAG)
1432 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
1434 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
1435 if (execf == EXECF_SYNC)
1436 rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0);
1438 rc = result(aTHX_ P_WAIT,
1439 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
1440 if (rc < 0 && ckWARN(WARN_EXEC))
1441 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
1442 (execf == EXECF_SPAWN ? "spawn" : "exec"),
1443 shell, Strerror(errno));
1450 } else if (*s == ' ' || *s == '\t') {
1455 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
1456 Newx(argv, (s - cmd + 11) / 2, char*);
1458 cmd = savepvn(cmd, s-cmd);
1461 for (s = cmd; *s;) {
1462 while (*s && isSPACE(*s)) s++;
1465 while (*s && !isSPACE(*s)) s++;
1471 rc = do_spawn_ve(aTHX_ NULL, argv, flag, execf, cmd, mergestderr);
1481 #define ASPAWN_WAIT 0
1482 #define ASPAWN_EXEC 1
1483 #define ASPAWN_NOWAIT 2
1485 /* Array spawn/exec. */
1487 os2_aspawn_4(pTHX_ SV *really, SV **args, I32 cnt, int execing)
1489 SV **argp = (SV **)args;
1490 SV **last = argp + cnt;
1493 int flag = P_WAIT, flag_set = 0;
1498 Newx(argv, cnt + 3, char*); /* 3 extra to expand #! */
1502 if (cnt > 1 && SvNIOKp(*argp) && !SvPOKp(*argp)) {
1503 flag = SvIVx(*argp);
1508 while (++argp < last) {
1510 char *arg = SvPVx(*argp, n_a);
1519 if ( flag_set && (a == argv + 1)
1520 && !really && execing == ASPAWN_WAIT ) { /* One arg? */
1521 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
1523 const int execf[3] = {EXECF_SPAWN, EXECF_EXEC, EXECF_SPAWN_NOWAIT};
1525 rc = do_spawn_ve(aTHX_ really, argv, flag, execf[execing], NULL, 0);
1535 os2_do_aspawn(pTHX_ SV *really, SV **vmark, SV **vsp)
1537 return os2_aspawn_4(aTHX_ really, vmark + 1, vsp - vmark, ASPAWN_WAIT);
1542 Perl_do_aexec(pTHX_ SV* really, SV** vmark, SV** vsp)
1544 return os2_aspawn_4(aTHX_ really, vmark + 1, vsp - vmark, ASPAWN_EXEC);
1548 os2_do_spawn(pTHX_ char *cmd)
1550 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
1554 do_spawn_nowait(pTHX_ char *cmd)
1556 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1560 Perl_do_exec(pTHX_ const char *cmd)
1562 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1567 os2exec(pTHX_ char *cmd)
1569 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1573 my_syspopen4(pTHX_ char *cmd, char *mode, I32 cnt, SV** args)
1577 I32 this, that, newfd;
1580 int fh_fl = 0; /* Pacify the warning */
1582 /* `this' is what we use in the parent, `that' in the child. */
1583 this = (*mode == 'w');
1587 taint_proper("Insecure %s%s", "EXEC");
1591 /* Now we need to spawn the child. */
1592 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1593 int new = dup(p[this]);
1600 newfd = dup(*mode == 'r'); /* Preserve std* */
1602 /* This cannot happen due to fh being bad after pipe(), since
1603 pipe() should have created fh 0 and 1 even if they were
1604 initially closed. But we closed p[this] before. */
1605 if (errno != EBADF) {
1612 fh_fl = fcntl(*mode == 'r', F_GETFD);
1613 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1614 dup2(p[that], *mode == 'r');
1617 /* Where is `this' and newfd now? */
1618 fcntl(p[this], F_SETFD, FD_CLOEXEC);
1620 fcntl(newfd, F_SETFD, FD_CLOEXEC);
1621 if (cnt) { /* Args: "Real cmd", before first arg, the last, execing */
1622 pid = os2_aspawn_4(aTHX_ NULL, args, cnt, ASPAWN_NOWAIT);
1624 pid = do_spawn_nowait(aTHX_ cmd);
1626 close(*mode == 'r'); /* It was closed initially */
1627 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1628 dup2(newfd, *mode == 'r'); /* Return std* back. */
1630 fcntl(*mode == 'r', F_SETFD, fh_fl);
1632 fcntl(*mode == 'r', F_SETFD, fh_fl);
1633 if (p[that] == (*mode == 'r'))
1639 if (p[that] < p[this]) { /* Make fh as small as possible */
1640 dup2(p[this], p[that]);
1644 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1645 (void)SvUPGRADE(sv,SVt_IV);
1647 PL_forkprocess = pid;
1648 return PerlIO_fdopen(p[this], mode);
1650 #else /* USE_POPEN */
1656 Perl_croak(aTHX_ "List form of piped open not implemented");
1659 res = popen(cmd, mode);
1661 char *shell = getenv("EMXSHELL");
1663 my_setenv("EMXSHELL", PL_sh_path);
1664 res = popen(cmd, mode);
1665 my_setenv("EMXSHELL", shell);
1667 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1668 (void)SvUPGRADE(sv,SVt_IV);
1669 SvIVX(sv) = -1; /* A cooky. */
1672 #endif /* USE_POPEN */
1677 my_syspopen(pTHX_ char *cmd, char *mode)
1679 return my_syspopen4(aTHX_ cmd, mode, 0, NULL);
1682 /******************************************************************/
1688 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1694 /*******************************************************************/
1695 /* not implemented in EMX 0.9d */
1697 char * ctermid(char *s) { return 0; }
1699 #ifdef MYTTYNAME /* was not in emx0.9a */
1700 void * ttyname(x) { return 0; }
1703 /*****************************************************************************/
1704 /* not implemented in C Set++ */
1707 int setuid(x) { errno = EINVAL; return -1; }
1708 int setgid(x) { errno = EINVAL; return -1; }
1711 /*****************************************************************************/
1712 /* stat() hack for char/block device */
1716 enum os2_stat_extra { /* EMX 0.9d fix 4 defines up to 0100000 */
1717 os2_stat_archived = 0x1000000, /* 0100000000 */
1718 os2_stat_hidden = 0x2000000, /* 0200000000 */
1719 os2_stat_system = 0x4000000, /* 0400000000 */
1720 os2_stat_force = 0x8000000, /* Do not ignore flags on chmod */
1723 #define OS2_STAT_SPECIAL (os2_stat_system | os2_stat_archived | os2_stat_hidden)
1726 massage_os2_attr(struct stat *st)
1728 if ( ((st->st_mode & S_IFMT) != S_IFREG
1729 && (st->st_mode & S_IFMT) != S_IFDIR)
1730 || !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM)))
1733 if ( st->st_attr & FILE_ARCHIVED )
1734 st->st_mode |= (os2_stat_archived | os2_stat_force);
1735 if ( st->st_attr & FILE_HIDDEN )
1736 st->st_mode |= (os2_stat_hidden | os2_stat_force);
1737 if ( st->st_attr & FILE_SYSTEM )
1738 st->st_mode |= (os2_stat_system | os2_stat_force);
1741 /* First attempt used DosQueryFSAttach which crashed the system when
1742 used with 5.001. Now just look for /dev/. */
1744 os2_stat(const char *name, struct stat *st)
1746 static int ino = SHRT_MAX;
1747 STRLEN l = strlen(name);
1749 if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0
1750 || ( stricmp(name + 5, "con") != 0
1751 && stricmp(name + 5, "tty") != 0
1752 && stricmp(name + 5, "nul") != 0
1753 && stricmp(name + 5, "null") != 0) ) {
1754 int s = stat(name, st);
1758 massage_os2_attr(st);
1762 memset(st, 0, sizeof *st);
1763 st->st_mode = S_IFCHR|0666;
1764 MUTEX_LOCK(&perlos2_state_mutex);
1765 st->st_ino = (ino-- & 0x7FFF);
1766 MUTEX_UNLOCK(&perlos2_state_mutex);
1772 os2_fstat(int handle, struct stat *st)
1774 int s = fstat(handle, st);
1778 massage_os2_attr(st);
1784 os2_chmod (const char *name, int pmode) /* Modelled after EMX src/lib/io/chmod.c */
1788 if (!(pmode & os2_stat_force))
1789 return chmod(name, pmode);
1791 attr = __chmod (name, 0, 0); /* Get attributes */
1794 if (pmode & S_IWRITE)
1795 attr &= ~FILE_READONLY;
1797 attr |= FILE_READONLY;
1799 attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM);
1801 if ( pmode & os2_stat_archived )
1802 attr |= FILE_ARCHIVED;
1803 if ( pmode & os2_stat_hidden )
1804 attr |= FILE_HIDDEN;
1805 if ( pmode & os2_stat_system )
1806 attr |= FILE_SYSTEM;
1808 rc = __chmod (name, 1, attr);
1809 if (rc >= 0) rc = 0;
1815 #ifdef USE_PERL_SBRK
1817 /* SBRK() emulation, mostly moved to malloc.c. */
1820 sys_alloc(int size) {
1822 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1824 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1827 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1831 #endif /* USE_PERL_SBRK */
1835 const char *tmppath = TMPPATH1;
1840 char *p = getenv("TMP"), *tpath;
1843 if (!p) p = getenv("TEMP");
1844 if (!p) p = getenv("TMPDIR");
1847 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1851 strcpy(tpath + len + 1, TMPPATH1);
1858 XS(XS_File__Copy_syscopy)
1861 if (items < 2 || items > 3)
1862 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1865 char * src = (char *)SvPV(ST(0),n_a);
1866 char * dst = (char *)SvPV(ST(1),n_a);
1874 flag = (unsigned long)SvIV(ST(2));
1877 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1878 XSprePUSH; PUSHi((IV)RETVAL);
1883 /* APIRET APIENTRY DosReplaceModule (PCSZ pszOld, PCSZ pszNew, PCSZ pszBackup); */
1885 DeclOSFuncByORD(ULONG,replaceModule,ORD_DosReplaceModule,
1886 (char *old, char *new, char *backup), (old, new, backup))
1888 XS(XS_OS2_replaceModule); /* prototype to pass -Wmissing-prototypes */
1889 XS(XS_OS2_replaceModule)
1892 if (items < 1 || items > 3)
1893 Perl_croak(aTHX_ "Usage: OS2::replaceModule(target [, source [, backup]])");
1895 char * target = (char *)SvPV_nolen(ST(0));
1896 char * source = (items < 2) ? NULL : (char *)SvPV_nolen(ST(1));
1897 char * backup = (items < 3) ? NULL : (char *)SvPV_nolen(ST(2));
1899 if (!replaceModule(target, source, backup))
1900 croak_with_os2error("replaceModule() error");
1905 /* APIRET APIENTRY DosPerfSysCall(ULONG ulCommand, ULONG ulParm1,
1906 ULONG ulParm2, ULONG ulParm3); */
1908 DeclOSFuncByORD(ULONG,perfSysCall,ORD_DosPerfSysCall,
1909 (ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3),
1910 (ulCommand, ulParm1, ulParm2, ulParm3))
1912 #ifndef CMD_KI_RDCNT
1913 # define CMD_KI_RDCNT 0x63
1915 #ifndef CMD_KI_GETQTY
1916 # define CMD_KI_GETQTY 0x41
1918 #ifndef QSV_NUMPROCESSORS
1919 # define QSV_NUMPROCESSORS 26
1922 typedef unsigned long long myCPUUTIL[4]; /* time/idle/busy/intr */
1926 perfSysCall(ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3)
1931 croak_with_os2error("perfSysCall() error");
1939 if (DosQuerySysInfo(QSV_NUMPROCESSORS, QSV_NUMPROCESSORS, (PVOID)&res, sizeof(res)))
1940 return 1; /* Old system? */
1944 XS(XS_OS2_perfSysCall); /* prototype to pass -Wmissing-prototypes */
1945 XS(XS_OS2_perfSysCall)
1948 if (items < 0 || items > 4)
1949 Perl_croak(aTHX_ "Usage: OS2::perfSysCall(ulCommand = CMD_KI_RDCNT, ulParm1= 0, ulParm2= 0, ulParm3= 0)");
1953 ULONG RETVAL, ulCommand, ulParm1, ulParm2, ulParm3, res;
1955 int total = 0, tot2 = 0;
1958 ulCommand = CMD_KI_RDCNT;
1960 ulCommand = (ULONG)SvUV(ST(0));
1964 total = (ulCommand == CMD_KI_RDCNT ? numprocessors() : 0);
1965 ulParm1 = (total ? (ULONG)u : 0);
1967 if (total > C_ARRAY_LENGTH(u))
1968 croak("Unexpected number of processors: %d", total);
1970 ulParm1 = (ULONG)SvUV(ST(1));
1974 tot2 = (ulCommand == CMD_KI_GETQTY);
1975 ulParm2 = (tot2 ? (ULONG)&res : 0);
1977 ulParm2 = (ULONG)SvUV(ST(2));
1983 ulParm3 = (ULONG)SvUV(ST(3));
1986 RETVAL = perfSysCall(ulCommand, ulParm1, ulParm2, ulParm3);
1988 croak_with_os2error("perfSysCall() error");
1993 if (GIMME_V != G_ARRAY) {
1994 PUSHn(u[0][0]); /* Total ticks on the first processor */
1997 EXTEND(SP, 4*total);
1998 for (i=0; i < total; i++)
1999 for (j=0; j < 4; j++)
2000 PUSHs(sv_2mortal(newSVnv(u[i][j])));
2011 #define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */
2012 #include "patchlevel.h"
2013 #undef PERL_PATCHLEVEL_H_IMPLICIT
2016 mod2fname(pTHX_ SV *sv)
2018 int pos = 6, len, avlen;
2019 unsigned int sum = 0;
2023 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
2025 if (SvTYPE(sv) != SVt_PVAV)
2026 Perl_croak_nocontext("Not array reference given to mod2fname");
2028 avlen = av_tindex((AV*)sv);
2030 Perl_croak_nocontext("Empty array reference given to mod2fname");
2032 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
2033 strncpy(fname, s, 8);
2035 if (len < 6) pos = len;
2037 sum = 33 * sum + *(s++); /* Checksumming first chars to
2038 * get the capitalization into c.s. */
2041 while (avlen >= 0) {
2042 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
2044 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
2048 /* We always load modules as *specific* DLLs, and with the full name.
2049 When loading a specific DLL by its full name, one cannot get a
2050 different DLL, even if a DLL with the same basename is loaded already.
2051 Thus there is no need to include the version into the mangling scheme. */
2053 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
2055 # ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
2056 # define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
2058 sum += COMPATIBLE_VERSION_SUM;
2060 fname[pos] = 'A' + (sum % 26);
2061 fname[pos + 1] = 'A' + (sum / 26 % 26);
2062 fname[pos + 2] = '\0';
2063 return (char *)fname;
2066 XS(XS_DynaLoader_mod2fname)
2070 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
2076 RETVAL = mod2fname(aTHX_ sv);
2077 sv_setpv(TARG, RETVAL);
2078 XSprePUSH; PUSHTARG;
2089 int number = SvTRUE(get_sv("OS2::nsyserror", GV_ADD));
2091 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
2095 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
2096 s = os2error_buf + strlen(os2error_buf);
2099 if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf),
2100 rc, "OSO001.MSG", &len)) {
2104 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
2105 s = os2error_buf + strlen(os2error_buf);
2108 case PMERR_INVALID_HWND:
2109 name = "PMERR_INVALID_HWND";
2111 case PMERR_INVALID_HMQ:
2112 name = "PMERR_INVALID_HMQ";
2114 case PMERR_CALL_FROM_WRONG_THREAD:
2115 name = "PMERR_CALL_FROM_WRONG_THREAD";
2117 case PMERR_NO_MSG_QUEUE:
2118 name = "PMERR_NO_MSG_QUEUE";
2120 case PMERR_NOT_IN_A_PM_SESSION:
2121 name = "PMERR_NOT_IN_A_PM_SESSION";
2123 case PMERR_INVALID_ATOM:
2124 name = "PMERR_INVALID_ATOM";
2126 case PMERR_INVALID_HATOMTBL:
2127 name = "PMERR_INVALID_HATOMTMB";
2129 case PMERR_INVALID_INTEGER_ATOM:
2130 name = "PMERR_INVALID_INTEGER_ATOM";
2132 case PMERR_INVALID_ATOM_NAME:
2133 name = "PMERR_INVALID_ATOM_NAME";
2135 case PMERR_ATOM_NAME_NOT_FOUND:
2136 name = "PMERR_ATOM_NAME_NOT_FOUND";
2139 sprintf(s, "%s%s[No description found in OSO001.MSG]",
2140 name, (*name ? "=" : ""));
2143 if (len && s[len - 1] == '\n')
2145 if (len && s[len - 1] == '\r')
2147 if (len && s[len - 1] == '.')
2149 if (len >= 10 && number && strnEQ(s, os2error_buf, 7)
2150 && s[7] == ':' && s[8] == ' ')
2151 /* Some messages start with SYSdddd:, some not */
2152 Move(s + 9, s, (len -= 9) + 1, char);
2154 return os2error_buf;
2164 CroakWinError(int die, char *name)
2168 croak_with_os2error(name ? name : "Win* API call");
2172 dllname2buffer(pTHX_ char *buf, STRLEN l)
2178 dll = module_name(mod_name_full);
2183 return (ll >= l ? "???" : buf);
2187 execname2buffer(char *buf, STRLEN l, char *oname)
2189 char *p, *orig = oname, ok = oname != NULL;
2191 if (_execname(buf, l) != 0) {
2192 if (!oname || strlen(oname) >= l)
2202 if (ok && *oname != '/' && *oname != '\\')
2204 } else if (ok && tolower(*oname) != tolower(*p))
2209 if (ok) { /* orig matches the real name. Use orig: */
2210 strcpy(buf, orig); /* _execname() is always uppercased */
2224 char buf[300], *p = execname2buffer(buf, sizeof buf, PL_origargv[0]);
2232 Perl_OS2_handler_install(void *handler, enum Perlos2_handler how)
2237 case Perlos2_handler_mangle:
2238 perllib_mangle_installed = (char *(*)(char *s, unsigned int l))handler;
2240 case Perlos2_handler_perl_sh:
2241 s = (char *)handler;
2242 s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perl_sh");
2243 perl_sh_installed = savepv(s);
2245 case Perlos2_handler_perllib_from:
2246 s = (char *)handler;
2247 s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_from");
2251 case Perlos2_handler_perllib_to:
2252 s = (char *)handler;
2253 s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_to");
2256 strcpy(mangle_ret, newp);
2267 /* Returns a malloc()ed copy */
2269 dir_subst(char *s, unsigned int l, char *b, unsigned int bl, enum dir_subst_e flags, char *msg)
2271 char *from, *to = b, *e = b; /* `to' assignment: shut down the warning */
2272 STRLEN froml = 0, tol = 0, rest = 0; /* froml: likewise */
2274 if (l >= 2 && s[0] == '~') {
2277 from = "installprefix"; break;
2279 from = "dll"; break;
2281 from = "exe"; break;
2284 froml = l + 1; /* Will not match */
2288 froml = strlen(from) + 1;
2289 if (l >= froml && strnicmp(s + 2, from + 1, froml - 2) == 0) {
2295 tol = strlen(INSTALL_PREFIX);
2297 if (flags & dir_subst_fatal)
2298 Perl_croak_nocontext("INSTALL_PREFIX too long: `%s'", INSTALL_PREFIX);
2302 memcpy(b, INSTALL_PREFIX, tol + 1);
2307 if (flags & dir_subst_fatal) {
2310 to = dllname2buffer(aTHX_ b, bl);
2311 } else { /* No Perl present yet */
2312 HMODULE self = find_myself();
2313 APIRET rc = DosQueryModuleName(self, bl, b);
2325 if (flags & dir_subst_fatal) {
2328 to = execname2buffer(b, bl, PL_origargv[0]);
2330 to = execname2buffer(b, bl, NULL);
2336 e = strrchr(to, '/');
2337 if (!e && (flags & dir_subst_fatal))
2338 Perl_croak_nocontext("%s: Can't parse EXE/DLL name: '%s'", msg, to);
2343 s += froml; l -= froml;
2349 while (l >= 3 && (s[0] == '/' || s[0] == '\\')
2350 && s[1] == '.' && s[2] == '.'
2351 && (l == 3 || s[3] == '/' || s[3] == '\\' || s[3] == ';')) {
2352 e = strrchr(b, '/');
2353 if (!e && (flags & dir_subst_fatal))
2354 Perl_croak_nocontext("%s: Error stripping dirs from EXE/DLL/INSTALLDIR name", msg);
2360 if (l && s[0] != '/' && s[0] != '\\' && s[0] != ';')
2363 } /* Else: copy as is */
2364 if (l && (flags & dir_subst_pathlike)) {
2367 while ( i < l - 2 && s[i] != ';') /* May have ~char after `;' */
2369 if (i < l - 2) { /* Found */
2374 if (e + l >= b + bl) {
2375 if (flags & dir_subst_fatal)
2376 Perl_croak_nocontext("%s: name `%s%s' too long", msg, b, s);
2382 e = dir_subst(s + l, rest, e + l, bl - (e + l - b), flags, msg);
2390 perllib_mangle_with(char *s, unsigned int l, char *from, unsigned int froml, char *to, unsigned int tol)
2396 if (l < froml || strnicmp(from, s, froml) != 0)
2398 if (l + tol - froml > STATIC_FILE_LENGTH || tol > STATIC_FILE_LENGTH)
2399 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
2400 if (to && to != mangle_ret)
2401 memcpy(mangle_ret, to, tol);
2402 strcpy(mangle_ret + tol, s + froml);
2407 perllib_mangle(char *s, unsigned int l)
2411 if (perllib_mangle_installed && (name = perllib_mangle_installed(s,l)))
2413 if (!newp && !notfound) {
2414 newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION)
2415 STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION)
2418 newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION)
2419 STRINGIFY(PERL_VERSION) "_PREFIX");
2421 newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX");
2423 newp = getenv(name = "PERLLIB_PREFIX");
2428 while (*newp && !isSPACE(*newp) && *newp != ';')
2429 newp++; /* Skip old name. */
2431 s = dir_subst(oldp, oldl, b, sizeof b, dir_subst_fatal, name);
2434 while (*newp && (isSPACE(*newp) || *newp == ';'))
2435 newp++; /* Skip whitespace. */
2436 Perl_OS2_handler_install((void *)newp, Perlos2_handler_perllib_to);
2437 if (newl == 0 || oldl == 0)
2438 Perl_croak_nocontext("Malformed %s", name);
2446 if (l < oldl || strnicmp(oldp, s, oldl) != 0)
2448 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH)
2449 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
2450 strcpy(mangle_ret + newl, s + oldl);
2455 Perl_hab_GET() /* Needed if perl.h cannot be included */
2457 return perl_hab_GET();
2461 Create_HMQ(int serve, char *message) /* Assumes morphing */
2463 unsigned fpflag = _control87(0,0);
2465 init_PMWIN_entries();
2466 /* 64 messages if before OS/2 3.0, ignored otherwise */
2467 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
2471 SAVEINT(rmq_cnt); /* Allow catch()ing. */
2473 _exit(188); /* Panic can try to create a window. */
2474 CroakWinError(1, message ? message : "Cannot create a message queue");
2477 (*PMWIN_entries.CancelShutdown)(Perl_hmq, !serve);
2478 /* We may have loaded some modules */
2479 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
2482 #define REGISTERMQ_WILL_SERVE 1
2483 #define REGISTERMQ_IMEDIATE_UNMORPH 2
2486 Perl_Register_MQ(int serve)
2488 if (Perl_hmq_refcnt <= 0) {
2492 Perl_hmq_refcnt = 0; /* Be extra safe */
2493 DosGetInfoBlocks(&tib, &pib);
2494 if (!Perl_morph_refcnt) {
2495 Perl_os2_initial_mode = pib->pib_ultype;
2496 /* Try morphing into a PM application. */
2497 if (pib->pib_ultype != 3) /* 2 is VIO */
2498 pib->pib_ultype = 3; /* 3 is PM */
2500 Create_HMQ(-1, /* We do CancelShutdown ourselves */
2501 "Cannot create a message queue, or morph to a PM application");
2502 if ((serve & REGISTERMQ_IMEDIATE_UNMORPH)) {
2503 if (!Perl_morph_refcnt && Perl_os2_initial_mode != 3)
2504 pib->pib_ultype = Perl_os2_initial_mode;
2507 if (serve & REGISTERMQ_WILL_SERVE) {
2508 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
2509 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
2510 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
2512 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
2513 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
2515 if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH))
2516 Perl_morph_refcnt++;
2521 Perl_Serve_Messages(int force)
2526 if (Perl_hmq_servers > 0 && !force)
2528 if (Perl_hmq_refcnt <= 0)
2529 Perl_croak_nocontext("No message queue");
2530 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
2532 if (msg.msg == WM_QUIT)
2533 Perl_croak_nocontext("QUITing...");
2534 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
2540 Perl_Process_Messages(int force, I32 *cntp)
2544 if (Perl_hmq_servers > 0 && !force)
2546 if (Perl_hmq_refcnt <= 0)
2547 Perl_croak_nocontext("No message queue");
2548 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
2551 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
2552 if (msg.msg == WM_DESTROY)
2554 if (msg.msg == WM_CREATE)
2557 Perl_croak_nocontext("QUITing...");
2561 Perl_Deregister_MQ(int serve)
2563 if (serve & REGISTERMQ_WILL_SERVE)
2566 if (--Perl_hmq_refcnt <= 0) {
2567 unsigned fpflag = _control87(0,0);
2569 init_PMWIN_entries(); /* To be extra safe */
2570 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
2572 /* We may have (un)loaded some modules */
2573 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
2574 } else if ((serve & REGISTERMQ_WILL_SERVE) && Perl_hmq_servers <= 0)
2575 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); /* Last server exited */
2576 if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH) && (--Perl_morph_refcnt <= 0)) {
2577 /* Try morphing back from a PM application. */
2581 DosGetInfoBlocks(&tib, &pib);
2582 if (pib->pib_ultype == 3) /* 3 is PM */
2583 pib->pib_ultype = Perl_os2_initial_mode;
2585 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
2590 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
2591 && ((path)[2] == '/' || (path)[2] == '\\'))
2592 #define sys_is_rooted _fnisabs
2593 #define sys_is_relative _fnisrel
2594 #define current_drive _getdrive
2596 #undef chdir /* Was _chdir2. */
2597 #define sys_chdir(p) (chdir(p) == 0)
2598 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
2604 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
2606 int arg1 = SvIV(ST(0));
2607 int arg2 = SvIV(ST(1));
2608 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
2609 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
2610 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
2613 if (CheckOSError(DosError(a)))
2614 Perl_croak_nocontext("DosError(%d) failed: %s", a, os2error(Perl_rc));
2615 ST(0) = sv_newmortal();
2616 if (DOS_harderr_state >= 0)
2617 sv_setiv(ST(0), DOS_harderr_state);
2618 DOS_harderr_state = RETVAL;
2623 XS(XS_OS2_Errors2Drive)
2627 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
2631 int suppress = SvOK(sv);
2632 char *s = suppress ? SvPV(sv, n_a) : NULL;
2633 char drive = (s ? *s : 0);
2636 if (suppress && !isALPHA(drive))
2637 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
2638 if (CheckOSError(DosSuppressPopUps((suppress
2639 ? SPU_ENABLESUPPRESSION
2640 : SPU_DISABLESUPPRESSION),
2642 Perl_croak_nocontext("DosSuppressPopUps(%c) failed: %s", drive,
2644 ST(0) = sv_newmortal();
2645 if (DOS_suppression_state > 0)
2646 sv_setpvn(ST(0), &DOS_suppression_state, 1);
2647 else if (DOS_suppression_state == 0)
2649 DOS_suppression_state = drive;
2655 async_mssleep(ULONG ms, int switch_priority) {
2656 /* This is similar to DosSleep(), but has 8ms granularity in time-critical
2657 threads even on Warp3. */
2658 HEV hevEvent1 = 0; /* Event semaphore handle */
2659 HTIMER htimerEvent1 = 0; /* Timer handle */
2660 APIRET rc = NO_ERROR; /* Return code */
2662 ULONG priority = 0, nesting; /* Shut down the warnings */
2668 if (!(_emx_env & 0x200)) /* DOS */
2669 return !_sleep2(ms);
2671 os2cp_croak(DosCreateEventSem(NULL, /* Unnamed */
2672 &hevEvent1, /* Handle of semaphore returned */
2673 DC_SEM_SHARED, /* Shared needed for DosAsyncTimer */
2674 FALSE), /* Semaphore is in RESET state */
2675 "DosCreateEventSem");
2677 if (ms >= switch_priority)
2678 switch_priority = 0;
2679 if (switch_priority) {
2680 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
2681 switch_priority = 0;
2683 /* In Warp3, to switch scheduling to 8ms step, one needs to do
2684 DosAsyncTimer() in time-critical thread. On laters versions,
2685 more and more cases of wait-for-something are covered.
2687 It turns out that on Warp3fp42 it is the priority at the time
2688 of DosAsyncTimer() which matters. Let's hope that this works
2689 with later versions too... XXXX
2691 priority = (tib->tib_ptib2->tib2_ulpri);
2692 if ((priority & 0xFF00) == 0x0300) /* already time-critical */
2693 switch_priority = 0;
2694 /* Make us time-critical. Just modifying TIB is not enough... */
2695 /* tib->tib_ptib2->tib2_ulpri = 0x0300;*/
2696 /* We do not want to run at high priority if a signal causes us
2697 to longjmp() out of this section... */
2698 if (DosEnterMustComplete(&nesting))
2699 switch_priority = 0;
2701 DosSetPriority(PRTYS_THREAD, PRTYC_TIMECRITICAL, 0, 0);
2705 if ((badrc = DosAsyncTimer(ms,
2706 (HSEM) hevEvent1, /* Semaphore to post */
2707 &htimerEvent1))) /* Timer handler (returned) */
2708 e = "DosAsyncTimer";
2710 if (switch_priority && tib->tib_ptib2->tib2_ulpri == 0x0300) {
2711 /* Nobody switched priority while we slept... Ignore errors... */
2712 /* tib->tib_ptib2->tib2_ulpri = priority; */ /* Get back... */
2713 if (!(rc = DosSetPriority(PRTYS_THREAD, (priority>>8) & 0xFF, 0, 0)))
2714 rc = DosSetPriority(PRTYS_THREAD, 0, priority & 0xFF, 0);
2716 if (switch_priority)
2717 rc = DosExitMustComplete(&nesting); /* Ignore errors */
2719 /* The actual blocking call is made with "normal" priority. This way we
2720 should not bother with DosSleep(0) etc. to compensate for us interrupting
2721 higher-priority threads. The goal is to prohibit the system spending too
2722 much time halt()ing, not to run us "no matter what". */
2723 if (!e) /* Wait for AsyncTimer event */
2724 badrc = DosWaitEventSem(hevEvent1, SEM_INDEFINITE_WAIT);
2726 if (e) ; /* Do nothing */
2727 else if (badrc == ERROR_INTERRUPT)
2730 e = "DosWaitEventSem";
2731 if ((rc = DosCloseEventSem(hevEvent1)) && !e) { /* Get rid of semaphore */
2732 e = "DosCloseEventSem";
2736 os2cp_croak(badrc, e);
2740 XS(XS_OS2_ms_sleep) /* for testing only... */
2745 if (items > 2 || items < 1)
2746 Perl_croak_nocontext("Usage: OS2::ms_sleep(wait_ms [, high_priority_limit])");
2748 lim = items > 1 ? SvUV(ST(1)) : ms + 1;
2749 async_mssleep(ms, lim);
2753 ULONG (*pDosTmrQueryFreq) (PULONG);
2754 ULONG (*pDosTmrQueryTime) (unsigned long long *);
2760 unsigned long long count;
2764 Perl_croak_nocontext("Usage: OS2::Timer()");
2766 *(PFN*)&pDosTmrQueryFreq = loadByOrdinal(ORD_DosTmrQueryFreq, 0);
2767 *(PFN*)&pDosTmrQueryTime = loadByOrdinal(ORD_DosTmrQueryTime, 0);
2768 MUTEX_LOCK(&perlos2_state_mutex);
2770 if (CheckOSError(pDosTmrQueryFreq(&freq)))
2771 croak_with_os2error("DosTmrQueryFreq");
2772 MUTEX_UNLOCK(&perlos2_state_mutex);
2774 if (CheckOSError(pDosTmrQueryTime(&count)))
2775 croak_with_os2error("DosTmrQueryTime");
2779 XSprePUSH; PUSHn(((NV)count)/freq);
2784 XS(XS_OS2_msCounter)
2789 Perl_croak_nocontext("Usage: OS2::msCounter()");
2793 XSprePUSH; PUSHu(msCounter());
2798 XS(XS_OS2__InfoTable)
2804 Perl_croak_nocontext("Usage: OS2::_infoTable([isLocal])");
2806 is_local = (int)SvIV(ST(0));
2810 XSprePUSH; PUSHu(InfoTable(is_local));
2815 static const char * const dc_fields[] = {
2824 "HORIZONTAL_RESOLUTION",
2825 "VERTICAL_RESOLUTION",
2829 "SMALL_CHAR_HEIGHT",
2833 "COLOR_TABLE_SUPPORT",
2835 "FOREGROUND_MIX_SUPPORT",
2836 "BACKGROUND_MIX_SUPPORT",
2837 "VIO_LOADABLE_FONTS",
2838 "WINDOW_BYTE_ALIGNMENT",
2846 "GRAPHICS_VECTOR_SUBSET",
2848 "ADDITIONAL_GRAPHICS",
2851 "GRAPHICS_CHAR_WIDTH",
2852 "GRAPHICS_CHAR_HEIGHT",
2853 "HORIZONTAL_FONT_RES",
2854 "VERTICAL_FONT_RES",
2857 "DEVICE_POLYSET_POINTS",
2861 DevCap_dc, DevCap_hwnd
2864 HDC (*pWinOpenWindowDC) (HWND hwnd);
2865 HMF (*pDevCloseDC) (HDC hdc);
2866 HDC (*pDevOpenDC) (HAB hab, LONG lType, PCSZ pszToken, LONG lCount,
2867 PDEVOPENDATA pdopData, HDC hdcComp);
2868 BOOL (*pDevQueryCaps) (HDC hdc, LONG lStart, LONG lCount, PLONG alArray);
2875 Perl_croak_nocontext("Usage: OS2::DevCap()");
2877 /* Device Capabilities Data Buffer (10 extra w.r.t. Warp 4.5) */
2878 LONG si[CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1];
2879 int i = 0, j = 0, how = DevCap_dc;
2881 DEVOPENSTRUC doStruc= {0L, (PSZ)"DISPLAY", NULL, 0L, 0L, 0L, 0L, 0L, 0L};
2882 ULONG rc1 = NO_ERROR;
2884 static volatile int devcap_loaded;
2886 if (!devcap_loaded) {
2887 *(PFN*)&pWinOpenWindowDC = loadByOrdinal(ORD_WinOpenWindowDC, 0);
2888 *(PFN*)&pDevOpenDC = loadByOrdinal(ORD_DevOpenDC, 0);
2889 *(PFN*)&pDevCloseDC = loadByOrdinal(ORD_DevCloseDC, 0);
2890 *(PFN*)&pDevQueryCaps = loadByOrdinal(ORD_DevQueryCaps, 0);
2896 if (!items) { /* Get device contents from PM */
2897 hScreenDC = pDevOpenDC(perl_hab_GET(), OD_MEMORY, (PSZ)"*", 0,
2898 (PDEVOPENDATA)&doStruc, NULLHANDLE);
2899 if (CheckWinError(hScreenDC))
2900 croak_with_os2error("DevOpenDC() failed");
2901 } else if (how == DevCap_dc)
2902 hScreenDC = (HDC)SvIV(ST(0));
2903 else { /* DevCap_hwnd */
2905 Perl_croak(aTHX_ "Getting a window's device context without a message queue would lock PM");
2906 hwnd = (HWND)SvIV(ST(0));
2907 hScreenDC = pWinOpenWindowDC(hwnd); /* No need to DevCloseDC() */
2908 if (CheckWinError(hScreenDC))
2909 croak_with_os2error("WinOpenWindowDC() failed");
2911 if (CheckWinError(pDevQueryCaps(hScreenDC,
2912 CAPS_FAMILY, /* W3 documented caps */
2913 CAPS_DEVICE_POLYSET_POINTS
2918 EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1));
2919 while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) {
2920 ST(j) = sv_newmortal();
2921 sv_setpv(ST(j++), dc_fields[i]);
2922 ST(j) = sv_newmortal();
2923 sv_setiv(ST(j++), si[i]);
2926 i = CAPS_DEVICE_POLYSET_POINTS + 1;
2927 while (i < CAPS_DEVICE_POLYSET_POINTS + 11) { /* Just in case... */
2930 if (CheckWinError(pDevQueryCaps(hScreenDC, i, 1, &l)))
2933 ST(j) = sv_newmortal();
2934 sv_setiv(ST(j++), i);
2935 ST(j) = sv_newmortal();
2936 sv_setiv(ST(j++), l);
2940 if (!items && CheckWinError(pDevCloseDC(hScreenDC)))
2941 Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc));
2943 Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed");
2948 LONG (*pWinQuerySysValue) (HWND hwndDesktop, LONG iSysValue);
2949 BOOL (*pWinSetSysValue) (HWND hwndDesktop, LONG iSysValue, LONG lValue);
2951 const char * const sv_keys[] = {
3003 "DESKTOPWORKAREAYTOP",
3004 "DESKTOPWORKAREAYBOTTOM",
3005 "DESKTOPWORKAREAXRIGHT",
3006 "DESKTOPWORKAREAXLEFT",
3016 "MENUROLLDOWNDELAY",
3019 "TASKLISTMOUSEACCESS",
3049 "PRINTSCREEN", /* 97, the last one on one of the DDK header */
3061 /* In recent DDK the limit is 108 */
3064 XS(XS_OS2_SysValues)
3068 Perl_croak_nocontext("Usage: OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP)");
3070 int i = 0, j = 0, which = -1;
3071 HWND hwnd = HWND_DESKTOP;
3072 static volatile int sv_loaded;
3076 *(PFN*)&pWinQuerySysValue = loadByOrdinal(ORD_WinQuerySysValue, 0);
3081 hwnd = (HWND)SvIV(ST(1));
3083 which = (int)SvIV(ST(0));
3085 EXTEND(SP,2*C_ARRAY_LENGTH(sv_keys));
3086 while (i < C_ARRAY_LENGTH(sv_keys)) {
3088 RETVAL = pWinQuerySysValue(hwnd, i);
3090 && !(sv_keys[i][0] >= '0' && sv_keys[i][0] <= '9'
3091 && i <= SV_PRINTSCREEN) ) {
3094 if (i > SV_PRINTSCREEN)
3095 break; /* May be not present on older systems */
3096 croak_with_os2error("SysValues():");
3100 ST(j) = sv_newmortal();
3101 sv_setpv(ST(j++), sv_keys[i]);
3102 ST(j) = sv_newmortal();
3103 sv_setiv(ST(j++), RETVAL);
3111 RETVAL = pWinQuerySysValue(hwnd, which);
3115 croak_with_os2error("SysValues():");
3117 XSprePUSH; PUSHi((IV)RETVAL);
3122 XS(XS_OS2_SysValues_set)
3125 if (items < 2 || items > 3)
3126 Perl_croak_nocontext("Usage: OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP)");
3128 int which = (int)SvIV(ST(0));
3129 LONG val = (LONG)SvIV(ST(1));
3130 HWND hwnd = HWND_DESKTOP;
3131 static volatile int svs_loaded;
3134 *(PFN*)&pWinSetSysValue = loadByOrdinal(ORD_WinSetSysValue, 0);
3139 hwnd = (HWND)SvIV(ST(2));
3140 if (CheckWinError(pWinSetSysValue(hwnd, which, val)))
3141 croak_with_os2error("SysValues_set()");
3146 #define QSV_MAX_WARP3 QSV_MAX_COMP_LENGTH
3148 static const char * const si_fields[] = {
3150 "MAX_TEXT_SESSIONS",
3154 "DYN_PRI_VARIATION",
3172 "FOREGROUND_FS_SESSION",
3173 "FOREGROUND_PROCESS", /* Warp 3 toolkit defines up to this */
3178 "VIRTUALADDRESSLIMIT",
3179 "INT10ENABLED", /* From $TOOLKIT-ddk\DDK\video\rel\os2c\include\base\os2\bsedos.h */
3186 Perl_croak_nocontext("Usage: OS2::SysInfo()");
3188 /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
3189 ULONG si[C_ARRAY_LENGTH(si_fields) + 10];
3190 APIRET rc = NO_ERROR; /* Return code */
3191 int i = 0, j = 0, last = QSV_MAX_WARP3;
3193 if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */
3194 last, /* info for Warp 3 */
3197 croak_with_os2error("DosQuerySysInfo() failed");
3198 while (++last <= C_ARRAY_LENGTH(si)) {
3199 if (CheckOSError(DosQuerySysInfo(last, last, /* One entry only */
3202 if (Perl_rc != ERROR_INVALID_PARAMETER)
3203 croak_with_os2error("DosQuerySysInfo() failed");
3207 last--; /* Count of successfully processed offsets */
3210 ST(j) = sv_newmortal();
3211 if (i < C_ARRAY_LENGTH(si_fields))
3212 sv_setpv(ST(j++), si_fields[i]);
3214 sv_setiv(ST(j++), i + 1);
3215 ST(j) = sv_newmortal();
3216 sv_setuv(ST(j++), si[i]);
3223 XS(XS_OS2_SysInfoFor)
3226 int count = (items == 2 ? (int)SvIV(ST(1)) : 1);
3228 if (items < 1 || items > 2)
3229 Perl_croak_nocontext("Usage: OS2::SysInfoFor(id[,count])");
3231 /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
3232 ULONG si[C_ARRAY_LENGTH(si_fields) + 10];
3233 APIRET rc = NO_ERROR; /* Return code */
3235 int start = (int)SvIV(ST(0));
3237 if (count > C_ARRAY_LENGTH(si) || count <= 0)
3238 Perl_croak(aTHX_ "unexpected count %d for OS2::SysInfoFor()", count);
3239 if (CheckOSError(DosQuerySysInfo(start,
3243 croak_with_os2error("DosQuerySysInfo() failed");
3246 ST(i) = sv_newmortal();
3247 sv_setiv(ST(i), si[i]);
3254 XS(XS_OS2_BootDrive)
3258 Perl_croak_nocontext("Usage: OS2::BootDrive()");
3260 ULONG si[1] = {0}; /* System Information Data Buffer */
3261 APIRET rc = NO_ERROR; /* Return code */
3265 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
3266 (PVOID)si, sizeof(si))))
3267 croak_with_os2error("DosQuerySysInfo() failed");
3268 c = 'a' - 1 + si[0];
3269 sv_setpvn(TARG, &c, 1);
3270 XSprePUSH; PUSHTARG;
3278 if (items > 2) /* Defaults as for WinAlarm(ERROR) */
3279 Perl_croak_nocontext("Usage: OS2::Beep(freq = 440, ms = 100)");
3281 ULONG freq = (items > 0 ? (ULONG)SvUV(ST(0)) : 440);
3282 ULONG ms = (items > 1 ? (ULONG)SvUV(ST(1)) : 100);
3285 if (CheckOSError(DosBeep(freq, ms)))
3286 croak_with_os2error("SysValues_set()");
3297 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
3299 bool serve = SvOK(ST(0));
3300 unsigned long pmq = perl_hmq_GET(serve);
3303 XSprePUSH; PUSHi((IV)pmq);
3308 XS(XS_OS2_UnMorphPM)
3312 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
3314 bool serve = SvOK(ST(0));
3316 perl_hmq_UNSET(serve);
3321 XS(XS_OS2_Serve_Messages)
3325 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
3327 bool force = SvOK(ST(0));
3328 unsigned long cnt = Perl_Serve_Messages(force);
3331 XSprePUSH; PUSHi((IV)cnt);
3336 XS(XS_OS2_Process_Messages)
3339 if (items < 1 || items > 2)
3340 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
3342 bool force = SvOK(ST(0));
3350 (void)SvIV(sv); /* Force SvIVX */
3352 Perl_croak_nocontext("Can't upgrade count to IV");
3354 cnt = Perl_Process_Messages(force, &cntr);
3357 cnt = Perl_Process_Messages(force, NULL);
3359 XSprePUSH; PUSHi((IV)cnt);
3364 XS(XS_Cwd_current_drive)
3368 Perl_croak_nocontext("Usage: Cwd::current_drive()");
3373 RETVAL = current_drive();
3374 sv_setpvn(TARG, (char *)&RETVAL, 1);
3375 XSprePUSH; PUSHTARG;
3380 XS(XS_Cwd_sys_chdir)
3384 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
3387 char * path = (char *)SvPV(ST(0),n_a);
3390 RETVAL = sys_chdir(path);
3391 ST(0) = boolSV(RETVAL);
3392 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3397 XS(XS_Cwd_change_drive)
3401 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
3404 char d = (char)*SvPV(ST(0),n_a);
3407 RETVAL = change_drive(d);
3408 ST(0) = boolSV(RETVAL);
3409 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3414 XS(XS_Cwd_sys_is_absolute)
3418 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
3421 char * path = (char *)SvPV(ST(0),n_a);
3424 RETVAL = sys_is_absolute(path);
3425 ST(0) = boolSV(RETVAL);
3426 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3431 XS(XS_Cwd_sys_is_rooted)
3435 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
3438 char * path = (char *)SvPV(ST(0),n_a);
3441 RETVAL = sys_is_rooted(path);
3442 ST(0) = boolSV(RETVAL);
3443 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3448 XS(XS_Cwd_sys_is_relative)
3452 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
3455 char * path = (char *)SvPV(ST(0),n_a);
3458 RETVAL = sys_is_relative(path);
3459 ST(0) = boolSV(RETVAL);
3460 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3469 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
3474 /* Can't use TARG, since tainting behaves differently */
3475 RETVAL = _getcwd2(p, MAXPATHLEN);
3476 ST(0) = sv_newmortal();
3477 sv_setpv(ST(0), RETVAL);
3478 SvTAINTED_on(ST(0));
3483 XS(XS_Cwd_sys_abspath)
3487 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path = '.', dir = NULL)");
3490 char * path = items ? (char *)SvPV(ST(0),n_a) : ".";
3491 char * dir, *s, *t, *e;
3500 dir = (char *)SvPV(ST(1),n_a);
3502 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
3506 if (_abspath(p, path, MAXPATHLEN) == 0) {
3512 /* Absolute with drive: */
3513 if ( sys_is_absolute(path) ) {
3514 if (_abspath(p, path, MAXPATHLEN) == 0) {
3519 } else if (path[0] == '/' || path[0] == '\\') {
3520 /* Rooted, but maybe on different drive. */
3521 if (isALPHA(dir[0]) && dir[1] == ':' ) {
3522 char p1[MAXPATHLEN];
3524 /* Need to prepend the drive. */
3527 Copy(path, p1 + 2, strlen(path) + 1, char);
3529 if (_abspath(p, p1, MAXPATHLEN) == 0) {
3534 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3540 /* Either path is relative, or starts with a drive letter. */
3541 /* If the path starts with a drive letter, then dir is
3543 a/b) it is absolute/x:relative on the same drive.
3544 c) path is on current drive, and dir is rooted
3545 In all the cases it is safe to drop the drive part
3547 if ( !sys_is_relative(path) ) {
3548 if ( ( ( sys_is_absolute(dir)
3549 || (isALPHA(dir[0]) && dir[1] == ':'
3550 && strnicmp(dir, path,1) == 0))
3551 && strnicmp(dir, path,1) == 0)
3552 || ( !(isALPHA(dir[0]) && dir[1] == ':')
3553 && toupper(path[0]) == current_drive())) {
3555 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3556 RETVAL = p; goto done;
3558 RETVAL = NULL; goto done;
3562 /* Need to prepend the absolute path of dir. */
3563 char p1[MAXPATHLEN];
3565 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
3568 if (p1[ l - 1 ] != '/') {
3572 Copy(path, p1 + l, strlen(path) + 1, char);
3573 if (_abspath(p, p1, MAXPATHLEN) == 0) {
3587 /* Backslashes are already converted to slashes. */
3588 /* Remove trailing slashes */
3590 while (l > 0 && RETVAL[l-1] == '/')
3592 ST(0) = sv_newmortal();
3593 sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
3594 /* Remove duplicate slashes, skipping the first three, which
3595 may be parts of a server-based path */
3596 s = t = 3 + SvPV_force(sv, n_a);
3598 /* Do not worry about multibyte chars here, this would contradict the
3599 eventual UTFization, and currently most other places break too... */
3601 if (s[0] == t[-1] && s[0] == '/')
3602 s++; /* Skip duplicate / */
3608 SvCUR_set(sv, t - SvPVX(sv));
3611 SvTAINTED_on(ST(0));
3615 typedef APIRET (*PELP)(PSZ path, ULONG type);
3617 /* Kernels after 2000/09/15 understand this too: */
3618 #ifndef LIBPATHSTRICT
3619 # define LIBPATHSTRICT 3
3623 ExtLIBPATH(ULONG ord, PSZ path, IV type, int fatal)
3626 PFN f = loadByOrdinal(ord, fatal); /* if fatal: load or die! */
3628 if (!f) /* Impossible with fatal */
3633 what = BEGIN_LIBPATH;
3635 what = LIBPATHSTRICT;
3636 return (*(PELP)f)(path, what);
3639 #define extLibpath(to,type, fatal) \
3640 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type), fatal)) ? NULL : (to) )
3642 #define extLibpath_set(p,type, fatal) \
3643 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type), fatal)))
3646 early_error(char *msg1, char *msg2, char *msg3)
3647 { /* Buffer overflow detected; there is very little we can do... */
3650 DosWrite(2, msg1, strlen(msg1), &rc);
3651 DosWrite(2, msg2, strlen(msg2), &rc);
3652 DosWrite(2, msg3, strlen(msg3), &rc);
3653 DosExit(EXIT_PROCESS, 2);
3656 XS(XS_Cwd_extLibpath)
3659 if (items < 0 || items > 1)
3660 Perl_croak_nocontext("Usage: OS2::extLibpath(type = 0)");
3675 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
3676 RETVAL = extLibpath(to, type, 1); /* Make errors fatal */
3677 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
3678 Perl_croak_nocontext("panic OS2::extLibpath parameter");
3680 if (l >= sizeof(to))
3681 early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `",
3682 to, "'\r\n"); /* Will not return */
3683 sv_setpv(TARG, RETVAL);
3684 XSprePUSH; PUSHTARG;
3689 XS(XS_Cwd_extLibpath_set)
3692 if (items < 1 || items > 2)
3693 Perl_croak_nocontext("Usage: OS2::extLibpath_set(s, type = 0)");
3696 char * s = (char *)SvPV(ST(0),n_a);
3707 RETVAL = extLibpath_set(s, type, 1); /* Make errors fatal */
3708 ST(0) = boolSV(RETVAL);
3709 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3715 fill_extLibpath(int type, char *pre, char *post, int replace, char *msg)
3717 char buf[2048], *to = buf, buf1[300], *s;
3724 pre = dir_subst(pre, strlen(pre), buf1, sizeof buf1, dir_subst_pathlike, msg);
3726 return ERROR_INVALID_PARAMETER;
3728 if (l >= sizeof(buf)/2)
3729 return ERROR_BUFFER_OVERFLOW;
3733 *s = '\\'; /* Be extra cautious */
3735 if (!l || to[l-1] != ';')
3741 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
3742 rc = ExtLIBPATH(ORD_DosQueryExtLibpath, to, type, 0); /* Do not croak */
3745 if (to[0] == 1 && to[1] == 0)
3746 return ERROR_INVALID_PARAMETER;
3748 if (buf + sizeof(buf) - 1 <= to) /* Buffer overflow */
3749 early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `",
3750 buf, "'\r\n"); /* Will not return */
3751 if (to > buf && to[-1] != ';')
3755 post = dir_subst(post, strlen(post), buf1, sizeof buf1, dir_subst_pathlike, msg);
3757 return ERROR_INVALID_PARAMETER;
3759 if (l + to - buf >= sizeof(buf) - 1)
3760 return ERROR_BUFFER_OVERFLOW;
3764 *s = '\\'; /* Be extra cautious */
3765 memcpy(to, post, l);
3766 if (!l || to[l-1] != ';')
3771 rc = ExtLIBPATH(ORD_DosSetExtLibpath, buf, type, 0); /* Do not croak */
3775 /* Input: Address, BufLen
3777 DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3778 ULONG * Offset, ULONG Address);
3781 DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
3782 (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3783 ULONG * Offset, ULONG Address),
3784 (hmod, obj, BufLen, Buf, Offset, Address))
3787 module_name_at(void *pp, enum module_name_how how)
3790 char buf[MAXPATHLEN];
3793 ULONG obj, offset, rc, addr = (ULONG)pp;
3795 if (how & mod_name_HMODULE) {
3796 if ((how & ~mod_name_HMODULE) == mod_name_shortname)
3797 Perl_croak(aTHX_ "Can't get short module name from a handle");
3799 how &= ~mod_name_HMODULE;
3800 } else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr))
3801 return &PL_sv_undef;
3802 if (how == mod_name_handle)
3803 return newSVuv(mod);
3805 if ( how != mod_name_shortname
3806 && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
3807 return &PL_sv_undef;
3813 return newSVpv(buf, 0);
3817 module_name_of_cv(SV *cv, enum module_name_how how)
3819 if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
3822 if (how & mod_name_C_function)
3823 return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function);
3824 else if (how & mod_name_HMODULE)
3825 return module_name_at((void*)SvIV(cv), how);
3826 Perl_croak(aTHX_ "Not an XSUB reference");
3828 return module_name_at(CvXSUB(SvRV(cv)), how);
3835 Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
3841 how = mod_name_full;
3843 how = (int)SvIV(ST(0));
3846 RETVAL = module_name(how);
3848 RETVAL = module_name_of_cv(ST(1), how);
3855 DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo,
3856 (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum),
3857 (r1, r2, buf, szbuf, fnum))
3859 XS(XS_OS2__headerInfo)
3862 if (items > 4 || items < 2)
3863 Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])");
3865 ULONG req = (ULONG)SvIV(ST(0));
3866 STRLEN size = (STRLEN)SvIV(ST(1)), n_a;
3867 ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0);
3868 ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0);
3871 Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size);
3872 ST(0) = newSVpvs("");
3873 SvGROW(ST(0), size + 1);
3876 if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req))
3877 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3878 req, size, handle, offset, os2error(Perl_rc));
3879 SvCUR_set(ST(0), size);
3885 #define DQHI_QUERYLIBPATHSIZE 4
3886 #define DQHI_QUERYLIBPATH 5
3892 Perl_croak(aTHX_ "Usage: OS2::libPath()");
3897 if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size),
3898 DQHI_QUERYLIBPATHSIZE))
3899 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3900 DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0,
3902 ST(0) = newSVpvs("");
3903 SvGROW(ST(0), size + 1);
3906 /* We should be careful: apparently, this entry point does not
3907 pay attention to the size argument, so may overwrite
3909 if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size,
3911 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3912 DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc));
3913 SvCUR_set(ST(0), size);
3919 #define get_control87() _control87(0,0)
3920 #define set_control87 _control87
3922 XS(XS_OS2__control87)
3926 Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
3928 unsigned new = (unsigned)SvIV(ST(0));
3929 unsigned mask = (unsigned)SvIV(ST(1));
3933 RETVAL = _control87(new, mask);
3934 XSprePUSH; PUSHi((IV)RETVAL);
3944 if (items < 0 || items > 1)
3945 Perl_croak(aTHX_ "Usage: OS2::mytype([which])");
3947 which = (int)SvIV(ST(0));
3954 RETVAL = os2_mytype; /* Reset after fork */
3957 RETVAL = os2_mytype_ini; /* Before any fork */
3960 RETVAL = Perl_os2_initial_mode; /* Before first morphing */
3963 RETVAL = my_type(); /* Morphed type */
3966 Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which);
3968 XSprePUSH; PUSHi((IV)RETVAL);
3974 XS(XS_OS2_mytype_set)
3980 type = (int)SvIV(ST(0));
3982 Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)");
3988 XS(XS_OS2_get_control87)
3992 Perl_croak(aTHX_ "Usage: OS2::get_control87()");
3997 RETVAL = get_control87();
3998 XSprePUSH; PUSHi((IV)RETVAL);
4004 XS(XS_OS2_set_control87)
4007 if (items < 0 || items > 2)
4008 Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
4018 new = (unsigned)SvIV(ST(0));
4024 mask = (unsigned)SvIV(ST(1));
4027 RETVAL = set_control87(new, mask);
4028 XSprePUSH; PUSHi((IV)RETVAL);
4033 XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */
4036 if (items < 0 || items > 1)
4037 Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)");
4046 delta = (LONG)SvIV(ST(0));
4048 if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL)))
4049 croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error");
4050 XSprePUSH; PUSHu((UV)RETVAL);
4055 /* wait>0: force wait, wait<0: force nowait;
4056 if restore, save/restore flags; otherwise flags are in oflags.
4058 Returns 1 if connected, 0 if not (due to nowait); croaks on error. */
4060 connectNPipe(ULONG hpipe, int wait, ULONG restore, ULONG oflags)
4062 ULONG ret = ERROR_INTERRUPT, rc, flags;
4064 if (restore && wait)
4065 os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()");
4066 /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */
4067 oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE);
4068 flags = (oflags & ~NP_NOWAIT) | (wait > 0 ? NP_WAIT : NP_NOWAIT);
4069 /* We know (o)flags unless wait == 0 && restore */
4070 if (wait && (flags != oflags))
4071 os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()");
4072 while (ret == ERROR_INTERRUPT)
4073 ret = DosConnectNPipe(hpipe);
4074 (void)CheckOSError(ret);
4075 if (restore && wait && (flags != oflags))
4076 os2cp_croak(DosSetNPHState(hpipe, oflags), "DosSetNPHState() back");
4077 /* We know flags unless wait == 0 && restore */
4078 if ( ((wait || restore) ? (flags & NP_NOWAIT) : 1)
4079 && (ret == ERROR_PIPE_NOT_CONNECTED) )
4080 return 0; /* normal return value */
4081 if (ret == NO_ERROR)
4083 croak_with_os2error("DosConnectNPipe()");
4086 /* With a lot of manual editing:
4088 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)
4092 pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout
4094 if (CheckOSError(RETVAL))
4095 croak_with_os2error("OS2::mkpipe() error");
4097 XS(XS_OS2_pipe); /* prototype to pass -Wmissing-prototypes */
4101 if (items < 2 || items > 8)
4102 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)");
4105 PCSZ pszName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL );
4107 SV *OpenMode = ST(1);
4109 int connect = 0, count, message_r = 0, message = 0, b = 0;
4110 ULONG ulInbufLength, ulOutbufLength, ulPipeMode, ulTimeout, rc;
4112 char *s, buf[10], *s1, *perltype = NULL;
4116 if (!pszName || !*pszName)
4117 Perl_croak(aTHX_ "OS2::pipe(): empty pipe name");
4118 s = SvPV(OpenMode, len);
4119 if (memEQs(s, len, "wait")) { /* DosWaitNPipe() */
4120 ULONG ms = 0xFFFFFFFF, ret = ERROR_INTERRUPT; /* Indefinite */
4123 timeout = (double)SvNV(ST(2));
4124 ms = timeout * 1000;
4126 ms = 0xFFFFFFFF; /* Indefinite */
4127 else if (timeout && !ms)
4129 } else if (items > 3)
4130 Perl_croak(aTHX_ "OS2::pipe(): too many arguments for wait-for-connect: %ld", (long)items);
4132 while (ret == ERROR_INTERRUPT)
4133 ret = DosWaitNPipe(pszName, ms); /* XXXX Update ms? */
4134 os2cp_croak(ret, "DosWaitNPipe()");
4137 if (memEQs(s, len, "call")) { /* DosCallNPipe() */
4138 ULONG ms = 0xFFFFFFFF, got; /* Indefinite */
4142 STRLEN ll = sizeof(buf);
4145 if (items < 3 || items > 5)
4146 Perl_croak(aTHX_ "usage: OS2::pipe(pszName, 'call', write [, timeout= 0xFFFFFFFF, buffsize = 8192])");
4149 timeout = (double)SvNV(ST(3));
4150 ms = timeout * 1000;
4152 ms = 0xFFFFFFFF; /* Indefinite */
4153 else if (timeout && !ms)
4157 STRLEN lll = SvUV(ST(4));
4158 SV *sv = NEWSV(914, lll);
4165 os2cp_croak(DosCallNPipe(pszName, s, l, b, ll, &got, ms),
4167 XSRETURN_PVN(b, got);
4170 if (len && len <= 3 && !(*s >= '0' && *s <= '9')) {
4173 r = strchr(s, 'r') != 0;
4174 w = strchr(s, 'w') != 0;
4175 R = strchr(s, 'R') != 0;
4176 W = strchr(s, 'W') != 0;
4177 b = strchr(s, 'b') != 0;
4178 if (r + w + R + W + b != len || (r && R) || (w && W))
4179 Perl_croak(aTHX_ "OS2::pipe(): unknown OpenMode argument: `%s'", s);
4180 if ((r || R) && (w || W))
4181 ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_DUPLEX;
4183 ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_INBOUND;
4185 ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_OUTBOUND;
4187 message = message_r = 1;
4191 Perl_croak(aTHX_ "OS2::pipe(): can't have message read mode for non-message pipes");
4193 ulOpenMode = (ULONG)SvUV(OpenMode); /* ST(1) */
4195 if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX
4196 || (ulOpenMode & 0x3) == NP_ACCESS_INBOUND )
4198 if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX )
4200 if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND )
4205 if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX )
4207 else if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND )
4213 connect = -1; /* no wait */
4214 else if (SvTRUE(ST(2))) {
4215 s = SvPV(ST(2), len);
4216 if (memEQs(s, len, "nowait"))
4217 connect = -1; /* no wait */
4218 else if (memEQs(s, len, "wait"))
4219 connect = 1; /* wait */
4221 Perl_croak(aTHX_ "OS2::pipe(): unknown connect argument: `%s'", s);
4227 count = (int)SvIV(ST(3));
4230 ulInbufLength = 8192;
4232 ulInbufLength = (ULONG)SvUV(ST(4));
4235 ulOutbufLength = ulInbufLength;
4237 ulOutbufLength = (ULONG)SvUV(ST(5));
4239 if (count < -1 || count == 0 || count >= 255)
4240 Perl_croak(aTHX_ "OS2::pipe(): count should be -1 or between 1 and 254: %ld", (long)count);
4242 count = 255; /* Unlimited */
4246 ulPipeMode |= (NP_WAIT
4247 | (message ? NP_TYPE_MESSAGE : NP_TYPE_BYTE)
4248 | (message_r ? NP_READMODE_MESSAGE : NP_READMODE_BYTE));
4250 ulPipeMode |= (ULONG)SvUV(ST(6));
4255 timeout = (double)SvNV(ST(7));
4256 ulTimeout = timeout * 1000;
4258 ulTimeout = 0xFFFFFFFF; /* Indefinite */
4259 else if (timeout && !ulTimeout)
4262 RETVAL = DosCreateNPipe(pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout);
4263 if (CheckOSError(RETVAL))
4264 croak_with_os2error("OS2::pipe(): DosCreateNPipe() error");
4267 connectNPipe(hpipe, connect, 1, 0); /* XXXX wait, retval */
4268 hpipe = __imphandle(hpipe);
4270 perlio = PerlIO_fdopen(hpipe, buf);
4271 ST(0) = sv_newmortal();
4273 GV *gv = (GV *)sv_newmortal();
4274 gv_init_pvn(gv, gv_stashpvs("OS2::pipe",1),"__ANONIO__",10,0);
4275 if ( do_open6(gv, perltype, strlen(perltype), perlio, NULL, 0) )
4276 sv_setsv(ST(0), sv_bless(newRV((SV*)gv), gv_stashpv("IO::Handle",1)));
4278 ST(0) = &PL_sv_undef;
4284 XS(XS_OS2_pipeCntl); /* prototype to pass -Wmissing-prototypes */
4288 if (items < 2 || items > 3)
4289 Perl_croak(aTHX_ "Usage: OS2::pipeCntl(pipe, op [, wait])");
4292 PerlIO *perlio = IoIFP(sv_2io(ST(0)));
4293 IV fn = PerlIO_fileno(perlio);
4294 HPIPE hpipe = (HPIPE)fn;
4296 char *s = SvPV(ST(1), len);
4297 int wait = 0, disconnect = 0, connect = 0, message = -1, query = 0;
4298 int peek = 0, state = 0, info = 0;
4301 Perl_croak(aTHX_ "OS2::pipeCntl(): not a pipe");
4303 wait = (SvTRUE(ST(2)) ? 1 : -1);
4307 if (strEQ(s, "byte"))
4309 else if (strEQ(s, "peek"))
4311 else if (strEQ(s, "info"))
4317 if (strEQ(s, "reset"))
4318 disconnect = connect = 1;
4319 else if (strEQ(s, "state"))
4325 if (strEQ(s, "connect"))
4327 else if (strEQ(s, "message"))
4333 if (!strEQ(s, "readstate"))
4338 if (!strEQ(s, "disconnect"))
4344 Perl_croak(aTHX_ "OS2::pipeCntl(): unknown argument: `%s'", s);
4348 if (items == 3 && !connect)
4349 Perl_croak(aTHX_ "OS2::pipeCntl(): no wait argument for `%s'", s);
4351 XSprePUSH; /* Do not need arguments any more */
4353 os2cp_croak(DosDisConnectNPipe(hpipe), "OS2::pipeCntl(): DosDisConnectNPipe()");
4354 PerlIO_clearerr(perlio);
4357 if (!connectNPipe(hpipe, wait , 1, 0))
4363 os2cp_croak(DosQueryNPHState(hpipe, &flags), "DosQueryNPHState()");
4366 if (peek || state || info) {
4367 ULONG BytesRead, PipeState;
4368 AVAILDATA BytesAvail;
4370 os2cp_croak( DosPeekNPipe(hpipe, NULL, 0, &BytesRead, &BytesAvail,
4371 &PipeState), "DosPeekNPipe() for state");
4375 /* Bytes (available/in-message) */
4376 mPUSHi(BytesAvail.cbpipe);
4377 mPUSHi(BytesAvail.cbmessage);
4381 ID of the (remote) computer
4383 instances (max/actual)
4385 struct pipe_info_t {
4386 ULONG id; /* char id[4]; */
4392 os2cp_croak( DosQueryNPipeInfo(hpipe, 1, &b.pInfo, sizeof(b) - STRUCT_OFFSET(struct pipe_info_t, pInfo)),
4393 "DosQueryNPipeInfo(1)");
4394 os2cp_croak( DosQueryNPipeInfo(hpipe, 2, &b.id, sizeof(b.id)),
4395 "DosQueryNPipeInfo(2)");
4396 size = b.pInfo.cbName;
4397 /* Trailing 0 is included in cbName - undocumented; so
4398 one should always extract with Z* */
4399 if (size) /* name length 254 or less */
4402 size = strlen(b.pInfo.szName);
4404 mPUSHp(b.pInfo.szName, size);
4406 mPUSHi(b.pInfo.cbOut);
4407 mPUSHi(b.pInfo.cbIn);
4408 mPUSHi(b.pInfo.cbMaxInst);
4409 mPUSHi(b.pInfo.cbCurInst);
4411 } else if (BytesAvail.cbpipe == 0) {
4414 SV *tmp = NEWSV(914, BytesAvail.cbpipe);
4415 char *s = SvPVX(tmp);
4418 os2cp_croak( DosPeekNPipe(hpipe, s, BytesAvail.cbpipe, &BytesRead,
4419 &BytesAvail, &PipeState), "DosPeekNPipe()");
4420 SvCUR_set(tmp, BytesRead);
4423 XSprePUSH; PUSHs(tmp);
4428 ULONG oflags, flags;
4430 os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()");
4431 /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */
4432 oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE);
4433 flags = (oflags & NP_NOWAIT)
4434 | (message ? NP_READMODE_MESSAGE : NP_READMODE_BYTE);
4435 if (flags != oflags)
4436 os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()");
4444 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);
4448 pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf
4450 if (CheckOSError(RETVAL))
4451 croak_with_os2error("OS2::open() error");
4453 XS(XS_OS2_open); /* prototype to pass -Wmissing-prototypes */
4457 if (items < 2 || items > 6)
4458 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)");
4464 PCSZ pszFileName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL );
4467 ULONG ulOpenMode = (ULONG)SvUV(ST(1));
4474 ulOpenFlags = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW;
4476 ulOpenFlags = (ULONG)SvUV(ST(2));
4480 ulAttribute = FILE_NORMAL;
4482 ulAttribute = (ULONG)SvUV(ST(3));
4488 ulFileSize = (ULONG)SvUV(ST(4));
4494 pEABuf = (PEAOP2)SvUV(ST(5));
4497 RETVAL = DosOpen(pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf);
4498 if (CheckOSError(RETVAL))
4499 croak_with_os2error("OS2::open() error");
4500 XSprePUSH; EXTEND(SP,2);
4501 PUSHs(sv_newmortal());
4502 sv_setuv(ST(0), (UV)hFile);
4503 PUSHs(sv_newmortal());
4504 sv_setuv(ST(1), (UV)ulAction);
4512 char *file = __FILE__;
4516 if (_emx_env & 0x200) { /* OS/2 */
4517 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
4518 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
4519 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
4520 newXS("OS2::extLibpath", XS_Cwd_extLibpath, file);
4521 newXS("OS2::extLibpath_set", XS_Cwd_extLibpath_set, file);
4523 newXS("OS2::Error", XS_OS2_Error, file);
4524 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
4525 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
4526 newXSproto("OS2::DevCap", XS_OS2_DevCap, file, ";$$");
4527 newXSproto("OS2::SysInfoFor", XS_OS2_SysInfoFor, file, "$;$");
4528 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
4529 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
4530 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
4531 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
4532 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
4533 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
4534 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
4535 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
4536 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
4537 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
4538 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
4539 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
4540 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
4541 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
4542 newXS("OS2::replaceModule", XS_OS2_replaceModule, file);
4543 newXS("OS2::perfSysCall", XS_OS2_perfSysCall, file);
4544 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
4545 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
4546 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
4547 newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
4548 newXSproto("OS2::mytype", XS_OS2_mytype, file, ";$");
4549 newXSproto("OS2::mytype_set", XS_OS2_mytype_set, file, "$");
4550 newXSproto("OS2::_headerInfo", XS_OS2__headerInfo, file, "$$;$$");
4551 newXSproto("OS2::libPath", XS_OS2_libPath, file, "");
4552 newXSproto("OS2::Timer", XS_OS2_Timer, file, "");
4553 newXSproto("OS2::msCounter", XS_OS2_msCounter, file, "");
4554 newXSproto("OS2::ms_sleep", XS_OS2_ms_sleep, file, "$;$");
4555 newXSproto("OS2::_InfoTable", XS_OS2__InfoTable, file, ";$");
4556 newXSproto("OS2::incrMaxFHandles", XS_OS2_incrMaxFHandles, file, ";$");
4557 newXSproto("OS2::SysValues", XS_OS2_SysValues, file, ";$$");
4558 newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$");
4559 newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$");
4560 newXSproto("OS2::pipe", XS_OS2_pipe, file, "$$;$$$$$$");
4561 newXSproto("OS2::pipeCntl", XS_OS2_pipeCntl, file, "$$;$");
4562 newXSproto("OS2::open", XS_OS2_open, file, "$$;$$$$");
4563 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
4566 sv_setiv(GvSV(gv), 1);
4568 gv = gv_fetchpv("OS2::is_static", TRUE, SVt_PV);
4571 sv_setiv(GvSV(gv), 1);
4573 gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
4575 sv_setiv(GvSV(gv), exe_is_aout());
4576 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
4578 sv_setiv(GvSV(gv), _emx_rev);
4579 sv_setpv(GvSV(gv), _emx_vprt);
4581 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
4583 sv_setiv(GvSV(gv), _emx_env);
4584 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
4586 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
4587 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
4589 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
4594 extern void _emx_init(void*);
4596 static void jmp_out_of_atexit(void);
4598 #define FORCE_EMX_INIT_CONTRACT_ARGV 1
4599 #define FORCE_EMX_INIT_INSTALL_ATEXIT 2
4602 my_emx_init(void *layout) {
4603 static volatile void *old_esp = 0; /* Cannot be on stack! */
4605 /* Can't just call emx_init(), since it moves the stack pointer */
4606 /* It also busts a lot of registers, so be extra careful */
4614 "popf\n" : : "r" (layout), "m" (old_esp) );
4617 struct layout_table_t {
4638 static ULONG osv_res; /* Cannot be on stack! */
4640 /* Can't just call __os_version(), since it does not follow C
4641 calling convention: it busts a lot of registers, so be extra careful */
4644 "call ___os_version\n"
4647 "popf\n" : "=m" (osv_res) );
4653 force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
4655 /* Calling emx_init() will bust the top of stack: it installs an
4656 exception handler and puts argv data there. */
4657 char *oldarg, *oldenv;
4658 void *oldstackend, *oldstack;
4661 ULONG rc, error = 0, out;
4663 static struct layout_table_t layout_table;
4665 char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
4667 EXCEPTIONREGISTRATIONRECORD xreg;
4671 layout_table.os2_dll = (ULONG)&os2_dll_fake;
4672 layout_table.flags = 0x02000002; /* flags: application, OMF */
4674 DosGetInfoBlocks(&tib, &pib);
4675 oldarg = pib->pib_pchcmd;
4676 oldenv = pib->pib_pchenv;
4677 oldstack = tib->tib_pstack;
4678 oldstackend = tib->tib_pstacklimit;
4680 if ( (char*)&s < (char*)oldstack + 4*1024
4681 || (char *)oldstackend < (char*)oldstack + 52*1024 )
4682 early_error("It is a lunacy to try to run EMX Perl ",
4683 "with less than 64K of stack;\r\n",
4684 " at least with non-EMX starter...\r\n");
4686 /* Minimize the damage to the stack via reducing the size of argv. */
4687 if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
4688 pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */
4689 pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */
4692 newstack = alloca(sizeof(*newstack));
4693 /* Emulate the stack probe */
4694 s = ((char*)newstack) + sizeof(*newstack);
4695 while (s > (char*)newstack) {
4700 /* Reassigning stack is documented to work */
4701 tib->tib_pstack = (void*)newstack;
4702 tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
4704 /* Can't just call emx_init(), since it moves the stack pointer */
4705 my_emx_init((void*)&layout_table);
4707 /* Remove the exception handler, cannot use it - too low on the stack.
4708 Check whether it is inside the new stack. */
4710 if (tib->tib_pexchain >= tib->tib_pstacklimit
4711 || tib->tib_pexchain < tib->tib_pstack) {
4714 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
4715 (unsigned long)tib->tib_pstack,
4716 (unsigned long)tib->tib_pexchain,
4717 (unsigned long)tib->tib_pstacklimit);
4720 if (tib->tib_pexchain != &(newstack->xreg)) {
4721 sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
4722 (unsigned long)tib->tib_pexchain,
4723 (unsigned long)&(newstack->xreg));
4725 rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
4727 sprintf(buf + strlen(buf),
4728 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
4731 /* ExceptionRecords should be on stack, in a correct order. Sigh... */
4732 preg->prev_structure = 0;
4733 preg->ExceptionHandler = _emx_exception;
4734 rc = DosSetExceptionHandler(preg);
4736 sprintf(buf + strlen(buf),
4737 "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
4738 DosWrite(2, buf, strlen(buf), &out);
4739 emx_exception_init = 1; /* Do it around spawn*() calls */
4742 emx_exception_init = 1; /* Do it around spawn*() calls */
4745 /* Restore the damage */
4746 pib->pib_pchcmd = oldarg;
4747 pib->pib_pchcmd = oldenv;
4748 tib->tib_pstacklimit = oldstackend;
4749 tib->tib_pstack = oldstack;
4750 emx_runtime_init = 1;
4752 DosWrite(2, buf, strlen(buf), &out);
4758 jmp_out_of_atexit(void)
4760 if (longjmp_at_exit)
4761 longjmp(at_exit_buf, 1);
4764 extern void _CRT_term(void);
4767 Perl_OS2_term(void **p, int exitstatus, int flags)
4769 if (!emx_runtime_secondary)
4772 /* The principal executable is not running the same CRTL, so there
4773 is nobody to shutdown *this* CRTL except us... */
4774 if (flags & FORCE_EMX_DEINIT_EXIT) {
4775 if (p && !emx_exception_init)
4776 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
4777 /* Do not run the executable's CRTL's termination routines */
4778 exit(exitstatus); /* Run at-exit, flush buffers, etc */
4780 /* Run at-exit list, and jump out at the end */
4781 if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
4782 longjmp_at_exit = 1;
4783 exit(exitstatus); /* The first pass through "if" */
4786 /* Get here if we managed to jump out of exit(), or did not run atexit. */
4787 longjmp_at_exit = 0; /* Maybe exit() is called again? */
4788 #if 0 /* _atexit_n is not exported */
4789 if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
4790 _atexit_n = 0; /* Remove the atexit() handlers */
4792 /* Will segfault on program termination if we leave this dangling... */
4793 if (p && !emx_exception_init)
4794 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
4795 /* Typically there is no need to do this, done from _DLL_InitTerm() */
4796 if (flags & FORCE_EMX_DEINIT_CRT_TERM)
4797 _CRT_term(); /* Flush buffers, etc. */
4798 /* Now it is a good time to call exit() in the caller's CRTL... */
4801 #include <emx/startup.h>
4803 extern ULONG __os_version(); /* See system.doc */
4806 check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
4808 ULONG v_crt, v_emx, count = 0, rc = NO_ERROR, rc1, maybe_inited = 0;
4809 static HMTX hmtx_emx_init = NULLHANDLE;
4810 static int emx_init_done = 0;
4812 /* If _environ is not set, this code sits in a DLL which
4813 uses a CRT DLL which not compatible with the executable's
4814 CRT library. Some parts of the DLL are not initialized.
4816 if (_environ != NULL)
4817 return; /* Properly initialized */
4819 /* It is not DOS, so we may use OS/2 API now */
4820 /* Some data we manipulate is static; protect ourselves from
4821 calling the same API from a different thread. */
4822 DosEnterMustComplete(&count);
4824 rc1 = DosEnterCritSec();
4826 rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/
4831 hmtx_emx_init = NULLHANDLE;
4833 if (rc1 == NO_ERROR)
4835 DosExitMustComplete(&count);
4837 while (maybe_inited) { /* Other thread did or is doing the same now */
4840 rc = DosRequestMutexSem(hmtx_emx_init,
4841 (ULONG) SEM_INDEFINITE_WAIT); /* Timeout (none) */
4842 if (rc == ERROR_INTERRUPT)
4844 if (rc != NO_ERROR) {
4849 "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc);
4850 DosWrite(2, buf, strlen(buf), &out);
4853 DosReleaseMutexSem(hmtx_emx_init);
4857 /* If the executable does not use EMX.DLL, EMX.DLL is not completely
4858 initialized either. Uninitialized EMX.DLL returns 0 in the low
4859 nibble of __os_version(). */
4860 v_emx = my_os_version();
4862 /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
4863 (=>_CRT_init=>_entry2) via a call to __os_version(), then
4864 reset when the EXE initialization code calls _text=>_init=>_entry2.
4865 The first time they are wrongly set to 0; the second time the
4866 EXE initialization code had already called emx_init=>initialize1
4867 which correctly set version_major, version_minor used by
4869 v_crt = (_osmajor | _osminor);
4871 if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */
4872 force_init_emx_runtime( preg,
4873 FORCE_EMX_INIT_CONTRACT_ARGV
4874 | FORCE_EMX_INIT_INSTALL_ATEXIT );
4875 emx_wasnt_initialized = 1;
4876 /* Update CRTL data basing on now-valid EMX runtime data */
4877 if (!v_crt) { /* The only wrong data are the versions. */
4878 v_emx = my_os_version(); /* *Now* it works */
4879 *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
4880 *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
4883 emx_runtime_secondary = 1;
4884 /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
4885 atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */
4887 if (env == NULL) { /* Fetch from the process info block */
4893 DosGetInfoBlocks(&tib, &pib);
4894 e = pib->pib_pchenv;
4895 while (*e) { /* Get count */
4897 e = e + strlen(e) + 1;
4899 Newx(env, c + 1, char*);
4901 e = pib->pib_pchenv;
4904 e = e + strlen(e) + 1;
4908 _environ = _org_environ = env;
4911 DosReleaseMutexSem(hmtx_emx_init);
4914 #define ENTRY_POINT 0x10000
4919 struct layout_table_t *layout;
4920 if (emx_wasnt_initialized)
4922 /* Now we know that the principal executable is an EMX application
4923 - unless somebody did already play with delayed initialization... */
4924 /* With EMX applications to determine whether it is AOUT one needs
4925 to examine the start of the executable to find "layout" */
4926 if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */
4927 || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */
4928 || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */
4929 || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */
4930 return 0; /* ! EMX executable */
4932 Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
4933 return !(layout->flags & 2);
4937 Perl_OS2_init(char **env)
4939 Perl_OS2_init3(env, 0, 0);
4943 Perl_OS2_init3(char **env, void **preg, int flags)
4948 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
4951 check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
4954 OS2_Perl_data.xs_init = &Xs_OS2_init;
4955 if (perl_sh_installed) {
4956 int l = strlen(perl_sh_installed);
4958 Newx(PL_sh_path, l + 1, char);
4959 memcpy(PL_sh_path, perl_sh_installed, l + 1);
4960 } else if ( (shell = getenv("PERL_SH_DRIVE")) ) {
4961 Newx(PL_sh_path, strlen(SH_PATH) + 1, char);
4962 strcpy(PL_sh_path, SH_PATH);
4963 PL_sh_path[0] = shell[0];
4964 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
4965 int l = strlen(shell), i;
4967 while (l && (shell[l-1] == '/' || shell[l-1] == '\\'))
4969 Newx(PL_sh_path, l + 8, char);
4970 strncpy(PL_sh_path, shell, l);
4971 strcpy(PL_sh_path + l, "/sh.exe");
4972 for (i = 0; i < l; i++) {
4973 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
4976 MUTEX_INIT(&start_thread_mutex);
4977 MUTEX_INIT(&perlos2_state_mutex);
4978 os2_mytype = my_type(); /* Do it before morphing. Needed? */
4979 os2_mytype_ini = os2_mytype;
4980 Perl_os2_initial_mode = -1; /* Uninit */
4982 s = getenv("PERL_BEGINLIBPATH");
4984 rc = fill_extLibpath(0, s, NULL, 1, "PERL_BEGINLIBPATH");
4986 rc = fill_extLibpath(0, getenv("PERL_PRE_BEGINLIBPATH"), getenv("PERL_POST_BEGINLIBPATH"), 0, "PERL_(PRE/POST)_BEGINLIBPATH");
4988 s = getenv("PERL_ENDLIBPATH");
4990 rc = fill_extLibpath(1, s, NULL, 1, "PERL_ENDLIBPATH");
4992 rc = fill_extLibpath(1, getenv("PERL_PRE_ENDLIBPATH"), getenv("PERL_POST_ENDLIBPATH"), 0, "PERL_(PRE/POST)_ENDLIBPATH");
4997 snprintf(buf, sizeof buf, "Error setting BEGIN/ENDLIBPATH: %s\n",
4999 DosWrite(2, buf, strlen(buf), &rc);
5003 _emxload_env("PERL_EMXLOAD_SECS");
5004 /* Some DLLs reset FP flags on load. We may have been linked with them */
5005 _control87(MCW_EM, MCW_EM);
5011 static ULONG max_fh = 0;
5013 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
5014 if (fd >= max_fh) { /* Renew */
5017 if (DosSetRelMaxFH(&delta, &max_fh)) /* Assume it OK??? */
5023 /* Kernels up to Oct 2003 trap on (invalid) dup(max_fh); [off-by-one + double fault]. */
5025 dup2(int from, int to)
5027 if (fd_ok(from < to ? to : from))
5028 return _dup2(from, to);
5046 my_tmpnam (char *str)
5048 char *p = getenv("TMP"), *tpath;
5050 if (!p) p = getenv("TEMP");
5051 tpath = tempnam(p, "pltmp");
5065 if (s.st_mode & S_IWOTH) {
5068 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
5074 /* EMX flavors do not tolerate trailing slashes. t/op/mkdir.t has many
5075 trailing slashes, so we need to support this as well. */
5078 my_rmdir (__const__ char *s)
5082 STRLEN l = strlen(s);
5085 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
5087 Newx(buf, l + 1, char);
5089 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
5103 my_mkdir (__const__ char *s, long perm)
5107 STRLEN l = strlen(s);
5110 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
5112 Newx(buf, l + 1, char);
5114 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
5119 rc = mkdir(s, perm);
5127 /* This code was contributed by Rocco Caputo. */
5129 my_flock(int handle, int o)
5131 FILELOCK rNull, rFull;
5132 ULONG timeout, handle_type, flag_word;
5134 int blocking, shared;
5135 static int use_my_flock = -1;
5137 if (use_my_flock == -1) {
5138 MUTEX_LOCK(&perlos2_state_mutex);
5139 if (use_my_flock == -1) {
5140 char *s = getenv("USE_PERL_FLOCK");
5142 use_my_flock = atoi(s);
5146 MUTEX_UNLOCK(&perlos2_state_mutex);
5148 if (!(_emx_env & 0x200) || !use_my_flock)
5149 return flock(handle, o); /* Delegate to EMX. */
5151 /* is this a file? */
5152 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
5153 (handle_type & 0xFF))
5158 /* set lock/unlock ranges */
5159 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
5160 rFull.lRange = 0x7FFFFFFF;
5161 /* set timeout for blocking */
5162 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
5163 /* shared or exclusive? */
5164 shared = (o & LOCK_SH) ? 1 : 0;
5165 /* do not block the unlock */
5166 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
5167 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
5172 case ERROR_INVALID_HANDLE:
5175 case ERROR_SHARING_BUFFER_EXCEEDED:
5178 case ERROR_LOCK_VIOLATION:
5179 break; /* not an error */
5180 case ERROR_INVALID_PARAMETER:
5181 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
5182 case ERROR_READ_LOCKS_NOT_SUPPORTED:
5185 case ERROR_INTERRUPT:
5193 /* lock may block */
5194 if (o & (LOCK_SH | LOCK_EX)) {
5195 /* for blocking operations */
5209 case ERROR_INVALID_HANDLE:
5212 case ERROR_SHARING_BUFFER_EXCEEDED:
5215 case ERROR_LOCK_VIOLATION:
5217 errno = EWOULDBLOCK;
5221 case ERROR_INVALID_PARAMETER:
5222 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
5223 case ERROR_READ_LOCKS_NOT_SUPPORTED:
5226 case ERROR_INTERRUPT:
5233 /* give away timeslice */
5245 if (_my_pwent == -1) {
5246 char *s = getenv("USE_PERL_PWENT");
5248 _my_pwent = atoi(s);
5262 if (!use_my_pwent()) {
5263 setpwent(); /* Delegate to EMX. */
5272 if (!use_my_pwent()) {
5273 endpwent(); /* Delegate to EMX. */
5281 if (!use_my_pwent())
5282 return getpwent(); /* Delegate to EMX. */
5284 return 0; /* Return one entry only */
5303 return 0; /* Return one entry only */
5310 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
5311 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
5313 static struct passwd *
5314 passw_wrap(struct passwd *p)
5318 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
5321 s = getenv("PW_PASSWD");
5323 s = (char*)pw_p; /* Make match impossible */
5330 my_getpwuid (uid_t id)
5332 return passw_wrap(getpwuid(id));
5336 my_getpwnam (__const__ char *n)
5338 return passw_wrap(getpwnam(n));
5342 gcvt_os2 (double value, int digits, char *buffer)
5344 double absv = value > 0 ? value : -value;
5345 /* EMX implementation is lousy between 0.1 and 0.0001 (uses exponents below
5346 0.1), 1-digit stuff is ok below 0.001; multi-digit below 0.0001. */
5350 buggy = (absv < 1000 && (absv >= 10 || (absv > 1 && floor(absv) != absv)));
5355 sprintf(pat, "%%.%dg", digits);
5356 sprintf(buffer, pat, value);
5359 return gcvt (value, digits, buffer);
5363 int fork_with_resources()
5365 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
5367 void *ctx = PERL_GET_CONTEXT;
5369 unsigned fpflag = _control87(0,0);
5372 if (rc == 0) { /* child */
5373 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
5374 ALLOC_THREAD_KEY; /* Acquire the thread-local memory */
5375 PERL_SET_CONTEXT(ctx); /* Reinit the thread-local memory */
5378 { /* Reload loaded-on-demand DLLs */
5379 struct dll_handle_t *dlls = dll_handles;
5381 while (dlls->modname) {
5382 char dllname[260], fail[260];
5385 if (!dlls->handle) { /* Was not loaded */
5389 /* It was loaded in the parent. We need to reload it. */
5391 rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname);
5393 Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx",
5394 dlls->modname, (int)dlls->handle, rc, rc);
5398 rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle);
5400 Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'",
5406 { /* Support message queue etc. */
5407 os2_mytype = my_type();
5408 /* Apparently, subprocesses (in particular, fork()) do not
5409 inherit the morphed state, so os2_mytype is the same as
5412 if (Perl_os2_initial_mode != -1
5413 && Perl_os2_initial_mode != os2_mytype) {
5418 (void)_obtain_Perl_HAB;
5419 if (Perl_hmq_refcnt) {
5422 Create_HMQ(Perl_hmq_servers != 0,
5423 "Cannot create a message queue on fork");
5426 /* We may have loaded some modules */
5427 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
5432 /* APIRET APIENTRY DosGetInfoSeg(PSEL pselGlobal, PSEL pselLocal); */
5434 ULONG _THUNK_FUNCTION(Dos16GetInfoSeg)(USHORT *pGlobal, USHORT *pLocal);
5437 myDosGetInfoSeg(PGINFOSEG *pGlobal, PLINFOSEG *pLocal)
5440 USHORT gSel, lSel; /* Will not cross 64K boundary */
5443 (_THUNK_PROLOG (4+4);
5444 _THUNK_FLAT (&gSel);
5445 _THUNK_FLAT (&lSel);
5446 _THUNK_CALL (Dos16GetInfoSeg)));
5449 *pGlobal = MAKEPGINFOSEG(gSel);
5450 *pLocal = MAKEPLINFOSEG(lSel);
5459 MUTEX_LOCK(&perlos2_state_mutex);
5461 rc = myDosGetInfoSeg(&gTable, &lTable);
5462 MUTEX_UNLOCK(&perlos2_state_mutex);
5463 os2cp_croak(rc, "Dos16GetInfoSeg");
5468 { /* XXXX Is not lTable thread-specific? */
5471 return gTable->SIS_MsCount;
5475 InfoTable(int local)
5479 return local ? (ULONG)lTable : (ULONG)gTable;