3 #define INCL_DOSFILEMGR
6 /* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */
7 #define INCL_DOSPROCESS
8 #define SPU_DISABLESUPPRESSION 0
9 #define SPU_ENABLESUPPRESSION 1
12 #include <emx/syscalls.h>
14 #include <sys/uflags.h>
17 * Various Unix compatibility functions for OS/2
28 #define PERLIO_NOT_STDIO 0
33 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
35 typedef void (*emx_startroutine)(void *);
36 typedef void* (*pthreads_startroutine)(void *);
45 pthreads_st_exited_waited,
47 const char *pthreads_states[] = {
54 "exited, then waited on",
57 enum pthread_exists { pthread_not_existant = -0xff };
60 pthreads_state_string(enum pthreads_state state)
62 if (state < 0 || state >= sizeof(pthreads_states)/sizeof(*pthreads_states)) {
65 snprintf(buf, sizeof(buf), "unknown thread state %d", (int)state);
68 return pthreads_states[state];
74 enum pthreads_state state;
77 thread_join_t *thread_join_data;
78 int thread_join_count;
79 perl_mutex start_thread_mutex;
82 pthread_join(perl_os_thread tid, void **status)
84 MUTEX_LOCK(&start_thread_mutex);
85 if (tid < 1 || tid >= thread_join_count) {
86 MUTEX_UNLOCK(&start_thread_mutex);
87 if (tid != pthread_not_existant)
88 Perl_croak_nocontext("panic: join with a thread with strange ordinal %d", (int)tid);
89 Perl_warn_nocontext("panic: join with a thread which could not start");
93 switch (thread_join_data[tid].state) {
94 case pthreads_st_exited:
95 thread_join_data[tid].state = pthreads_st_exited_waited;
96 *status = thread_join_data[tid].status;
97 MUTEX_UNLOCK(&start_thread_mutex);
98 COND_SIGNAL(&thread_join_data[tid].cond);
100 case pthreads_st_waited:
101 MUTEX_UNLOCK(&start_thread_mutex);
102 Perl_croak_nocontext("join with a thread with a waiter");
104 case pthreads_st_norun:
106 int state = (int)thread_join_data[tid].status;
108 thread_join_data[tid].state = pthreads_st_none;
109 MUTEX_UNLOCK(&start_thread_mutex);
110 Perl_croak_nocontext("panic: join with a thread which could not run"
111 " due to attempt of tid reuse (state='%s')",
112 pthreads_state_string(state));
115 case pthreads_st_run:
119 thread_join_data[tid].state = pthreads_st_waited;
120 thread_join_data[tid].status = (void *)status;
121 COND_INIT(&thread_join_data[tid].cond);
122 cond = thread_join_data[tid].cond;
123 COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
125 MUTEX_UNLOCK(&start_thread_mutex);
129 MUTEX_UNLOCK(&start_thread_mutex);
130 Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'",
131 pthreads_state_string(thread_join_data[tid].state));
138 pthreads_startroutine sub;
144 a) Since we temporarily usurp the caller interp, so malloc() may
145 use it to decide on debugging the call;
146 b) Since *args is on the caller's stack.
149 pthread_startit(void *arg1)
151 /* Thread is already started, we need to transfer control only */
152 pthr_startit args = *(pthr_startit *)arg1;
153 int tid = pthread_self();
158 /* Can't croak, the setjmp() is not in scope... */
161 snprintf(buf, sizeof(buf),
162 "panic: thread with strange ordinal %d created\n\r", tid);
163 write(2,buf,strlen(buf));
164 MUTEX_UNLOCK(&start_thread_mutex);
167 /* Until args.sub resets it, makes debugging Perl_malloc() work: */
169 if (tid >= thread_join_count) {
170 int oc = thread_join_count;
172 thread_join_count = tid + 5 + tid/5;
173 if (thread_join_data) {
174 Renew(thread_join_data, thread_join_count, thread_join_t);
175 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
177 Newz(1323, thread_join_data, thread_join_count, thread_join_t);
180 if (thread_join_data[tid].state != pthreads_st_none) {
181 /* Can't croak, the setjmp() is not in scope... */
184 snprintf(buf, sizeof(buf),
185 "panic: attempt to reuse thread id %d (state='%s')\n\r",
186 tid, pthreads_state_string(thread_join_data[tid].state));
187 write(2,buf,strlen(buf));
188 thread_join_data[tid].status = (void*)thread_join_data[tid].state;
189 thread_join_data[tid].state = pthreads_st_norun;
190 MUTEX_UNLOCK(&start_thread_mutex);
193 thread_join_data[tid].state = pthreads_st_run;
194 /* Now that we copied/updated the guys, we may release the caller... */
195 MUTEX_UNLOCK(&start_thread_mutex);
196 rc = (*args.sub)(args.arg);
197 MUTEX_LOCK(&start_thread_mutex);
198 switch (thread_join_data[tid].state) {
199 case pthreads_st_waited:
200 COND_SIGNAL(&thread_join_data[tid].cond);
201 thread_join_data[tid].state = pthreads_st_none;
202 *((void**)thread_join_data[tid].status) = rc;
204 case pthreads_st_detached:
205 thread_join_data[tid].state = pthreads_st_none;
207 case pthreads_st_run:
208 /* Somebody can wait on us; cannot exit, since OS can reuse the tid
209 and our waiter will get somebody else's status. */
210 thread_join_data[tid].state = pthreads_st_exited;
211 thread_join_data[tid].status = rc;
212 COND_INIT(&thread_join_data[tid].cond);
213 COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
214 COND_DESTROY(&thread_join_data[tid].cond);
215 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
218 state = thread_join_data[tid].state;
219 MUTEX_UNLOCK(&start_thread_mutex);
220 Perl_croak_nocontext("panic: unexpected thread state on exit: '%s'",
221 pthreads_state_string(state));
223 MUTEX_UNLOCK(&start_thread_mutex);
227 pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr,
228 void *(*start_routine)(void*), void *arg)
233 args.sub = (void*)start_routine;
235 args.ctx = PERL_GET_CONTEXT;
237 MUTEX_LOCK(&start_thread_mutex);
238 /* Test suite creates 31 extra threads;
239 on machine without shared-memory-hogs this stack sizeis OK with 31: */
240 *tidp = _beginthread(pthread_startit, /*stack*/ NULL,
241 /*stacksize*/ 4*1024*1024, (void*)&args);
243 *tidp = pthread_not_existant;
244 MUTEX_UNLOCK(&start_thread_mutex);
247 MUTEX_LOCK(&start_thread_mutex); /* Wait for init to proceed */
248 MUTEX_UNLOCK(&start_thread_mutex);
253 pthread_detach(perl_os_thread tid)
255 MUTEX_LOCK(&start_thread_mutex);
256 if (tid < 1 || tid >= thread_join_count) {
257 MUTEX_UNLOCK(&start_thread_mutex);
258 if (tid != pthread_not_existant)
259 Perl_croak_nocontext("panic: detach of a thread with strange ordinal %d", (int)tid);
260 Perl_warn_nocontext("detach of a thread which could not start");
263 switch (thread_join_data[tid].state) {
264 case pthreads_st_waited:
265 MUTEX_UNLOCK(&start_thread_mutex);
266 Perl_croak_nocontext("detach on a thread with a waiter");
268 case pthreads_st_run:
269 thread_join_data[tid].state = pthreads_st_detached;
270 MUTEX_UNLOCK(&start_thread_mutex);
272 case pthreads_st_exited:
273 MUTEX_UNLOCK(&start_thread_mutex);
274 COND_SIGNAL(&thread_join_data[tid].cond);
276 case pthreads_st_detached:
277 MUTEX_UNLOCK(&start_thread_mutex);
278 Perl_warn_nocontext("detach on an already detached thread");
280 case pthreads_st_norun:
282 int state = (int)thread_join_data[tid].status;
284 thread_join_data[tid].state = pthreads_st_none;
285 MUTEX_UNLOCK(&start_thread_mutex);
286 Perl_croak_nocontext("panic: detaching thread which could not run"
287 " due to attempt of tid reuse (state='%s')",
288 pthreads_state_string(state));
292 MUTEX_UNLOCK(&start_thread_mutex);
293 Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'",
294 pthreads_state_string(thread_join_data[tid].state));
300 /* This is a very bastardized version; may be OK due to edge trigger of Wait */
302 os2_cond_wait(perl_cond *c, perl_mutex *m)
306 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
307 Perl_croak_nocontext("panic: COND_WAIT-reset: rc=%i", rc);
308 if (m) MUTEX_UNLOCK(m);
309 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
310 && (rc != ERROR_INTERRUPT))
311 Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc);
312 if (rc == ERROR_INTERRUPT)
314 if (m) MUTEX_LOCK(m);
319 static int exe_is_aout(void);
321 /*****************************************************************************/
322 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
323 #define C_ARR_LEN(sym) (sizeof(sym)/sizeof(*sym))
329 static struct dll_handle doscalls_handle = {"doscalls", 0};
330 static struct dll_handle tcp_handle = {"tcp32dll", 0};
331 static struct dll_handle pmwin_handle = {"pmwin", 0};
332 static struct dll_handle rexx_handle = {"rexx", 0};
333 static struct dll_handle rexxapi_handle = {"rexxapi", 0};
334 static struct dll_handle sesmgr_handle = {"sesmgr", 0};
335 static struct dll_handle pmshapi_handle = {"pmshapi", 0};
337 /* This should match enum entries_ordinals defined in os2ish.h. */
338 static const struct {
339 struct dll_handle *dll;
340 const char *entryname;
342 } loadOrdinals[ORD_NENTRIES] = {
343 {&doscalls_handle, NULL, 874}, /* DosQueryExtLibpath */
344 {&doscalls_handle, NULL, 873}, /* DosSetExtLibpath */
345 {&doscalls_handle, NULL, 460}, /* DosVerifyPidTid */
346 {&tcp_handle, "SETHOSTENT", 0},
347 {&tcp_handle, "SETNETENT" , 0},
348 {&tcp_handle, "SETPROTOENT", 0},
349 {&tcp_handle, "SETSERVENT", 0},
350 {&tcp_handle, "GETHOSTENT", 0},
351 {&tcp_handle, "GETNETENT" , 0},
352 {&tcp_handle, "GETPROTOENT", 0},
353 {&tcp_handle, "GETSERVENT", 0},
354 {&tcp_handle, "ENDHOSTENT", 0},
355 {&tcp_handle, "ENDNETENT", 0},
356 {&tcp_handle, "ENDPROTOENT", 0},
357 {&tcp_handle, "ENDSERVENT", 0},
358 {&pmwin_handle, NULL, 763}, /* WinInitialize */
359 {&pmwin_handle, NULL, 716}, /* WinCreateMsgQueue */
360 {&pmwin_handle, NULL, 726}, /* WinDestroyMsgQueue */
361 {&pmwin_handle, NULL, 918}, /* WinPeekMsg */
362 {&pmwin_handle, NULL, 915}, /* WinGetMsg */
363 {&pmwin_handle, NULL, 912}, /* WinDispatchMsg */
364 {&pmwin_handle, NULL, 753}, /* WinGetLastError */
365 {&pmwin_handle, NULL, 705}, /* WinCancelShutdown */
366 /* These are needed in extensions.
367 How to protect PMSHAPI: it comes through EMX functions? */
368 {&rexx_handle, "RexxStart", 0},
369 {&rexx_handle, "RexxVariablePool", 0},
370 {&rexxapi_handle, "RexxRegisterFunctionExe", 0},
371 {&rexxapi_handle, "RexxDeregisterFunction", 0},
372 {&sesmgr_handle, "DOSSMSETTITLE", 0}, /* Would not work runtime-loaded */
373 {&pmshapi_handle, "PRF32QUERYPROFILESIZE", 0},
374 {&pmshapi_handle, "PRF32OPENPROFILE", 0},
375 {&pmshapi_handle, "PRF32CLOSEPROFILE", 0},
376 {&pmshapi_handle, "PRF32QUERYPROFILE", 0},
377 {&pmshapi_handle, "PRF32RESET", 0},
378 {&pmshapi_handle, "PRF32QUERYPROFILEDATA", 0},
379 {&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0},
381 /* At least some of these do not work by name, since they need
382 WIN32 instead of WIN... */
384 These were generated with
385 nm I:\emx\lib\os2.a | fgrep -f API-list | grep = > API-list-entries
386 perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( ORD_$1,)" API-list-entries > API-list-ORD_
387 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
389 {&pmshapi_handle, NULL, 123}, /* WinChangeSwitchEntry */
390 {&pmshapi_handle, NULL, 124}, /* WinQuerySwitchEntry */
391 {&pmshapi_handle, NULL, 125}, /* WinQuerySwitchHandle */
392 {&pmshapi_handle, NULL, 126}, /* WinQuerySwitchList */
393 {&pmshapi_handle, NULL, 131}, /* WinSwitchToProgram */
394 {&pmwin_handle, NULL, 702}, /* WinBeginEnumWindows */
395 {&pmwin_handle, NULL, 737}, /* WinEndEnumWindows */
396 {&pmwin_handle, NULL, 740}, /* WinEnumDlgItem */
397 {&pmwin_handle, NULL, 756}, /* WinGetNextWindow */
398 {&pmwin_handle, NULL, 768}, /* WinIsChild */
399 {&pmwin_handle, NULL, 799}, /* WinQueryActiveWindow */
400 {&pmwin_handle, NULL, 805}, /* WinQueryClassName */
401 {&pmwin_handle, NULL, 817}, /* WinQueryFocus */
402 {&pmwin_handle, NULL, 834}, /* WinQueryWindow */
403 {&pmwin_handle, NULL, 837}, /* WinQueryWindowPos */
404 {&pmwin_handle, NULL, 838}, /* WinQueryWindowProcess */
405 {&pmwin_handle, NULL, 841}, /* WinQueryWindowText */
406 {&pmwin_handle, NULL, 842}, /* WinQueryWindowTextLength */
407 {&pmwin_handle, NULL, 860}, /* WinSetFocus */
408 {&pmwin_handle, NULL, 875}, /* WinSetWindowPos */
409 {&pmwin_handle, NULL, 877}, /* WinSetWindowText */
410 {&pmwin_handle, NULL, 883}, /* WinShowWindow */
411 {&pmwin_handle, NULL, 772}, /* WinIsWindow */
412 {&pmwin_handle, NULL, 899}, /* WinWindowFromId */
413 {&pmwin_handle, NULL, 900}, /* WinWindowFromPoint */
414 {&pmwin_handle, NULL, 919}, /* WinPostMsg */
415 {&pmwin_handle, NULL, 735}, /* WinEnableWindow */
416 {&pmwin_handle, NULL, 736}, /* WinEnableWindowUpdate */
417 {&pmwin_handle, NULL, 773}, /* WinIsWindowEnabled */
418 {&pmwin_handle, NULL, 774}, /* WinIsWindowShowing */
419 {&pmwin_handle, NULL, 775}, /* WinIsWindowVisible */
420 {&pmwin_handle, NULL, 839}, /* WinQueryWindowPtr */
421 {&pmwin_handle, NULL, 843}, /* WinQueryWindowULong */
422 {&pmwin_handle, NULL, 844}, /* WinQueryWindowUShort */
423 {&pmwin_handle, NULL, 874}, /* WinSetWindowBits */
424 {&pmwin_handle, NULL, 876}, /* WinSetWindowPtr */
425 {&pmwin_handle, NULL, 878}, /* WinSetWindowULong */
426 {&pmwin_handle, NULL, 879}, /* WinSetWindowUShort */
427 {&pmwin_handle, NULL, 813}, /* WinQueryDesktopWindow */
428 {&pmwin_handle, NULL, 851}, /* WinSetActiveWindow */
429 {&doscalls_handle, NULL, 360}, /* DosQueryModFromEIP */
432 static PFN ExtFCN[C_ARR_LEN(loadOrdinals)]; /* Labeled by ord ORD_*. */
433 const Perl_PFN * const pExtFCN = ExtFCN;
434 struct PMWIN_entries_t PMWIN_entries;
437 loadModule(const char *modname, int fail)
439 HMODULE h = (HMODULE)dlopen(modname, 0);
442 Perl_croak_nocontext("Error loading module '%s': %s",
448 loadByOrdinal(enum entries_ordinals ord, int fail)
450 if (ExtFCN[ord] == NULL) {
454 if (!loadOrdinals[ord].dll->handle)
455 loadOrdinals[ord].dll->handle
456 = loadModule(loadOrdinals[ord].dll->modname, fail);
457 if (!loadOrdinals[ord].dll->handle)
458 return 0; /* Possible with FAIL==0 only */
459 if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle,
460 loadOrdinals[ord].entrypoint,
461 loadOrdinals[ord].entryname,&fcn))) {
462 char buf[20], *s = (char*)loadOrdinals[ord].entryname;
467 sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint);
468 Perl_croak_nocontext(
469 "This version of OS/2 does not support %s.%s",
470 loadOrdinals[ord].dll->modname, s);
474 if ((long)ExtFCN[ord] == -1)
475 Perl_croak_nocontext("panic queryaddr");
480 init_PMWIN_entries(void)
484 for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++)
485 ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1);
488 /*****************************************************/
489 /* socket forwarders without linking with tcpip DLLs */
491 DeclFuncByORD(struct hostent *, gethostent, ORD_GETHOSTENT, (void), ())
492 DeclFuncByORD(struct netent *, getnetent, ORD_GETNETENT, (void), ())
493 DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ())
494 DeclFuncByORD(struct servent *, getservent, ORD_GETSERVENT, (void), ())
496 DeclVoidFuncByORD(sethostent, ORD_SETHOSTENT, (int x), (x))
497 DeclVoidFuncByORD(setnetent, ORD_SETNETENT, (int x), (x))
498 DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x))
499 DeclVoidFuncByORD(setservent, ORD_SETSERVENT, (int x), (x))
501 DeclVoidFuncByORD(endhostent, ORD_ENDHOSTENT, (void), ())
502 DeclVoidFuncByORD(endnetent, ORD_ENDNETENT, (void), ())
503 DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ())
504 DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ())
507 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
509 #define QSS_INI_BUFFER 1024
511 ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
512 static int pidtid_lookup;
515 get_sysinfo(ULONG pid, ULONG flags)
518 ULONG rc, buf_len = QSS_INI_BUFFER;
521 if (!pidtid_lookup) {
523 *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0);
525 if (pDosVerifyPidTid) { /* Warp3 or later */
526 /* Up to some fixpak QuerySysState() kills the system if a non-existent
528 if (CheckOSError(pDosVerifyPidTid(pid, 1)))
531 New(1322, pbuffer, buf_len, char);
532 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
533 rc = QuerySysState(flags, pid, pbuffer, buf_len);
534 while (rc == ERROR_BUFFER_OVERFLOW) {
535 Renew(pbuffer, buf_len *= 2, char);
536 rc = QuerySysState(flags, pid, pbuffer, buf_len);
543 psi = (PQTOPLEVEL)pbuffer;
544 if (psi && pid && pid != psi->procdata->pid) {
546 Perl_croak_nocontext("panic: wrong pid in sysinfo");
551 #define PRIO_ERR 0x1111
561 psi = get_sysinfo(pid, QSS_PROCESS);
564 prio = psi->procdata->threads->priority;
570 setpriority(int which, int pid, int val)
572 ULONG rc, prio = sys_prio(pid);
574 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
575 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
576 /* Do not change class. */
577 return CheckOSError(DosSetPriority((pid < 0)
578 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
580 (32 - val) % 32 - (prio & 0xFF),
583 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
584 /* Documentation claims one can change both class and basevalue,
585 * but I find it wrong. */
586 /* Change class, but since delta == 0 denotes absolute 0, correct. */
587 if (CheckOSError(DosSetPriority((pid < 0)
588 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
589 priors[(32 - val) >> 5] + 1,
593 if ( ((32 - val) % 32) == 0 ) return 0;
594 return CheckOSError(DosSetPriority((pid < 0)
595 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
604 getpriority(int which /* ignored */, int pid)
608 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
610 if (ret == PRIO_ERR) {
613 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
616 /*****************************************************************************/
619 int emx_runtime_init; /* If 1, we need to manually init it */
620 int emx_exception_init; /* If 1, we need to manually set it */
622 /* There is no big sense to make it thread-specific, since signals
623 are delivered to thread 1 only. XXXX Maybe make it into an array? */
624 static int spawn_pid;
625 static int spawn_killed;
628 spawn_sighandler(int sig)
630 /* Some programs do not arrange for the keyboard signals to be
631 delivered to them. We need to deliver the signal manually. */
632 /* We may get a signal only if
633 a) kid does not receive keyboard signal: deliver it;
634 b) kid already died, and we get a signal. We may only hope
635 that the pid number was not reused.
639 sig = SIGKILL; /* Try harder. */
640 kill(spawn_pid, sig);
645 result(pTHX_ int flag, int pid)
648 Signal_t (*ihand)(); /* place to save signal during system() */
649 Signal_t (*qhand)(); /* place to save signal during system() */
655 if (pid < 0 || flag != 0)
661 ihand = rsignal(SIGINT, &spawn_sighandler);
662 qhand = rsignal(SIGQUIT, &spawn_sighandler);
664 r = wait4pid(pid, &status, 0);
665 } while (r == -1 && errno == EINTR);
666 rsignal(SIGINT, ihand);
667 rsignal(SIGQUIT, qhand);
669 PL_statusvalue = (U16)status;
672 return status & 0xFFFF;
674 ihand = rsignal(SIGINT, SIG_IGN);
675 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
676 rsignal(SIGINT, ihand);
677 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
680 return PL_statusvalue;
693 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
702 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
703 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
706 return (pib->pib_ultype);
710 file_type(char *path)
715 if (!(_emx_env & 0x200))
716 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
717 if (CheckOSError(DosQueryAppType(path, &apptype))) {
719 case ERROR_FILE_NOT_FOUND:
720 case ERROR_PATH_NOT_FOUND:
722 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
724 default: /* Found, but not an
725 executable, or some other
733 static ULONG os2_mytype;
735 /* Spawn/exec a program, revert to shell if needed. */
736 /* global PL_Argv[] contains arguments. */
738 extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
739 EXCEPTIONREGISTRATIONRECORD *,
744 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
750 static char * fargs[4]
751 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
752 char **argsp = fargs;
755 int new_stderr = -1, nostderr = 0;
765 if (strEQ(PL_Argv[0],"/bin/sh"))
766 PL_Argv[0] = PL_sh_path;
768 /* We should check PERL_SH* and PERLLIB_* as well? */
769 if (!really || !*(tmps = SvPV(really, n_a)))
771 if (tmps[0] != '/' && tmps[0] != '\\'
772 && !(tmps[0] && tmps[1] == ':'
773 && (tmps[2] == '/' || tmps[2] != '\\'))
774 ) /* will spawnvp use PATH? */
775 TAINT_ENV(); /* testing IFS here is overkill, probably */
779 if (_emx_env & 0x200) { /* OS/2. */
780 int type = file_type(tmps);
782 if (type == -1) { /* Not found */
787 else if (type == -2) { /* Not an EXE */
792 else if (type == -3) { /* Is a directory? */
793 /* Special-case this */
795 int l = strlen(tmps);
797 if (l + 5 <= sizeof tbuf) {
799 strcpy(tbuf + l, ".exe");
800 type = file_type(tbuf);
810 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
811 case FAPPTYP_WINDOWAPI:
813 if (os2_mytype != 3) { /* not PM */
814 if (flag == P_NOWAIT)
816 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
817 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d",
822 case FAPPTYP_NOTWINDOWCOMPAT:
824 if (os2_mytype != 0) { /* not full screen */
825 if (flag == P_NOWAIT)
827 else if ((flag & 7) != P_SESSION)
828 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d",
833 case FAPPTYP_NOTSPEC:
834 /* Let the shell handle this... */
836 buf = ""; /* Pacify a warning */
837 file = 0; /* Pacify a warning */
845 new_stderr = dup(2); /* Preserve stderr */
846 if (new_stderr == -1) {
854 fl_stderr = fcntl(2, F_GETFD);
858 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
862 rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv));
864 if (execf == EXECF_TRUEEXEC)
865 rc = execvp(tmps,PL_Argv);
866 else if (execf == EXECF_EXEC)
867 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
868 else if (execf == EXECF_SPAWN_NOWAIT)
869 rc = spawnvp(flag,tmps,PL_Argv);
870 else if (execf == EXECF_SYNC)
871 rc = spawnvp(trueflag,tmps,PL_Argv);
872 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
873 rc = result(aTHX_ trueflag,
874 spawnvp(flag,tmps,PL_Argv));
876 if (rc < 0 && pass == 1
877 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
882 if (err == ENOENT || err == ENOEXEC) {
883 /* No such file, or is a script. */
884 /* Try adding script extensions to the file name, and
886 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
890 SV *scrsv = sv_2mortal(newSVpv(scr, 0));
891 SV *bufsv = sv_newmortal();
894 scr = SvPV(scrsv, n_a); /* free()ed later */
896 file = PerlIO_open(scr, "r");
901 buf = sv_gets(bufsv, file, 0 /* No append */);
903 buf = ""; /* XXX Needed? */
904 if (!buf[0]) { /* Empty... */
906 /* Special case: maybe from -Zexe build, so
907 there is an executable around (contrary to
908 documentation, DosQueryAppType sometimes (?)
909 does not append ".exe", so we could have
910 reached this place). */
911 sv_catpv(scrsv, ".exe");
912 scr = SvPV(scrsv, n_a); /* Reload */
913 if (PerlLIO_stat(scr,&PL_statbuf) >= 0
914 && !S_ISDIR(PL_statbuf.st_mode)) { /* Found */
918 } else { /* Restore */
919 SvCUR_set(scrsv, SvCUR(scrsv) - 4);
923 if (PerlIO_close(file) != 0) { /* Failure */
925 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
926 scr, Strerror(errno));
927 buf = ""; /* Not #! */
933 } else if (buf[0] == 'e') {
934 if (strnEQ(buf, "extproc", 7)
937 } else if (buf[0] == 'E') {
938 if (strnEQ(buf, "EXTPROC", 7)
943 buf = ""; /* Not #! */
951 /* Do better than pdksh: allow a few args,
952 strip trailing whitespace. */
962 while (*s && !isSPACE(*s))
969 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"",
974 /* Can jump from far, buf/file invalid if force_shell: */
981 || (!buf[0] && file)) { /* File without magic */
982 /* In fact we tried all what pdksh would
983 try. There is no point in calling
984 pdksh, we may just emulate its logic. */
985 char *shell = getenv("EXECSHELL");
986 char *shell_opt = NULL;
992 shell = getenv("OS2_SHELL");
993 if (inicmd) { /* No spaces at start! */
995 while (*s && !isSPACE(*s)) {
997 inicmd = NULL; /* Cannot use */
1005 /* Dosish shells will choke on slashes
1006 in paths, fortunately, this is
1007 important for zeroth arg only. */
1014 /* If EXECSHELL is set, we do not set */
1017 shell = ((_emx_env & 0x200)
1019 : "c:/command.com");
1020 nargs = shell_opt ? 2 : 1; /* shell file args */
1021 exec_args[0] = shell;
1022 exec_args[1] = shell_opt;
1024 if (nargs == 2 && inicmd) {
1025 /* Use the original cmd line */
1026 /* XXXX This is good only until we refuse
1027 quoted arguments... */
1028 PL_Argv[0] = inicmd;
1029 PL_Argv[1] = Nullch;
1031 } else if (!buf[0] && inicmd) { /* No file */
1032 /* Start with the original cmdline. */
1033 /* XXXX This is good only until we refuse
1034 quoted arguments... */
1036 PL_Argv[0] = inicmd;
1037 PL_Argv[1] = Nullch;
1038 nargs = 2; /* shell -c */
1041 while (a[1]) /* Get to the end */
1043 a++; /* Copy finil NULL too */
1044 while (a >= PL_Argv) {
1045 *(a + nargs) = *a; /* PL_Argv was preallocated to be
1049 while (--nargs >= 0)
1050 PL_Argv[nargs] = argsp[nargs];
1051 /* Enable pathless exec if #! (as pdksh). */
1052 pass = (buf[0] == '#' ? 2 : 3);
1056 /* Not found: restore errno */
1060 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
1061 char *no_dir = strrchr(PL_Argv[0], '/');
1063 /* Do as pdksh port does: if not found with /, try without
1066 PL_Argv[0] = no_dir + 1;
1071 if (rc < 0 && ckWARN(WARN_EXEC))
1072 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n",
1073 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1074 ? "spawn" : "exec"),
1075 PL_Argv[0], Strerror(errno));
1076 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
1077 && ((trueflag & 0xFF) == P_WAIT))
1081 if (new_stderr != -1) { /* How can we use error codes? */
1082 dup2(new_stderr, 2);
1084 fcntl(2, F_SETFD, fl_stderr);
1085 } else if (nostderr)
1090 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
1092 do_spawn3(pTHX_ char *cmd, int execf, int flag)
1096 char *shell, *copt, *news = NULL;
1097 int rc, seenspace = 0, mergestderr = 0;
1100 if ((shell = getenv("EMXSHELL")) != NULL)
1102 else if ((shell = getenv("SHELL")) != NULL)
1104 else if ((shell = getenv("COMSPEC")) != NULL)
1109 /* Consensus on perl5-porters is that it is _very_ important to
1110 have a shell which will not change between computers with the
1111 same architecture, to avoid "action on a distance".
1112 And to have simple build, this shell should be sh. */
1117 while (*cmd && isSPACE(*cmd))
1120 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
1121 STRLEN l = strlen(PL_sh_path);
1123 New(1302, news, strlen(cmd) - 7 + l + 1, char);
1124 strcpy(news, PL_sh_path);
1125 strcpy(news + l, cmd + 7);
1129 /* save an extra exec if possible */
1130 /* see if there are shell metacharacters in it */
1132 if (*cmd == '.' && isSPACE(cmd[1]))
1135 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1138 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
1142 for (s = cmd; *s; s++) {
1143 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
1144 if (*s == '\n' && s[1] == '\0') {
1147 } else if (*s == '\\' && !seenspace) {
1148 continue; /* Allow backslashes in names */
1149 } else if (*s == '>' && s >= cmd + 3
1150 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
1151 && isSPACE(s[-2]) ) {
1154 while (*t && isSPACE(*t))
1159 break; /* Allow 2>&1 as the last thing */
1162 /* We do not convert this to do_spawn_ve since shell
1163 should be smart enough to start itself gloriously. */
1165 if (execf == EXECF_TRUEEXEC)
1166 rc = execl(shell,shell,copt,cmd,(char*)0);
1167 else if (execf == EXECF_EXEC)
1168 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
1169 else if (execf == EXECF_SPAWN_NOWAIT)
1170 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
1171 else if (execf == EXECF_SPAWN_BYFLAG)
1172 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
1174 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
1175 if (execf == EXECF_SYNC)
1176 rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0);
1178 rc = result(aTHX_ P_WAIT,
1179 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
1180 if (rc < 0 && ckWARN(WARN_EXEC))
1181 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
1182 (execf == EXECF_SPAWN ? "spawn" : "exec"),
1183 shell, Strerror(errno));
1190 } else if (*s == ' ' || *s == '\t') {
1195 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
1196 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
1197 PL_Cmd = savepvn(cmd, s-cmd);
1199 for (s = PL_Cmd; *s;) {
1200 while (*s && isSPACE(*s)) s++;
1203 while (*s && !isSPACE(*s)) s++;
1209 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
1220 os2_do_aspawn(pTHX_ SV *really, register void **vmark, register void **vsp)
1222 register SV **mark = (SV **)vmark;
1223 register SV **sp = (SV **)vsp;
1226 int flag = P_WAIT, flag_set = 0;
1230 New(1301,PL_Argv, sp - mark + 3, char*);
1233 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
1235 flag = SvIVx(*mark);
1240 while (++mark <= sp) {
1242 *a++ = SvPVx(*mark, n_a);
1248 if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
1249 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
1251 rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0);
1259 os2_do_spawn(pTHX_ char *cmd)
1261 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
1265 do_spawn_nowait(pTHX_ char *cmd)
1267 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1271 Perl_do_exec(pTHX_ char *cmd)
1273 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1278 os2exec(pTHX_ char *cmd)
1280 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1284 my_syspopen(pTHX_ char *cmd, char *mode)
1288 register I32 this, that, newfd;
1291 int fh_fl = 0; /* Pacify the warning */
1293 /* `this' is what we use in the parent, `that' in the child. */
1294 this = (*mode == 'w');
1298 taint_proper("Insecure %s%s", "EXEC");
1302 /* Now we need to spawn the child. */
1303 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1304 int new = dup(p[this]);
1311 newfd = dup(*mode == 'r'); /* Preserve std* */
1313 /* This cannot happen due to fh being bad after pipe(), since
1314 pipe() should have created fh 0 and 1 even if they were
1315 initially closed. But we closed p[this] before. */
1316 if (errno != EBADF) {
1323 fh_fl = fcntl(*mode == 'r', F_GETFD);
1324 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1325 dup2(p[that], *mode == 'r');
1328 /* Where is `this' and newfd now? */
1329 fcntl(p[this], F_SETFD, FD_CLOEXEC);
1331 fcntl(newfd, F_SETFD, FD_CLOEXEC);
1332 pid = do_spawn_nowait(aTHX_ cmd);
1334 close(*mode == 'r'); /* It was closed initially */
1335 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1336 dup2(newfd, *mode == 'r'); /* Return std* back. */
1338 fcntl(*mode == 'r', F_SETFD, fh_fl);
1340 fcntl(*mode == 'r', F_SETFD, fh_fl);
1341 if (p[that] == (*mode == 'r'))
1347 if (p[that] < p[this]) { /* Make fh as small as possible */
1348 dup2(p[this], p[that]);
1352 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1353 (void)SvUPGRADE(sv,SVt_IV);
1355 PL_forkprocess = pid;
1356 return PerlIO_fdopen(p[this], mode);
1358 #else /* USE_POPEN */
1364 res = popen(cmd, mode);
1366 char *shell = getenv("EMXSHELL");
1368 my_setenv("EMXSHELL", PL_sh_path);
1369 res = popen(cmd, mode);
1370 my_setenv("EMXSHELL", shell);
1372 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1373 (void)SvUPGRADE(sv,SVt_IV);
1374 SvIVX(sv) = -1; /* A cooky. */
1377 #endif /* USE_POPEN */
1381 /******************************************************************/
1387 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1393 /*******************************************************************/
1394 /* not implemented in EMX 0.9d */
1396 char * ctermid(char *s) { return 0; }
1398 #ifdef MYTTYNAME /* was not in emx0.9a */
1399 void * ttyname(x) { return 0; }
1402 /*****************************************************************************/
1403 /* not implemented in C Set++ */
1406 int setuid(x) { errno = EINVAL; return -1; }
1407 int setgid(x) { errno = EINVAL; return -1; }
1410 /*****************************************************************************/
1411 /* stat() hack for char/block device */
1415 enum os2_stat_extra { /* EMX 0.9d fix 4 defines up to 0100000 */
1416 os2_stat_archived = 0x1000000, /* 0100000000 */
1417 os2_stat_hidden = 0x2000000, /* 0200000000 */
1418 os2_stat_system = 0x4000000, /* 0400000000 */
1419 os2_stat_force = 0x8000000, /* Do not ignore flags on chmod */
1422 #define OS2_STAT_SPECIAL (os2_stat_system | os2_stat_archived | os2_stat_hidden)
1425 massage_os2_attr(struct stat *st)
1427 if ( ((st->st_mode & S_IFMT) != S_IFREG
1428 && (st->st_mode & S_IFMT) != S_IFDIR)
1429 || !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM)))
1432 if ( st->st_attr & FILE_ARCHIVED )
1433 st->st_mode |= (os2_stat_archived | os2_stat_force);
1434 if ( st->st_attr & FILE_HIDDEN )
1435 st->st_mode |= (os2_stat_hidden | os2_stat_force);
1436 if ( st->st_attr & FILE_SYSTEM )
1437 st->st_mode |= (os2_stat_system | os2_stat_force);
1440 /* First attempt used DosQueryFSAttach which crashed the system when
1441 used with 5.001. Now just look for /dev/. */
1443 os2_stat(const char *name, struct stat *st)
1445 static int ino = SHRT_MAX;
1446 STRLEN l = strlen(name);
1448 if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0
1449 || ( stricmp(name + 5, "con") != 0
1450 && stricmp(name + 5, "tty") != 0
1451 && stricmp(name + 5, "nul") != 0
1452 && stricmp(name + 5, "null") != 0) ) {
1453 int s = stat(name, st);
1457 massage_os2_attr(st);
1461 memset(st, 0, sizeof *st);
1462 st->st_mode = S_IFCHR|0666;
1463 st->st_ino = (ino-- & 0x7FFF);
1469 os2_fstat(int handle, struct stat *st)
1471 int s = fstat(handle, st);
1475 massage_os2_attr(st);
1481 os2_chmod (const char *name, int pmode) /* Modelled after EMX src/lib/io/chmod.c */
1485 if (!(pmode & os2_stat_force))
1486 return chmod(name, pmode);
1488 attr = __chmod (name, 0, 0); /* Get attributes */
1491 if (pmode & S_IWRITE)
1492 attr &= ~FILE_READONLY;
1494 attr |= FILE_READONLY;
1496 attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM);
1498 if ( pmode & os2_stat_archived )
1499 attr |= FILE_ARCHIVED;
1500 if ( pmode & os2_stat_hidden )
1501 attr |= FILE_HIDDEN;
1502 if ( pmode & os2_stat_system )
1503 attr |= FILE_SYSTEM;
1505 rc = __chmod (name, 1, attr);
1506 if (rc >= 0) rc = 0;
1512 #ifdef USE_PERL_SBRK
1514 /* SBRK() emulation, mostly moved to malloc.c. */
1517 sys_alloc(int size) {
1519 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1521 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1524 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1528 #endif /* USE_PERL_SBRK */
1532 char *tmppath = TMPPATH1;
1537 char *p = getenv("TMP"), *tpath;
1540 if (!p) p = getenv("TEMP");
1543 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1547 strcpy(tpath + len + 1, TMPPATH1);
1554 XS(XS_File__Copy_syscopy)
1557 if (items < 2 || items > 3)
1558 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1561 char * src = (char *)SvPV(ST(0),n_a);
1562 char * dst = (char *)SvPV(ST(1),n_a);
1569 flag = (unsigned long)SvIV(ST(2));
1572 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1573 ST(0) = sv_newmortal();
1574 sv_setiv(ST(0), (IV)RETVAL);
1579 #define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */
1580 #include "patchlevel.h"
1581 #undef PERL_PATCHLEVEL_H_IMPLICIT
1584 mod2fname(pTHX_ SV *sv)
1586 static char fname[9];
1587 int pos = 6, len, avlen;
1588 unsigned int sum = 0;
1592 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1594 if (SvTYPE(sv) != SVt_PVAV)
1595 Perl_croak_nocontext("Not array reference given to mod2fname");
1597 avlen = av_len((AV*)sv);
1599 Perl_croak_nocontext("Empty array reference given to mod2fname");
1601 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1602 strncpy(fname, s, 8);
1604 if (len < 6) pos = len;
1606 sum = 33 * sum + *(s++); /* Checksumming first chars to
1607 * get the capitalization into c.s. */
1610 while (avlen >= 0) {
1611 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1613 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1617 /* We always load modules as *specific* DLLs, and with the full name.
1618 When loading a specific DLL by its full name, one cannot get a
1619 different DLL, even if a DLL with the same basename is loaded already.
1620 Thus there is no need to include the version into the mangling scheme. */
1622 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
1624 # ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
1625 # define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
1627 sum += COMPATIBLE_VERSION_SUM;
1629 fname[pos] = 'A' + (sum % 26);
1630 fname[pos + 1] = 'A' + (sum / 26 % 26);
1631 fname[pos + 2] = '\0';
1632 return (char *)fname;
1635 XS(XS_DynaLoader_mod2fname)
1639 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1644 RETVAL = mod2fname(aTHX_ sv);
1645 ST(0) = sv_newmortal();
1646 sv_setpv((SV*)ST(0), RETVAL);
1655 static char buf[300];
1658 int number = SvTRUE(get_sv("OS2::nsyserror", TRUE));
1660 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1664 sprintf(buf, "SYS%04d=%#x: ", rc, rc);
1665 s = buf + strlen(buf);
1668 if (DosGetMessage(NULL, 0, s, sizeof(buf) - 1 - (s-buf),
1669 rc, "OSO001.MSG", &len)) {
1671 sprintf(buf, "SYS%04d=%#x: ", rc, rc);
1672 s = buf + strlen(buf);
1674 sprintf(s, "[No description found in OSO001.MSG]");
1677 if (len && s[len - 1] == '\n')
1679 if (len && s[len - 1] == '\r')
1681 if (len && s[len - 1] == '.')
1683 if (len >= 10 && number && strnEQ(s, buf, 7)
1684 && s[7] == ':' && s[8] == ' ')
1685 /* Some messages start with SYSdddd:, some not */
1686 Move(s + 9, s, (len -= 9) + 1, char);
1698 CroakWinError(int die, char *name)
1701 if (die && Perl_rc) {
1704 Perl_croak(aTHX_ "%s: %s", (name ? name : "Win* API call"), os2error(Perl_rc));
1711 char buf[300], *p, *o = PL_origargv[0], ok = 1;
1713 if (_execname(buf, sizeof buf) != 0)
1720 if (ok && *o != '/' && *o != '\\')
1722 } else if (ok && tolower(*o) != tolower(*p))
1727 if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */
1728 strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */
1742 perllib_mangle(char *s, unsigned int l)
1744 static char *newp, *oldp;
1745 static int newl, oldl, notfound;
1746 static char ret[STATIC_FILE_LENGTH+1];
1748 if (!newp && !notfound) {
1749 newp = getenv("PERLLIB_PREFIX");
1754 while (*newp && !isSPACE(*newp) && *newp != ';') {
1755 newp++; oldl++; /* Skip digits. */
1757 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1758 newp++; /* Skip whitespace. */
1760 newl = strlen(newp);
1761 if (newl == 0 || oldl == 0) {
1762 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1767 if (*s == '\\') *s = '/';
1780 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1783 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1784 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1786 strcpy(ret + newl, s + oldl);
1791 Perl_hab_GET() /* Needed if perl.h cannot be included */
1793 return perl_hab_GET();
1797 Perl_Register_MQ(int serve)
1799 if (Perl_hmq_refcnt <= 0) {
1803 Perl_hmq_refcnt = 0; /* Be extra safe */
1804 DosGetInfoBlocks(&tib, &pib);
1805 Perl_os2_initial_mode = pib->pib_ultype;
1806 /* Try morphing into a PM application. */
1807 if (pib->pib_ultype != 3) /* 2 is VIO */
1808 pib->pib_ultype = 3; /* 3 is PM */
1809 init_PMWIN_entries();
1810 /* 64 messages if before OS/2 3.0, ignored otherwise */
1811 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1816 SAVEINT(cnt); /* Allow catch()ing. */
1818 _exit(188); /* Panic can try to create a window. */
1819 Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
1823 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
1824 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
1825 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
1827 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
1828 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1834 Perl_Serve_Messages(int force)
1839 if (Perl_hmq_servers > 0 && !force)
1841 if (Perl_hmq_refcnt <= 0)
1842 Perl_croak_nocontext("No message queue");
1843 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1845 if (msg.msg == WM_QUIT)
1846 Perl_croak_nocontext("QUITing...");
1847 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1853 Perl_Process_Messages(int force, I32 *cntp)
1857 if (Perl_hmq_servers > 0 && !force)
1859 if (Perl_hmq_refcnt <= 0)
1860 Perl_croak_nocontext("No message queue");
1861 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1864 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1865 if (msg.msg == WM_DESTROY)
1867 if (msg.msg == WM_CREATE)
1870 Perl_croak_nocontext("QUITing...");
1874 Perl_Deregister_MQ(int serve)
1881 if (--Perl_hmq_refcnt <= 0) {
1882 init_PMWIN_entries(); /* To be extra safe */
1883 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1885 /* Try morphing back from a PM application. */
1886 DosGetInfoBlocks(&tib, &pib);
1887 if (pib->pib_ultype == 3) /* 3 is PM */
1888 pib->pib_ultype = Perl_os2_initial_mode;
1890 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
1892 } else if (serve && Perl_hmq_servers <= 0) /* Last server exited */
1893 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1896 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1897 && ((path)[2] == '/' || (path)[2] == '\\'))
1898 #define sys_is_rooted _fnisabs
1899 #define sys_is_relative _fnisrel
1900 #define current_drive _getdrive
1902 #undef chdir /* Was _chdir2. */
1903 #define sys_chdir(p) (chdir(p) == 0)
1904 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1906 static int DOS_harderr_state = -1;
1912 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
1914 int arg1 = SvIV(ST(0));
1915 int arg2 = SvIV(ST(1));
1916 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1917 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1918 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1921 if (CheckOSError(DosError(a)))
1922 Perl_croak_nocontext("DosError(%d) failed", a);
1923 ST(0) = sv_newmortal();
1924 if (DOS_harderr_state >= 0)
1925 sv_setiv(ST(0), DOS_harderr_state);
1926 DOS_harderr_state = RETVAL;
1931 static signed char DOS_suppression_state = -1;
1933 XS(XS_OS2_Errors2Drive)
1937 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
1941 int suppress = SvOK(sv);
1942 char *s = suppress ? SvPV(sv, n_a) : NULL;
1943 char drive = (s ? *s : 0);
1946 if (suppress && !isALPHA(drive))
1947 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1948 if (CheckOSError(DosSuppressPopUps((suppress
1949 ? SPU_ENABLESUPPRESSION
1950 : SPU_DISABLESUPPRESSION),
1952 Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
1953 ST(0) = sv_newmortal();
1954 if (DOS_suppression_state > 0)
1955 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1956 else if (DOS_suppression_state == 0)
1957 sv_setpvn(ST(0), "", 0);
1958 DOS_suppression_state = drive;
1963 static const char * const si_fields[QSV_MAX] = {
1965 "MAX_TEXT_SESSIONS",
1969 "DYN_PRI_VARIATION",
1987 "FOREGROUND_FS_SESSION",
1988 "FOREGROUND_PROCESS"
1995 Perl_croak_nocontext("Usage: OS2::SysInfo()");
1997 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1998 APIRET rc = NO_ERROR; /* Return code */
2001 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
2002 QSV_MAX, /* information */
2005 Perl_croak_nocontext("DosQuerySysInfo() failed");
2006 EXTEND(SP,2*QSV_MAX);
2007 while (i < QSV_MAX) {
2008 ST(j) = sv_newmortal();
2009 sv_setpv(ST(j++), si_fields[i]);
2010 ST(j) = sv_newmortal();
2011 sv_setiv(ST(j++), si[i]);
2015 XSRETURN(2 * QSV_MAX);
2018 XS(XS_OS2_BootDrive)
2022 Perl_croak_nocontext("Usage: OS2::BootDrive()");
2024 ULONG si[1] = {0}; /* System Information Data Buffer */
2025 APIRET rc = NO_ERROR; /* Return code */
2028 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
2029 (PVOID)si, sizeof(si))))
2030 Perl_croak_nocontext("DosQuerySysInfo() failed");
2031 ST(0) = sv_newmortal();
2032 c = 'a' - 1 + si[0];
2033 sv_setpvn(ST(0), &c, 1);
2042 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
2044 bool serve = SvOK(ST(0));
2045 unsigned long pmq = perl_hmq_GET(serve);
2047 ST(0) = sv_newmortal();
2048 sv_setiv(ST(0), pmq);
2053 XS(XS_OS2_UnMorphPM)
2057 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
2059 bool serve = SvOK(ST(0));
2061 perl_hmq_UNSET(serve);
2066 XS(XS_OS2_Serve_Messages)
2070 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
2072 bool force = SvOK(ST(0));
2073 unsigned long cnt = Perl_Serve_Messages(force);
2075 ST(0) = sv_newmortal();
2076 sv_setiv(ST(0), cnt);
2081 XS(XS_OS2_Process_Messages)
2084 if (items < 1 || items > 2)
2085 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
2087 bool force = SvOK(ST(0));
2094 (void)SvIV(sv); /* Force SvIVX */
2096 Perl_croak_nocontext("Can't upgrade count to IV");
2098 cnt = Perl_Process_Messages(force, &cntr);
2101 cnt = Perl_Process_Messages(force, NULL);
2103 ST(0) = sv_newmortal();
2104 sv_setiv(ST(0), cnt);
2109 XS(XS_Cwd_current_drive)
2113 Perl_croak_nocontext("Usage: Cwd::current_drive()");
2117 RETVAL = current_drive();
2118 ST(0) = sv_newmortal();
2119 sv_setpvn(ST(0), (char *)&RETVAL, 1);
2124 XS(XS_Cwd_sys_chdir)
2128 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
2131 char * path = (char *)SvPV(ST(0),n_a);
2134 RETVAL = sys_chdir(path);
2135 ST(0) = boolSV(RETVAL);
2136 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2141 XS(XS_Cwd_change_drive)
2145 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
2148 char d = (char)*SvPV(ST(0),n_a);
2151 RETVAL = change_drive(d);
2152 ST(0) = boolSV(RETVAL);
2153 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2158 XS(XS_Cwd_sys_is_absolute)
2162 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
2165 char * path = (char *)SvPV(ST(0),n_a);
2168 RETVAL = sys_is_absolute(path);
2169 ST(0) = boolSV(RETVAL);
2170 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2175 XS(XS_Cwd_sys_is_rooted)
2179 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
2182 char * path = (char *)SvPV(ST(0),n_a);
2185 RETVAL = sys_is_rooted(path);
2186 ST(0) = boolSV(RETVAL);
2187 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2192 XS(XS_Cwd_sys_is_relative)
2196 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
2199 char * path = (char *)SvPV(ST(0),n_a);
2202 RETVAL = sys_is_relative(path);
2203 ST(0) = boolSV(RETVAL);
2204 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2213 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
2217 RETVAL = _getcwd2(p, MAXPATHLEN);
2218 ST(0) = sv_newmortal();
2219 sv_setpv((SV*)ST(0), RETVAL);
2220 #ifndef INCOMPLETE_TAINTS
2221 SvTAINTED_on(ST(0));
2227 XS(XS_Cwd_sys_abspath)
2230 if (items < 1 || items > 2)
2231 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
2234 char * path = (char *)SvPV(ST(0),n_a);
2235 char * dir, *s, *t, *e;
2244 dir = (char *)SvPV(ST(1),n_a);
2246 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
2250 if (_abspath(p, path, MAXPATHLEN) == 0) {
2256 /* Absolute with drive: */
2257 if ( sys_is_absolute(path) ) {
2258 if (_abspath(p, path, MAXPATHLEN) == 0) {
2263 } else if (path[0] == '/' || path[0] == '\\') {
2264 /* Rooted, but maybe on different drive. */
2265 if (isALPHA(dir[0]) && dir[1] == ':' ) {
2266 char p1[MAXPATHLEN];
2268 /* Need to prepend the drive. */
2271 Copy(path, p1 + 2, strlen(path) + 1, char);
2273 if (_abspath(p, p1, MAXPATHLEN) == 0) {
2278 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2284 /* Either path is relative, or starts with a drive letter. */
2285 /* If the path starts with a drive letter, then dir is
2287 a/b) it is absolute/x:relative on the same drive.
2288 c) path is on current drive, and dir is rooted
2289 In all the cases it is safe to drop the drive part
2291 if ( !sys_is_relative(path) ) {
2292 if ( ( ( sys_is_absolute(dir)
2293 || (isALPHA(dir[0]) && dir[1] == ':'
2294 && strnicmp(dir, path,1) == 0))
2295 && strnicmp(dir, path,1) == 0)
2296 || ( !(isALPHA(dir[0]) && dir[1] == ':')
2297 && toupper(path[0]) == current_drive())) {
2299 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2300 RETVAL = p; goto done;
2302 RETVAL = NULL; goto done;
2306 /* Need to prepend the absolute path of dir. */
2307 char p1[MAXPATHLEN];
2309 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
2312 if (p1[ l - 1 ] != '/') {
2316 Copy(path, p1 + l, strlen(path) + 1, char);
2317 if (_abspath(p, p1, MAXPATHLEN) == 0) {
2331 /* Backslashes are already converted to slashes. */
2332 /* Remove trailing slashes */
2334 while (l > 0 && RETVAL[l-1] == '/')
2336 ST(0) = sv_newmortal();
2337 sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
2338 /* Remove duplicate slashes, skipping the first three, which
2339 may be parts of a server-based path */
2340 s = t = 3 + SvPV_force(sv, n_a);
2342 /* Do not worry about multibyte chars here, this would contradict the
2343 eventual UTFization, and currently most other places break too... */
2345 if (s[0] == t[-1] && s[0] == '/')
2346 s++; /* Skip duplicate / */
2352 SvCUR_set(sv, t - SvPVX(sv));
2357 typedef APIRET (*PELP)(PSZ path, ULONG type);
2359 /* Kernels after 2000/09/15 understand this too: */
2360 #ifndef LIBPATHSTRICT
2361 # define LIBPATHSTRICT 3
2365 ExtLIBPATH(ULONG ord, PSZ path, IV type)
2368 PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */
2373 what = BEGIN_LIBPATH;
2375 what = LIBPATHSTRICT;
2376 return (*(PELP)f)(path, what);
2379 #define extLibpath(to,type) \
2380 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
2382 #define extLibpath_set(p,type) \
2383 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
2385 XS(XS_Cwd_extLibpath)
2388 if (items < 0 || items > 1)
2389 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
2402 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
2403 RETVAL = extLibpath(to, type);
2404 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
2405 Perl_croak_nocontext("panic Cwd::extLibpath parameter");
2406 ST(0) = sv_newmortal();
2407 sv_setpv((SV*)ST(0), RETVAL);
2412 XS(XS_Cwd_extLibpath_set)
2415 if (items < 1 || items > 2)
2416 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2419 char * s = (char *)SvPV(ST(0),n_a);
2430 RETVAL = extLibpath_set(s, type);
2431 ST(0) = boolSV(RETVAL);
2432 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2437 /* Input: Address, BufLen
2439 DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
2440 ULONG * Offset, ULONG Address);
2443 DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
2444 (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
2445 ULONG * Offset, ULONG Address),
2446 (hmod, obj, BufLen, Buf, Offset, Address))
2448 enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full};
2451 module_name_at(void *pp, enum module_name_how how)
2454 char buf[MAXPATHLEN];
2457 ULONG obj, offset, rc;
2459 if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, (ULONG)pp))
2460 return &PL_sv_undef;
2461 if (how == mod_name_handle)
2462 return newSVuv(mod);
2464 if ( how == mod_name_full
2465 && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
2466 return &PL_sv_undef;
2472 return newSVpv(buf, 0);
2476 module_name_of_cv(SV *cv, enum module_name_how how)
2478 if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
2481 Perl_croak(aTHX_ "Not an XSUB reference");
2483 return module_name_at(CvXSUB(SvRV(cv)), how);
2486 /* Find module name to which *this* subroutine is compiled */
2487 #define module_name(how) module_name_at(&module_name_at, how)
2493 Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
2499 how = mod_name_full;
2501 how = (int)SvIV(ST(0));
2504 RETVAL = module_name(how);
2506 RETVAL = module_name_of_cv(ST(1), how);
2513 #define get_control87() _control87(0,0)
2514 #define set_control87 _control87
2516 XS(XS_OS2__control87)
2520 Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
2522 unsigned new = (unsigned)SvIV(ST(0));
2523 unsigned mask = (unsigned)SvIV(ST(1));
2526 RETVAL = _control87(new, mask);
2527 ST(0) = sv_newmortal();
2528 sv_setiv(ST(0), (IV)RETVAL);
2533 XS(XS_OS2_get_control87)
2537 Perl_croak(aTHX_ "Usage: OS2::get_control87()");
2541 RETVAL = get_control87();
2542 ST(0) = sv_newmortal();
2543 sv_setiv(ST(0), (IV)RETVAL);
2549 XS(XS_OS2_set_control87)
2552 if (items < 0 || items > 2)
2553 Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
2562 new = (unsigned)SvIV(ST(0));
2568 mask = (unsigned)SvIV(ST(1));
2571 RETVAL = set_control87(new, mask);
2572 ST(0) = sv_newmortal();
2573 sv_setiv(ST(0), (IV)RETVAL);
2581 char *file = __FILE__;
2585 if (_emx_env & 0x200) { /* OS/2 */
2586 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2587 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2588 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2590 newXS("OS2::Error", XS_OS2_Error, file);
2591 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2592 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2593 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2594 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2595 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2596 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2597 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2598 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2599 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2600 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2601 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2602 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2603 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2604 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2605 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2606 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2607 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
2608 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
2609 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
2610 newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
2611 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2614 sv_setiv(GvSV(gv), 1);
2616 gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
2618 sv_setiv(GvSV(gv), exe_is_aout());
2619 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2621 sv_setiv(GvSV(gv), _emx_rev);
2622 sv_setpv(GvSV(gv), _emx_vprt);
2624 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2626 sv_setiv(GvSV(gv), _emx_env);
2627 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2629 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2630 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
2632 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
2637 OS2_Perl_data_t OS2_Perl_data;
2639 extern void _emx_init(void*);
2641 static void jmp_out_of_atexit(void);
2643 #define FORCE_EMX_INIT_CONTRACT_ARGV 1
2644 #define FORCE_EMX_INIT_INSTALL_ATEXIT 2
2647 my_emx_init(void *layout) {
2648 static volatile void *p = 0; /* Cannot be on stack! */
2650 /* Can't just call emx_init(), since it moves the stack pointer */
2651 /* It also busts a lot of registers, so be extra careful */
2659 "popf\n" : : "r" (layout), "m" (p) );
2662 struct layout_table_t {
2683 static ULONG res; /* Cannot be on stack! */
2685 /* Can't just call __os_version(), since it does not follow C
2686 calling convention: it busts a lot of registers, so be extra careful */
2689 "call ___os_version\n"
2692 "popf\n" : "=m" (res) );
2698 force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
2700 /* Calling emx_init() will bust the top of stack: it installs an
2701 exception handler and puts argv data there. */
2702 char *oldarg, *oldenv;
2703 void *oldstackend, *oldstack;
2706 static ULONG os2_dll;
2707 ULONG rc, error = 0, out;
2709 static struct layout_table_t layout_table;
2711 char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
2713 EXCEPTIONREGISTRATIONRECORD xreg;
2717 layout_table.os2_dll = (ULONG)&os2_dll;
2718 layout_table.flags = 0x02000002; /* flags: application, OMF */
2720 DosGetInfoBlocks(&tib, &pib);
2721 oldarg = pib->pib_pchcmd;
2722 oldenv = pib->pib_pchenv;
2723 oldstack = tib->tib_pstack;
2724 oldstackend = tib->tib_pstacklimit;
2726 /* Minimize the damage to the stack via reducing the size of argv. */
2727 if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
2728 pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */
2729 pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */
2732 newstack = alloca(sizeof(*newstack));
2733 /* Emulate the stack probe */
2734 s = ((char*)newstack) + sizeof(*newstack);
2735 while (s > (char*)newstack) {
2740 /* Reassigning stack is documented to work */
2741 tib->tib_pstack = (void*)newstack;
2742 tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
2744 /* Can't just call emx_init(), since it moves the stack pointer */
2745 my_emx_init((void*)&layout_table);
2747 /* Remove the exception handler, cannot use it - too low on the stack.
2748 Check whether it is inside the new stack. */
2750 if (tib->tib_pexchain >= tib->tib_pstacklimit
2751 || tib->tib_pexchain < tib->tib_pstack) {
2754 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
2755 (unsigned long)tib->tib_pstack,
2756 (unsigned long)tib->tib_pexchain,
2757 (unsigned long)tib->tib_pstacklimit);
2760 if (tib->tib_pexchain != &(newstack->xreg)) {
2761 sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
2762 (unsigned long)tib->tib_pexchain,
2763 (unsigned long)&(newstack->xreg));
2765 rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
2767 sprintf(buf + strlen(buf),
2768 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
2771 /* ExceptionRecords should be on stack, in a correct order. Sigh... */
2772 preg->prev_structure = 0;
2773 preg->ExceptionHandler = _emx_exception;
2774 rc = DosSetExceptionHandler(preg);
2776 sprintf(buf + strlen(buf),
2777 "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
2778 DosWrite(2, buf, strlen(buf), &out);
2779 emx_exception_init = 1; /* Do it around spawn*() calls */
2782 emx_exception_init = 1; /* Do it around spawn*() calls */
2785 /* Restore the damage */
2786 pib->pib_pchcmd = oldarg;
2787 pib->pib_pchcmd = oldenv;
2788 tib->tib_pstacklimit = oldstackend;
2789 tib->tib_pstack = oldstack;
2790 emx_runtime_init = 1;
2792 DosWrite(2, buf, strlen(buf), &out);
2797 jmp_buf at_exit_buf;
2798 int longjmp_at_exit;
2801 jmp_out_of_atexit(void)
2803 if (longjmp_at_exit)
2804 longjmp(at_exit_buf, 1);
2807 extern void _CRT_term(void);
2809 int emx_runtime_secondary;
2812 Perl_OS2_term(void **p, int exitstatus, int flags)
2814 if (!emx_runtime_secondary)
2817 /* The principal executable is not running the same CRTL, so there
2818 is nobody to shutdown *this* CRTL except us... */
2819 if (flags & FORCE_EMX_DEINIT_EXIT) {
2820 if (p && !emx_exception_init)
2821 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
2822 /* Do not run the executable's CRTL's termination routines */
2823 exit(exitstatus); /* Run at-exit, flush buffers, etc */
2825 /* Run at-exit list, and jump out at the end */
2826 if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
2827 longjmp_at_exit = 1;
2828 exit(exitstatus); /* The first pass through "if" */
2831 /* Get here if we managed to jump out of exit(), or did not run atexit. */
2832 longjmp_at_exit = 0; /* Maybe exit() is called again? */
2833 #if 0 /* _atexit_n is not exported */
2834 if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
2835 _atexit_n = 0; /* Remove the atexit() handlers */
2837 /* Will segfault on program termination if we leave this dangling... */
2838 if (p && !emx_exception_init)
2839 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
2840 /* Typically there is no need to do this, done from _DLL_InitTerm() */
2841 if (flags & FORCE_EMX_DEINIT_CRT_TERM)
2842 _CRT_term(); /* Flush buffers, etc. */
2843 /* Now it is a good time to call exit() in the caller's CRTL... */
2846 #include <emx/startup.h>
2848 extern ULONG __os_version(); /* See system.doc */
2850 static int emx_wasnt_initialized;
2853 check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
2857 /* If _environ is not set, this code sits in a DLL which
2858 uses a CRT DLL which not compatible with the executable's
2859 CRT library. Some parts of the DLL are not initialized.
2861 if (_environ != NULL)
2862 return; /* Properly initialized */
2864 /* If the executable does not use EMX.DLL, EMX.DLL is not completely
2865 initialized either. Uninitialized EMX.DLL returns 0 in the low
2866 nibble of __os_version(). */
2867 v_emx = my_os_version();
2869 /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
2870 (=>_CRT_init=>_entry2) via a call to __os_version(), then
2871 reset when the EXE initialization code calls _text=>_init=>_entry2.
2872 The first time they are wrongly set to 0; the second time the
2873 EXE initialization code had already called emx_init=>initialize1
2874 which correctly set version_major, version_minor used by
2876 v_crt = (_osmajor | _osminor);
2878 if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */
2879 force_init_emx_runtime( preg,
2880 FORCE_EMX_INIT_CONTRACT_ARGV
2881 | FORCE_EMX_INIT_INSTALL_ATEXIT );
2882 emx_wasnt_initialized = 1;
2883 /* Update CRTL data basing on now-valid EMX runtime data */
2884 if (!v_crt) { /* The only wrong data are the versions. */
2885 v_emx = my_os_version(); /* *Now* it works */
2886 *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
2887 *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
2890 emx_runtime_secondary = 1;
2891 /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
2892 atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */
2894 if (env == NULL) { /* Fetch from the process info block */
2900 DosGetInfoBlocks(&tib, &pib);
2901 e = pib->pib_pchenv;
2902 while (*e) { /* Get count */
2904 e = e + strlen(e) + 1;
2906 New(1307, env, c + 1, char*);
2908 e = pib->pib_pchenv;
2911 e = e + strlen(e) + 1;
2915 _environ = _org_environ = env;
2918 #define ENTRY_POINT 0x10000
2923 struct layout_table_t *layout;
2924 if (emx_wasnt_initialized)
2926 /* Now we know that the principal executable is an EMX application
2927 - unless somebody did already play with delayed initialization... */
2928 /* With EMX applications to determine whether it is AOUT one needs
2929 to examine the start of the executable to find "layout" */
2930 if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */
2931 || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */
2932 || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */
2933 || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */
2934 return 0; /* ! EMX executable */
2936 Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
2937 return !(layout->flags & 2);
2941 Perl_OS2_init(char **env)
2943 Perl_OS2_init3(env, 0, 0);
2947 Perl_OS2_init3(char **env, void **preg, int flags)
2951 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2954 check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
2957 OS2_Perl_data.xs_init = &Xs_OS2_init;
2958 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2959 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2960 strcpy(PL_sh_path, SH_PATH);
2961 PL_sh_path[0] = shell[0];
2962 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2963 int l = strlen(shell), i;
2964 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2967 New(1304, PL_sh_path, l + 8, char);
2968 strncpy(PL_sh_path, shell, l);
2969 strcpy(PL_sh_path + l, "/sh.exe");
2970 for (i = 0; i < l; i++) {
2971 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2974 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2975 MUTEX_INIT(&start_thread_mutex);
2977 os2_mytype = my_type(); /* Do it before morphing. Needed? */
2978 /* Some DLLs reset FP flags on load. We may have been linked with them */
2979 _control87(MCW_EM, MCW_EM);
2986 my_tmpnam (char *str)
2988 char *p = getenv("TMP"), *tpath;
2990 if (!p) p = getenv("TEMP");
2991 tpath = tempnam(p, "pltmp");
3005 if (s.st_mode & S_IWOTH) {
3008 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
3014 /* EMX flavors do not tolerate trailing slashes. t/op/mkdir.t has many
3015 trailing slashes, so we need to support this as well. */
3018 my_rmdir (__const__ char *s)
3022 STRLEN l = strlen(s);
3025 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
3027 New(1305, buf, l + 1, char);
3029 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
3043 my_mkdir (__const__ char *s, long perm)
3047 STRLEN l = strlen(s);
3050 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
3052 New(1305, buf, l + 1, char);
3054 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
3059 rc = mkdir(s, perm);
3067 /* This code was contributed by Rocco Caputo. */
3069 my_flock(int handle, int o)
3071 FILELOCK rNull, rFull;
3072 ULONG timeout, handle_type, flag_word;
3074 int blocking, shared;
3075 static int use_my = -1;
3078 char *s = getenv("USE_PERL_FLOCK");
3084 if (!(_emx_env & 0x200) || !use_my)
3085 return flock(handle, o); /* Delegate to EMX. */
3087 /* is this a file? */
3088 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
3089 (handle_type & 0xFF))
3094 /* set lock/unlock ranges */
3095 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
3096 rFull.lRange = 0x7FFFFFFF;
3097 /* set timeout for blocking */
3098 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
3099 /* shared or exclusive? */
3100 shared = (o & LOCK_SH) ? 1 : 0;
3101 /* do not block the unlock */
3102 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
3103 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
3108 case ERROR_INVALID_HANDLE:
3111 case ERROR_SHARING_BUFFER_EXCEEDED:
3114 case ERROR_LOCK_VIOLATION:
3115 break; /* not an error */
3116 case ERROR_INVALID_PARAMETER:
3117 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
3118 case ERROR_READ_LOCKS_NOT_SUPPORTED:
3121 case ERROR_INTERRUPT:
3129 /* lock may block */
3130 if (o & (LOCK_SH | LOCK_EX)) {
3131 /* for blocking operations */
3145 case ERROR_INVALID_HANDLE:
3148 case ERROR_SHARING_BUFFER_EXCEEDED:
3151 case ERROR_LOCK_VIOLATION:
3153 errno = EWOULDBLOCK;
3157 case ERROR_INVALID_PARAMETER:
3158 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
3159 case ERROR_READ_LOCKS_NOT_SUPPORTED:
3162 case ERROR_INTERRUPT:
3169 /* give away timeslice */
3178 static int pwent_cnt;
3179 static int _my_pwent = -1;
3184 if (_my_pwent == -1) {
3185 char *s = getenv("USE_PERL_PWENT");
3187 _my_pwent = atoi(s);
3201 if (!use_my_pwent()) {
3202 setpwent(); /* Delegate to EMX. */
3211 if (!use_my_pwent()) {
3212 endpwent(); /* Delegate to EMX. */
3220 if (!use_my_pwent())
3221 return getpwent(); /* Delegate to EMX. */
3223 return 0; /* Return one entry only */
3227 static int grent_cnt;
3244 return 0; /* Return one entry only */
3251 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
3252 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
3254 static struct passwd *
3255 passw_wrap(struct passwd *p)
3257 static struct passwd pw;
3260 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
3263 s = getenv("PW_PASSWD");
3265 s = (char*)pw_p; /* Make match impossible */
3272 my_getpwuid (uid_t id)
3274 return passw_wrap(getpwuid(id));
3278 my_getpwnam (__const__ char *n)
3280 return passw_wrap(getpwnam(n));
3284 gcvt_os2 (double value, int digits, char *buffer)
3286 return gcvt (value, digits, buffer);
3290 int fork_with_resources()
3292 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
3294 void *ctx = PERL_GET_CONTEXT;
3299 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
3300 if (rc == 0) { /* child */
3301 ALLOC_THREAD_KEY; /* Acquire the thread-local memory */
3302 PERL_SET_CONTEXT(ctx); /* Reinit the thread-local memory */