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
13 #include <sys/uflags.h>
16 * Various Unix compatibility functions for OS/2
27 #define PERLIO_NOT_STDIO 0
32 #ifdef USE_5005THREADS
34 typedef void (*emx_startroutine)(void *);
35 typedef void* (*pthreads_startroutine)(void *);
44 const char *pthreads_states[] = {
55 enum pthreads_state state;
58 thread_join_t *thread_join_data;
59 int thread_join_count;
60 perl_mutex start_thread_mutex;
63 pthread_join(perl_os_thread tid, void **status)
65 MUTEX_LOCK(&start_thread_mutex);
66 switch (thread_join_data[tid].state) {
67 case pthreads_st_exited:
68 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
69 MUTEX_UNLOCK(&start_thread_mutex);
70 *status = thread_join_data[tid].status;
72 case pthreads_st_waited:
73 MUTEX_UNLOCK(&start_thread_mutex);
74 Perl_croak_nocontext("join with a thread with a waiter");
77 thread_join_data[tid].state = pthreads_st_waited;
78 COND_INIT(&thread_join_data[tid].cond);
79 MUTEX_UNLOCK(&start_thread_mutex);
80 COND_WAIT(&thread_join_data[tid].cond, NULL);
81 COND_DESTROY(&thread_join_data[tid].cond);
82 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
83 *status = thread_join_data[tid].status;
86 MUTEX_UNLOCK(&start_thread_mutex);
87 Perl_croak_nocontext("join: unknown thread state: '%s'",
88 pthreads_states[thread_join_data[tid].state]);
95 pthread_startit(void *arg)
97 /* Thread is already started, we need to transfer control only */
98 pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
99 int tid = pthread_self();
102 arg = ((void**)arg)[1];
103 if (tid >= thread_join_count) {
104 int oc = thread_join_count;
106 thread_join_count = tid + 5 + tid/5;
107 if (thread_join_data) {
108 Renew(thread_join_data, thread_join_count, thread_join_t);
109 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
111 Newz(1323, thread_join_data, thread_join_count, thread_join_t);
114 if (thread_join_data[tid].state != pthreads_st_none)
115 Perl_croak_nocontext("attempt to reuse thread id %i", tid);
116 thread_join_data[tid].state = pthreads_st_run;
117 /* Now that we copied/updated the guys, we may release the caller... */
118 MUTEX_UNLOCK(&start_thread_mutex);
119 thread_join_data[tid].status = (*start_routine)(arg);
120 switch (thread_join_data[tid].state) {
121 case pthreads_st_waited:
122 COND_SIGNAL(&thread_join_data[tid].cond);
125 thread_join_data[tid].state = pthreads_st_exited;
131 pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
132 void *(*start_routine)(void*), void *arg)
136 args[0] = (void*)start_routine;
139 MUTEX_LOCK(&start_thread_mutex);
140 *tid = _beginthread(pthread_startit, /*stack*/ NULL,
141 /*stacksize*/ 10*1024*1024, (void*)args);
142 MUTEX_LOCK(&start_thread_mutex);
143 MUTEX_UNLOCK(&start_thread_mutex);
144 return *tid ? 0 : EINVAL;
148 pthread_detach(perl_os_thread tid)
150 MUTEX_LOCK(&start_thread_mutex);
151 switch (thread_join_data[tid].state) {
152 case pthreads_st_waited:
153 MUTEX_UNLOCK(&start_thread_mutex);
154 Perl_croak_nocontext("detach on a thread with a waiter");
156 case pthreads_st_run:
157 thread_join_data[tid].state = pthreads_st_detached;
158 MUTEX_UNLOCK(&start_thread_mutex);
161 MUTEX_UNLOCK(&start_thread_mutex);
162 Perl_croak_nocontext("detach: unknown thread state: '%s'",
163 pthreads_states[thread_join_data[tid].state]);
169 /* This is a very bastardized version: */
171 os2_cond_wait(perl_cond *c, perl_mutex *m)
175 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
176 Perl_croak_nocontext("panic: COND_WAIT-reset: rc=%i", rc);
177 if (m) MUTEX_UNLOCK(m);
178 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
179 && (rc != ERROR_INTERRUPT))
180 Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc);
181 if (rc == ERROR_INTERRUPT)
183 if (m) MUTEX_LOCK(m);
187 static int exe_is_aout(void);
189 /*****************************************************************************/
190 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
191 #define C_ARR_LEN(sym) (sizeof(sym)/sizeof(*sym))
197 static struct dll_handle doscalls_handle = {"doscalls", 0};
198 static struct dll_handle tcp_handle = {"tcp32dll", 0};
199 static struct dll_handle pmwin_handle = {"pmwin", 0};
200 static struct dll_handle rexx_handle = {"rexx", 0};
201 static struct dll_handle rexxapi_handle = {"rexxapi", 0};
202 static struct dll_handle sesmgr_handle = {"sesmgr", 0};
203 static struct dll_handle pmshapi_handle = {"pmshapi", 0};
205 /* This should match enum entries_ordinals defined in os2ish.h. */
206 static const struct {
207 struct dll_handle *dll;
208 const char *entryname;
210 } loadOrdinals[ORD_NENTRIES] = {
211 {&doscalls_handle, NULL, 874}, /* DosQueryExtLibpath */
212 {&doscalls_handle, NULL, 873}, /* DosSetExtLibpath */
213 {&doscalls_handle, NULL, 460}, /* DosVerifyPidTid */
214 {&tcp_handle, "SETHOSTENT", 0},
215 {&tcp_handle, "SETNETENT" , 0},
216 {&tcp_handle, "SETPROTOENT", 0},
217 {&tcp_handle, "SETSERVENT", 0},
218 {&tcp_handle, "GETHOSTENT", 0},
219 {&tcp_handle, "GETNETENT" , 0},
220 {&tcp_handle, "GETPROTOENT", 0},
221 {&tcp_handle, "GETSERVENT", 0},
222 {&tcp_handle, "ENDHOSTENT", 0},
223 {&tcp_handle, "ENDNETENT", 0},
224 {&tcp_handle, "ENDPROTOENT", 0},
225 {&tcp_handle, "ENDSERVENT", 0},
226 {&pmwin_handle, NULL, 763}, /* WinInitialize */
227 {&pmwin_handle, NULL, 716}, /* WinCreateMsgQueue */
228 {&pmwin_handle, NULL, 726}, /* WinDestroyMsgQueue */
229 {&pmwin_handle, NULL, 918}, /* WinPeekMsg */
230 {&pmwin_handle, NULL, 915}, /* WinGetMsg */
231 {&pmwin_handle, NULL, 912}, /* WinDispatchMsg */
232 {&pmwin_handle, NULL, 753}, /* WinGetLastError */
233 {&pmwin_handle, NULL, 705}, /* WinCancelShutdown */
234 /* These are needed in extensions.
235 How to protect PMSHAPI: it comes through EMX functions? */
236 {&rexx_handle, "RexxStart", 0},
237 {&rexx_handle, "RexxVariablePool", 0},
238 {&rexxapi_handle, "RexxRegisterFunctionExe", 0},
239 {&rexxapi_handle, "RexxDeregisterFunction", 0},
240 {&sesmgr_handle, "DOSSMSETTITLE", 0}, /* Would not work runtime-loaded */
241 {&pmshapi_handle, "PRF32QUERYPROFILESIZE", 0},
242 {&pmshapi_handle, "PRF32OPENPROFILE", 0},
243 {&pmshapi_handle, "PRF32CLOSEPROFILE", 0},
244 {&pmshapi_handle, "PRF32QUERYPROFILE", 0},
245 {&pmshapi_handle, "PRF32RESET", 0},
246 {&pmshapi_handle, "PRF32QUERYPROFILEDATA", 0},
247 {&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0},
249 /* At least some of these do not work by name, since they need
250 WIN32 instead of WIN... */
252 These were generated with
253 nm I:\emx\lib\os2.a | fgrep -f API-list | grep = > API-list-entries
254 perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( ORD_$1,)" API-list-entries > API-list-ORD_
255 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
257 {&pmshapi_handle, NULL, 123}, /* WinChangeSwitchEntry */
258 {&pmshapi_handle, NULL, 124}, /* WinQuerySwitchEntry */
259 {&pmshapi_handle, NULL, 125}, /* WinQuerySwitchHandle */
260 {&pmshapi_handle, NULL, 126}, /* WinQuerySwitchList */
261 {&pmshapi_handle, NULL, 131}, /* WinSwitchToProgram */
262 {&pmwin_handle, NULL, 702}, /* WinBeginEnumWindows */
263 {&pmwin_handle, NULL, 737}, /* WinEndEnumWindows */
264 {&pmwin_handle, NULL, 740}, /* WinEnumDlgItem */
265 {&pmwin_handle, NULL, 756}, /* WinGetNextWindow */
266 {&pmwin_handle, NULL, 768}, /* WinIsChild */
267 {&pmwin_handle, NULL, 799}, /* WinQueryActiveWindow */
268 {&pmwin_handle, NULL, 805}, /* WinQueryClassName */
269 {&pmwin_handle, NULL, 817}, /* WinQueryFocus */
270 {&pmwin_handle, NULL, 834}, /* WinQueryWindow */
271 {&pmwin_handle, NULL, 837}, /* WinQueryWindowPos */
272 {&pmwin_handle, NULL, 838}, /* WinQueryWindowProcess */
273 {&pmwin_handle, NULL, 841}, /* WinQueryWindowText */
274 {&pmwin_handle, NULL, 842}, /* WinQueryWindowTextLength */
275 {&pmwin_handle, NULL, 860}, /* WinSetFocus */
276 {&pmwin_handle, NULL, 875}, /* WinSetWindowPos */
277 {&pmwin_handle, NULL, 877}, /* WinSetWindowText */
278 {&pmwin_handle, NULL, 883}, /* WinShowWindow */
279 {&pmwin_handle, NULL, 772}, /* WinIsWindow */
280 {&pmwin_handle, NULL, 899}, /* WinWindowFromId */
281 {&pmwin_handle, NULL, 900}, /* WinWindowFromPoint */
282 {&pmwin_handle, NULL, 919}, /* WinPostMsg */
283 {&pmwin_handle, NULL, 735}, /* WinEnableWindow */
284 {&pmwin_handle, NULL, 736}, /* WinEnableWindowUpdate */
285 {&pmwin_handle, NULL, 773}, /* WinIsWindowEnabled */
286 {&pmwin_handle, NULL, 774}, /* WinIsWindowShowing */
287 {&pmwin_handle, NULL, 775}, /* WinIsWindowVisible */
288 {&pmwin_handle, NULL, 839}, /* WinQueryWindowPtr */
289 {&pmwin_handle, NULL, 843}, /* WinQueryWindowULong */
290 {&pmwin_handle, NULL, 844}, /* WinQueryWindowUShort */
291 {&pmwin_handle, NULL, 874}, /* WinSetWindowBits */
292 {&pmwin_handle, NULL, 876}, /* WinSetWindowPtr */
293 {&pmwin_handle, NULL, 878}, /* WinSetWindowULong */
294 {&pmwin_handle, NULL, 879}, /* WinSetWindowUShort */
295 {&pmwin_handle, NULL, 813}, /* WinQueryDesktopWindow */
296 {&pmwin_handle, NULL, 851}, /* WinSetActiveWindow */
297 {&doscalls_handle, NULL, 360}, /* DosQueryModFromEIP */
300 static PFN ExtFCN[C_ARR_LEN(loadOrdinals)]; /* Labeled by ord ORD_*. */
301 const Perl_PFN * const pExtFCN = ExtFCN;
302 struct PMWIN_entries_t PMWIN_entries;
305 loadModule(const char *modname, int fail)
307 HMODULE h = (HMODULE)dlopen(modname, 0);
310 Perl_croak_nocontext("Error loading module '%s': %s",
316 loadByOrdinal(enum entries_ordinals ord, int fail)
318 if (ExtFCN[ord] == NULL) {
322 if (!loadOrdinals[ord].dll->handle)
323 loadOrdinals[ord].dll->handle
324 = loadModule(loadOrdinals[ord].dll->modname, fail);
325 if (!loadOrdinals[ord].dll->handle)
326 return 0; /* Possible with FAIL==0 only */
327 if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle,
328 loadOrdinals[ord].entrypoint,
329 loadOrdinals[ord].entryname,&fcn))) {
330 char buf[20], *s = (char*)loadOrdinals[ord].entryname;
335 sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint);
336 Perl_croak_nocontext(
337 "This version of OS/2 does not support %s.%s",
338 loadOrdinals[ord].dll->modname, s);
342 if ((long)ExtFCN[ord] == -1)
343 Perl_croak_nocontext("panic queryaddr");
348 init_PMWIN_entries(void)
352 for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++)
353 ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1);
356 /*****************************************************/
357 /* socket forwarders without linking with tcpip DLLs */
359 DeclFuncByORD(struct hostent *, gethostent, ORD_GETHOSTENT, (void), ())
360 DeclFuncByORD(struct netent *, getnetent, ORD_GETNETENT, (void), ())
361 DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ())
362 DeclFuncByORD(struct servent *, getservent, ORD_GETSERVENT, (void), ())
364 DeclVoidFuncByORD(sethostent, ORD_SETHOSTENT, (int x), (x))
365 DeclVoidFuncByORD(setnetent, ORD_SETNETENT, (int x), (x))
366 DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x))
367 DeclVoidFuncByORD(setservent, ORD_SETSERVENT, (int x), (x))
369 DeclVoidFuncByORD(endhostent, ORD_ENDHOSTENT, (void), ())
370 DeclVoidFuncByORD(endnetent, ORD_ENDNETENT, (void), ())
371 DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ())
372 DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ())
375 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
377 #define QSS_INI_BUFFER 1024
379 ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
380 static int pidtid_lookup;
383 get_sysinfo(ULONG pid, ULONG flags)
386 ULONG rc, buf_len = QSS_INI_BUFFER;
389 if (!pidtid_lookup) {
391 *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0);
393 if (pDosVerifyPidTid) { /* Warp3 or later */
394 /* Up to some fixpak QuerySysState() kills the system if a non-existent
396 if (CheckOSError(pDosVerifyPidTid(pid, 1)))
399 New(1322, pbuffer, buf_len, char);
400 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
401 rc = QuerySysState(flags, pid, pbuffer, buf_len);
402 while (rc == ERROR_BUFFER_OVERFLOW) {
403 Renew(pbuffer, buf_len *= 2, char);
404 rc = QuerySysState(flags, pid, pbuffer, buf_len);
411 psi = (PQTOPLEVEL)pbuffer;
412 if (psi && pid && pid != psi->procdata->pid) {
414 Perl_croak_nocontext("panic: wrong pid in sysinfo");
419 #define PRIO_ERR 0x1111
429 psi = get_sysinfo(pid, QSS_PROCESS);
432 prio = psi->procdata->threads->priority;
438 setpriority(int which, int pid, int val)
440 ULONG rc, prio = sys_prio(pid);
442 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
443 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
444 /* Do not change class. */
445 return CheckOSError(DosSetPriority((pid < 0)
446 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
448 (32 - val) % 32 - (prio & 0xFF),
451 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
452 /* Documentation claims one can change both class and basevalue,
453 * but I find it wrong. */
454 /* Change class, but since delta == 0 denotes absolute 0, correct. */
455 if (CheckOSError(DosSetPriority((pid < 0)
456 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
457 priors[(32 - val) >> 5] + 1,
461 if ( ((32 - val) % 32) == 0 ) return 0;
462 return CheckOSError(DosSetPriority((pid < 0)
463 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
472 getpriority(int which /* ignored */, int pid)
476 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
478 if (ret == PRIO_ERR) {
481 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
484 /*****************************************************************************/
487 int emx_runtime_init; /* If 1, we need to manually init it */
488 int emx_exception_init; /* If 1, we need to manually set it */
490 /* There is no big sense to make it thread-specific, since signals
491 are delivered to thread 1 only. XXXX Maybe make it into an array? */
492 static int spawn_pid;
493 static int spawn_killed;
496 spawn_sighandler(int sig)
498 /* Some programs do not arrange for the keyboard signals to be
499 delivered to them. We need to deliver the signal manually. */
500 /* We may get a signal only if
501 a) kid does not receive keyboard signal: deliver it;
502 b) kid already died, and we get a signal. We may only hope
503 that the pid number was not reused.
507 sig = SIGKILL; /* Try harder. */
508 kill(spawn_pid, sig);
513 result(pTHX_ int flag, int pid)
516 Signal_t (*ihand)(); /* place to save signal during system() */
517 Signal_t (*qhand)(); /* place to save signal during system() */
523 if (pid < 0 || flag != 0)
529 ihand = rsignal(SIGINT, &spawn_sighandler);
530 qhand = rsignal(SIGQUIT, &spawn_sighandler);
532 r = wait4pid(pid, &status, 0);
533 } while (r == -1 && errno == EINTR);
534 rsignal(SIGINT, ihand);
535 rsignal(SIGQUIT, qhand);
537 PL_statusvalue = (U16)status;
540 return status & 0xFFFF;
542 ihand = rsignal(SIGINT, SIG_IGN);
543 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
544 rsignal(SIGINT, ihand);
545 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
548 return PL_statusvalue;
561 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
570 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
571 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
574 return (pib->pib_ultype);
578 file_type(char *path)
583 if (!(_emx_env & 0x200))
584 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
585 if (CheckOSError(DosQueryAppType(path, &apptype))) {
587 case ERROR_FILE_NOT_FOUND:
588 case ERROR_PATH_NOT_FOUND:
590 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
592 default: /* Found, but not an
593 executable, or some other
601 static ULONG os2_mytype;
603 /* Spawn/exec a program, revert to shell if needed. */
604 /* global PL_Argv[] contains arguments. */
606 extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
607 EXCEPTIONREGISTRATIONRECORD *,
612 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
618 static char * fargs[4]
619 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
620 char **argsp = fargs;
623 int new_stderr = -1, nostderr = 0;
633 if (strEQ(PL_Argv[0],"/bin/sh"))
634 PL_Argv[0] = PL_sh_path;
636 /* We should check PERL_SH* and PERLLIB_* as well? */
637 if (!really || !*(tmps = SvPV(really, n_a)))
639 if (tmps[0] != '/' && tmps[0] != '\\'
640 && !(tmps[0] && tmps[1] == ':'
641 && (tmps[2] == '/' || tmps[2] != '\\'))
642 ) /* will spawnvp use PATH? */
643 TAINT_ENV(); /* testing IFS here is overkill, probably */
647 if (_emx_env & 0x200) { /* OS/2. */
648 int type = file_type(tmps);
650 if (type == -1) { /* Not found */
655 else if (type == -2) { /* Not an EXE */
660 else if (type == -3) { /* Is a directory? */
661 /* Special-case this */
663 int l = strlen(tmps);
665 if (l + 5 <= sizeof tbuf) {
667 strcpy(tbuf + l, ".exe");
668 type = file_type(tbuf);
678 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
679 case FAPPTYP_WINDOWAPI:
681 if (os2_mytype != 3) { /* not PM */
682 if (flag == P_NOWAIT)
684 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
685 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d",
690 case FAPPTYP_NOTWINDOWCOMPAT:
692 if (os2_mytype != 0) { /* not full screen */
693 if (flag == P_NOWAIT)
695 else if ((flag & 7) != P_SESSION)
696 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d",
701 case FAPPTYP_NOTSPEC:
702 /* Let the shell handle this... */
704 buf = ""; /* Pacify a warning */
705 file = 0; /* Pacify a warning */
713 new_stderr = dup(2); /* Preserve stderr */
714 if (new_stderr == -1) {
722 fl_stderr = fcntl(2, F_GETFD);
726 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
730 rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv));
732 if (execf == EXECF_TRUEEXEC)
733 rc = execvp(tmps,PL_Argv);
734 else if (execf == EXECF_EXEC)
735 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
736 else if (execf == EXECF_SPAWN_NOWAIT)
737 rc = spawnvp(flag,tmps,PL_Argv);
738 else if (execf == EXECF_SYNC)
739 rc = spawnvp(trueflag,tmps,PL_Argv);
740 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
741 rc = result(aTHX_ trueflag,
742 spawnvp(flag,tmps,PL_Argv));
744 if (rc < 0 && pass == 1
745 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
750 if (err == ENOENT || err == ENOEXEC) {
751 /* No such file, or is a script. */
752 /* Try adding script extensions to the file name, and
754 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
758 SV *scrsv = sv_2mortal(newSVpv(scr, 0));
759 SV *bufsv = sv_newmortal();
762 scr = SvPV(scrsv, n_a); /* free()ed later */
764 file = PerlIO_open(scr, "r");
769 buf = sv_gets(bufsv, file, 0 /* No append */);
771 buf = ""; /* XXX Needed? */
772 if (!buf[0]) { /* Empty... */
774 /* Special case: maybe from -Zexe build, so
775 there is an executable around (contrary to
776 documentation, DosQueryAppType sometimes (?)
777 does not append ".exe", so we could have
778 reached this place). */
779 sv_catpv(scrsv, ".exe");
780 scr = SvPV(scrsv, n_a); /* Reload */
781 if (PerlLIO_stat(scr,&PL_statbuf) >= 0
782 && !S_ISDIR(PL_statbuf.st_mode)) { /* Found */
786 } else { /* Restore */
787 SvCUR_set(scrsv, SvCUR(scrsv) - 4);
791 if (PerlIO_close(file) != 0) { /* Failure */
793 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
794 scr, Strerror(errno));
795 buf = ""; /* Not #! */
801 } else if (buf[0] == 'e') {
802 if (strnEQ(buf, "extproc", 7)
805 } else if (buf[0] == 'E') {
806 if (strnEQ(buf, "EXTPROC", 7)
811 buf = ""; /* Not #! */
819 /* Do better than pdksh: allow a few args,
820 strip trailing whitespace. */
830 while (*s && !isSPACE(*s))
837 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"",
842 /* Can jump from far, buf/file invalid if force_shell: */
849 || (!buf[0] && file)) { /* File without magic */
850 /* In fact we tried all what pdksh would
851 try. There is no point in calling
852 pdksh, we may just emulate its logic. */
853 char *shell = getenv("EXECSHELL");
854 char *shell_opt = NULL;
860 shell = getenv("OS2_SHELL");
861 if (inicmd) { /* No spaces at start! */
863 while (*s && !isSPACE(*s)) {
865 inicmd = NULL; /* Cannot use */
873 /* Dosish shells will choke on slashes
874 in paths, fortunately, this is
875 important for zeroth arg only. */
882 /* If EXECSHELL is set, we do not set */
885 shell = ((_emx_env & 0x200)
888 nargs = shell_opt ? 2 : 1; /* shell file args */
889 exec_args[0] = shell;
890 exec_args[1] = shell_opt;
892 if (nargs == 2 && inicmd) {
893 /* Use the original cmd line */
894 /* XXXX This is good only until we refuse
895 quoted arguments... */
899 } else if (!buf[0] && inicmd) { /* No file */
900 /* Start with the original cmdline. */
901 /* XXXX This is good only until we refuse
902 quoted arguments... */
906 nargs = 2; /* shell -c */
909 while (a[1]) /* Get to the end */
911 a++; /* Copy finil NULL too */
912 while (a >= PL_Argv) {
913 *(a + nargs) = *a; /* PL_Argv was preallocated to be
918 PL_Argv[nargs] = argsp[nargs];
919 /* Enable pathless exec if #! (as pdksh). */
920 pass = (buf[0] == '#' ? 2 : 3);
924 /* Not found: restore errno */
928 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
929 char *no_dir = strrchr(PL_Argv[0], '/');
931 /* Do as pdksh port does: if not found with /, try without
934 PL_Argv[0] = no_dir + 1;
939 if (rc < 0 && ckWARN(WARN_EXEC))
940 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n",
941 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
943 PL_Argv[0], Strerror(errno));
944 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
945 && ((trueflag & 0xFF) == P_WAIT))
949 if (new_stderr != -1) { /* How can we use error codes? */
952 fcntl(2, F_SETFD, fl_stderr);
958 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
960 do_spawn3(pTHX_ char *cmd, int execf, int flag)
964 char *shell, *copt, *news = NULL;
965 int rc, seenspace = 0, mergestderr = 0;
968 if ((shell = getenv("EMXSHELL")) != NULL)
970 else if ((shell = getenv("SHELL")) != NULL)
972 else if ((shell = getenv("COMSPEC")) != NULL)
977 /* Consensus on perl5-porters is that it is _very_ important to
978 have a shell which will not change between computers with the
979 same architecture, to avoid "action on a distance".
980 And to have simple build, this shell should be sh. */
985 while (*cmd && isSPACE(*cmd))
988 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
989 STRLEN l = strlen(PL_sh_path);
991 New(1302, news, strlen(cmd) - 7 + l + 1, char);
992 strcpy(news, PL_sh_path);
993 strcpy(news + l, cmd + 7);
997 /* save an extra exec if possible */
998 /* see if there are shell metacharacters in it */
1000 if (*cmd == '.' && isSPACE(cmd[1]))
1003 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1006 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
1010 for (s = cmd; *s; s++) {
1011 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
1012 if (*s == '\n' && s[1] == '\0') {
1015 } else if (*s == '\\' && !seenspace) {
1016 continue; /* Allow backslashes in names */
1017 } else if (*s == '>' && s >= cmd + 3
1018 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
1019 && isSPACE(s[-2]) ) {
1022 while (*t && isSPACE(*t))
1027 break; /* Allow 2>&1 as the last thing */
1030 /* We do not convert this to do_spawn_ve since shell
1031 should be smart enough to start itself gloriously. */
1033 if (execf == EXECF_TRUEEXEC)
1034 rc = execl(shell,shell,copt,cmd,(char*)0);
1035 else if (execf == EXECF_EXEC)
1036 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
1037 else if (execf == EXECF_SPAWN_NOWAIT)
1038 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
1039 else if (execf == EXECF_SPAWN_BYFLAG)
1040 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
1042 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
1043 if (execf == EXECF_SYNC)
1044 rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0);
1046 rc = result(aTHX_ P_WAIT,
1047 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
1048 if (rc < 0 && ckWARN(WARN_EXEC))
1049 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
1050 (execf == EXECF_SPAWN ? "spawn" : "exec"),
1051 shell, Strerror(errno));
1058 } else if (*s == ' ' || *s == '\t') {
1063 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
1064 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
1065 PL_Cmd = savepvn(cmd, s-cmd);
1067 for (s = PL_Cmd; *s;) {
1068 while (*s && isSPACE(*s)) s++;
1071 while (*s && !isSPACE(*s)) s++;
1077 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
1088 os2_do_aspawn(pTHX_ SV *really, register void **vmark, register void **vsp)
1090 register SV **mark = (SV **)vmark;
1091 register SV **sp = (SV **)vsp;
1094 int flag = P_WAIT, flag_set = 0;
1098 New(1301,PL_Argv, sp - mark + 3, char*);
1101 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
1103 flag = SvIVx(*mark);
1108 while (++mark <= sp) {
1110 *a++ = SvPVx(*mark, n_a);
1116 if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
1117 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
1119 rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0);
1127 os2_do_spawn(pTHX_ char *cmd)
1129 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
1133 do_spawn_nowait(pTHX_ char *cmd)
1135 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1139 Perl_do_exec(pTHX_ char *cmd)
1141 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1146 os2exec(pTHX_ char *cmd)
1148 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1152 my_syspopen(pTHX_ char *cmd, char *mode)
1156 register I32 this, that, newfd;
1159 int fh_fl = 0; /* Pacify the warning */
1161 /* `this' is what we use in the parent, `that' in the child. */
1162 this = (*mode == 'w');
1166 taint_proper("Insecure %s%s", "EXEC");
1170 /* Now we need to spawn the child. */
1171 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1172 int new = dup(p[this]);
1179 newfd = dup(*mode == 'r'); /* Preserve std* */
1181 /* This cannot happen due to fh being bad after pipe(), since
1182 pipe() should have created fh 0 and 1 even if they were
1183 initially closed. But we closed p[this] before. */
1184 if (errno != EBADF) {
1191 fh_fl = fcntl(*mode == 'r', F_GETFD);
1192 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1193 dup2(p[that], *mode == 'r');
1196 /* Where is `this' and newfd now? */
1197 fcntl(p[this], F_SETFD, FD_CLOEXEC);
1199 fcntl(newfd, F_SETFD, FD_CLOEXEC);
1200 pid = do_spawn_nowait(aTHX_ cmd);
1202 close(*mode == 'r'); /* It was closed initially */
1203 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1204 dup2(newfd, *mode == 'r'); /* Return std* back. */
1206 fcntl(*mode == 'r', F_SETFD, fh_fl);
1208 fcntl(*mode == 'r', F_SETFD, fh_fl);
1209 if (p[that] == (*mode == 'r'))
1215 if (p[that] < p[this]) { /* Make fh as small as possible */
1216 dup2(p[this], p[that]);
1220 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1221 (void)SvUPGRADE(sv,SVt_IV);
1223 PL_forkprocess = pid;
1224 return PerlIO_fdopen(p[this], mode);
1226 #else /* USE_POPEN */
1232 res = popen(cmd, mode);
1234 char *shell = getenv("EMXSHELL");
1236 my_setenv("EMXSHELL", PL_sh_path);
1237 res = popen(cmd, mode);
1238 my_setenv("EMXSHELL", shell);
1240 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1241 (void)SvUPGRADE(sv,SVt_IV);
1242 SvIVX(sv) = -1; /* A cooky. */
1245 #endif /* USE_POPEN */
1249 /******************************************************************/
1255 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1261 /*******************************************************************/
1262 /* not implemented in EMX 0.9d */
1264 char * ctermid(char *s) { return 0; }
1266 #ifdef MYTTYNAME /* was not in emx0.9a */
1267 void * ttyname(x) { return 0; }
1270 /*****************************************************************************/
1271 /* not implemented in C Set++ */
1274 int setuid(x) { errno = EINVAL; return -1; }
1275 int setgid(x) { errno = EINVAL; return -1; }
1278 /*****************************************************************************/
1279 /* stat() hack for char/block device */
1283 /* First attempt used DosQueryFSAttach which crashed the system when
1284 used with 5.001. Now just look for /dev/. */
1287 os2_stat(const char *name, struct stat *st)
1289 static int ino = SHRT_MAX;
1291 if (stricmp(name, "/dev/con") != 0
1292 && stricmp(name, "/dev/tty") != 0)
1293 return stat(name, st);
1295 memset(st, 0, sizeof *st);
1296 st->st_mode = S_IFCHR|0666;
1297 st->st_ino = (ino-- & 0x7FFF);
1304 #ifdef USE_PERL_SBRK
1306 /* SBRK() emulation, mostly moved to malloc.c. */
1309 sys_alloc(int size) {
1311 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1313 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1316 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1320 #endif /* USE_PERL_SBRK */
1324 char *tmppath = TMPPATH1;
1329 char *p = getenv("TMP"), *tpath;
1332 if (!p) p = getenv("TEMP");
1335 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1339 strcpy(tpath + len + 1, TMPPATH1);
1346 XS(XS_File__Copy_syscopy)
1349 if (items < 2 || items > 3)
1350 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1353 char * src = (char *)SvPV(ST(0),n_a);
1354 char * dst = (char *)SvPV(ST(1),n_a);
1361 flag = (unsigned long)SvIV(ST(2));
1364 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1365 ST(0) = sv_newmortal();
1366 sv_setiv(ST(0), (IV)RETVAL);
1371 #define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */
1372 #include "patchlevel.h"
1373 #undef PERL_PATCHLEVEL_H_IMPLICIT
1376 mod2fname(pTHX_ SV *sv)
1378 static char fname[9];
1379 int pos = 6, len, avlen;
1380 unsigned int sum = 0;
1384 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1386 if (SvTYPE(sv) != SVt_PVAV)
1387 Perl_croak_nocontext("Not array reference given to mod2fname");
1389 avlen = av_len((AV*)sv);
1391 Perl_croak_nocontext("Empty array reference given to mod2fname");
1393 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1394 strncpy(fname, s, 8);
1396 if (len < 6) pos = len;
1398 sum = 33 * sum + *(s++); /* Checksumming first chars to
1399 * get the capitalization into c.s. */
1402 while (avlen >= 0) {
1403 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1405 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1409 #ifdef USE_5005THREADS
1410 sum++; /* Avoid conflict of DLLs in memory. */
1412 /* We always load modules as *specific* DLLs, and with the full name.
1413 When loading a specific DLL by its full name, one cannot get a
1414 different DLL, even if a DLL with the same basename is loaded already.
1415 Thus there is no need to include the version into the mangling scheme. */
1417 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
1419 # ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
1420 # define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
1422 sum += COMPATIBLE_VERSION_SUM;
1424 fname[pos] = 'A' + (sum % 26);
1425 fname[pos + 1] = 'A' + (sum / 26 % 26);
1426 fname[pos + 2] = '\0';
1427 return (char *)fname;
1430 XS(XS_DynaLoader_mod2fname)
1434 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1439 RETVAL = mod2fname(aTHX_ sv);
1440 ST(0) = sv_newmortal();
1441 sv_setpv((SV*)ST(0), RETVAL);
1449 static char buf[300];
1452 int number = SvTRUE(get_sv("OS2::nsyserror", TRUE));
1454 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1458 sprintf(buf, "SYS%04d=%#x: ", rc, rc);
1459 s = buf + strlen(buf);
1462 if (DosGetMessage(NULL, 0, s, sizeof(buf) - 1 - (s-buf),
1463 rc, "OSO001.MSG", &len)) {
1465 sprintf(buf, "SYS%04d=%#x: ", rc, rc);
1466 s = buf + strlen(buf);
1468 sprintf(s, "[No description found in OSO001.MSG]");
1471 if (len && s[len - 1] == '\n')
1473 if (len && s[len - 1] == '\r')
1475 if (len && s[len - 1] == '.')
1477 if (len >= 10 && number && strnEQ(s, buf, 7)
1478 && s[7] == ':' && s[8] == ' ')
1479 /* Some messages start with SYSdddd:, some not */
1480 Move(s + 9, s, (len -= 9) + 1, char);
1492 CroakWinError(int die, char *name)
1496 croak("%s: %s", (name ? name : "Win* API call"), os2error(Perl_rc));
1502 char buf[300], *p, *o = PL_origargv[0], ok = 1;
1504 if (_execname(buf, sizeof buf) != 0)
1511 if (ok && *o != '/' && *o != '\\')
1513 } else if (ok && tolower(*o) != tolower(*p))
1518 if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */
1519 strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */
1533 perllib_mangle(char *s, unsigned int l)
1535 static char *newp, *oldp;
1536 static int newl, oldl, notfound;
1537 static char ret[STATIC_FILE_LENGTH+1];
1539 if (!newp && !notfound) {
1540 newp = getenv("PERLLIB_PREFIX");
1545 while (*newp && !isSPACE(*newp) && *newp != ';') {
1546 newp++; oldl++; /* Skip digits. */
1548 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1549 newp++; /* Skip whitespace. */
1551 newl = strlen(newp);
1552 if (newl == 0 || oldl == 0) {
1553 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1558 if (*s == '\\') *s = '/';
1571 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1574 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1575 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1577 strcpy(ret + newl, s + oldl);
1582 Perl_hab_GET() /* Needed if perl.h cannot be included */
1584 return perl_hab_GET();
1588 Perl_Register_MQ(int serve)
1593 if (Perl_hmq_refcnt > 0)
1595 Perl_hmq_refcnt = 0; /* Be extra safe */
1596 DosGetInfoBlocks(&tib, &pib);
1597 Perl_os2_initial_mode = pib->pib_ultype;
1598 /* Try morphing into a PM application. */
1599 if (pib->pib_ultype != 3) /* 2 is VIO */
1600 pib->pib_ultype = 3; /* 3 is PM */
1601 init_PMWIN_entries();
1602 /* 64 messages if before OS/2 3.0, ignored otherwise */
1603 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1607 SAVEINT(cnt); /* Allow catch()ing. */
1609 _exit(188); /* Panic can try to create a window. */
1610 Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
1613 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
1614 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
1615 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
1617 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
1618 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1624 Perl_Serve_Messages(int force)
1629 if (Perl_hmq_servers > 0 && !force)
1631 if (Perl_hmq_refcnt <= 0)
1632 Perl_croak_nocontext("No message queue");
1633 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1635 if (msg.msg == WM_QUIT)
1636 Perl_croak_nocontext("QUITing...");
1637 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1643 Perl_Process_Messages(int force, I32 *cntp)
1647 if (Perl_hmq_servers > 0 && !force)
1649 if (Perl_hmq_refcnt <= 0)
1650 Perl_croak_nocontext("No message queue");
1651 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1654 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1655 if (msg.msg == WM_DESTROY)
1657 if (msg.msg == WM_CREATE)
1660 Perl_croak_nocontext("QUITing...");
1664 Perl_Deregister_MQ(int serve)
1671 if (--Perl_hmq_refcnt <= 0) {
1672 init_PMWIN_entries(); /* To be extra safe */
1673 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1675 /* Try morphing back from a PM application. */
1676 DosGetInfoBlocks(&tib, &pib);
1677 if (pib->pib_ultype == 3) /* 3 is PM */
1678 pib->pib_ultype = Perl_os2_initial_mode;
1680 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
1682 } else if (serve && Perl_hmq_servers <= 0) /* Last server exited */
1683 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1686 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1687 && ((path)[2] == '/' || (path)[2] == '\\'))
1688 #define sys_is_rooted _fnisabs
1689 #define sys_is_relative _fnisrel
1690 #define current_drive _getdrive
1692 #undef chdir /* Was _chdir2. */
1693 #define sys_chdir(p) (chdir(p) == 0)
1694 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1696 static int DOS_harderr_state = -1;
1702 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
1704 int arg1 = SvIV(ST(0));
1705 int arg2 = SvIV(ST(1));
1706 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1707 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1708 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1711 if (CheckOSError(DosError(a)))
1712 Perl_croak_nocontext("DosError(%d) failed", a);
1713 ST(0) = sv_newmortal();
1714 if (DOS_harderr_state >= 0)
1715 sv_setiv(ST(0), DOS_harderr_state);
1716 DOS_harderr_state = RETVAL;
1721 static signed char DOS_suppression_state = -1;
1723 XS(XS_OS2_Errors2Drive)
1727 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
1731 int suppress = SvOK(sv);
1732 char *s = suppress ? SvPV(sv, n_a) : NULL;
1733 char drive = (s ? *s : 0);
1736 if (suppress && !isALPHA(drive))
1737 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1738 if (CheckOSError(DosSuppressPopUps((suppress
1739 ? SPU_ENABLESUPPRESSION
1740 : SPU_DISABLESUPPRESSION),
1742 Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
1743 ST(0) = sv_newmortal();
1744 if (DOS_suppression_state > 0)
1745 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1746 else if (DOS_suppression_state == 0)
1747 sv_setpvn(ST(0), "", 0);
1748 DOS_suppression_state = drive;
1753 static const char * const si_fields[QSV_MAX] = {
1755 "MAX_TEXT_SESSIONS",
1759 "DYN_PRI_VARIATION",
1777 "FOREGROUND_FS_SESSION",
1778 "FOREGROUND_PROCESS"
1785 Perl_croak_nocontext("Usage: OS2::SysInfo()");
1787 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1788 APIRET rc = NO_ERROR; /* Return code */
1791 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1792 QSV_MAX, /* information */
1795 Perl_croak_nocontext("DosQuerySysInfo() failed");
1796 EXTEND(SP,2*QSV_MAX);
1797 while (i < QSV_MAX) {
1798 ST(j) = sv_newmortal();
1799 sv_setpv(ST(j++), si_fields[i]);
1800 ST(j) = sv_newmortal();
1801 sv_setiv(ST(j++), si[i]);
1805 XSRETURN(2 * QSV_MAX);
1808 XS(XS_OS2_BootDrive)
1812 Perl_croak_nocontext("Usage: OS2::BootDrive()");
1814 ULONG si[1] = {0}; /* System Information Data Buffer */
1815 APIRET rc = NO_ERROR; /* Return code */
1818 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1819 (PVOID)si, sizeof(si))))
1820 Perl_croak_nocontext("DosQuerySysInfo() failed");
1821 ST(0) = sv_newmortal();
1822 c = 'a' - 1 + si[0];
1823 sv_setpvn(ST(0), &c, 1);
1832 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
1834 bool serve = SvOK(ST(0));
1835 unsigned long pmq = perl_hmq_GET(serve);
1837 ST(0) = sv_newmortal();
1838 sv_setiv(ST(0), pmq);
1843 XS(XS_OS2_UnMorphPM)
1847 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
1849 bool serve = SvOK(ST(0));
1851 perl_hmq_UNSET(serve);
1856 XS(XS_OS2_Serve_Messages)
1860 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
1862 bool force = SvOK(ST(0));
1863 unsigned long cnt = Perl_Serve_Messages(force);
1865 ST(0) = sv_newmortal();
1866 sv_setiv(ST(0), cnt);
1871 XS(XS_OS2_Process_Messages)
1874 if (items < 1 || items > 2)
1875 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
1877 bool force = SvOK(ST(0));
1884 (void)SvIV(sv); /* Force SvIVX */
1886 Perl_croak_nocontext("Can't upgrade count to IV");
1888 cnt = Perl_Process_Messages(force, &cntr);
1891 cnt = Perl_Process_Messages(force, NULL);
1893 ST(0) = sv_newmortal();
1894 sv_setiv(ST(0), cnt);
1899 XS(XS_Cwd_current_drive)
1903 Perl_croak_nocontext("Usage: Cwd::current_drive()");
1907 RETVAL = current_drive();
1908 ST(0) = sv_newmortal();
1909 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1914 XS(XS_Cwd_sys_chdir)
1918 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
1921 char * path = (char *)SvPV(ST(0),n_a);
1924 RETVAL = sys_chdir(path);
1925 ST(0) = boolSV(RETVAL);
1926 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1931 XS(XS_Cwd_change_drive)
1935 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
1938 char d = (char)*SvPV(ST(0),n_a);
1941 RETVAL = change_drive(d);
1942 ST(0) = boolSV(RETVAL);
1943 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1948 XS(XS_Cwd_sys_is_absolute)
1952 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
1955 char * path = (char *)SvPV(ST(0),n_a);
1958 RETVAL = sys_is_absolute(path);
1959 ST(0) = boolSV(RETVAL);
1960 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1965 XS(XS_Cwd_sys_is_rooted)
1969 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
1972 char * path = (char *)SvPV(ST(0),n_a);
1975 RETVAL = sys_is_rooted(path);
1976 ST(0) = boolSV(RETVAL);
1977 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1982 XS(XS_Cwd_sys_is_relative)
1986 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
1989 char * path = (char *)SvPV(ST(0),n_a);
1992 RETVAL = sys_is_relative(path);
1993 ST(0) = boolSV(RETVAL);
1994 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2003 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
2007 RETVAL = _getcwd2(p, MAXPATHLEN);
2008 ST(0) = sv_newmortal();
2009 sv_setpv((SV*)ST(0), RETVAL);
2010 #ifndef INCOMPLETE_TAINTS
2011 SvTAINTED_on(ST(0));
2017 XS(XS_Cwd_sys_abspath)
2020 if (items < 1 || items > 2)
2021 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
2024 char * path = (char *)SvPV(ST(0),n_a);
2025 char * dir, *s, *t, *e;
2034 dir = (char *)SvPV(ST(1),n_a);
2036 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
2040 if (_abspath(p, path, MAXPATHLEN) == 0) {
2046 /* Absolute with drive: */
2047 if ( sys_is_absolute(path) ) {
2048 if (_abspath(p, path, MAXPATHLEN) == 0) {
2053 } else if (path[0] == '/' || path[0] == '\\') {
2054 /* Rooted, but maybe on different drive. */
2055 if (isALPHA(dir[0]) && dir[1] == ':' ) {
2056 char p1[MAXPATHLEN];
2058 /* Need to prepend the drive. */
2061 Copy(path, p1 + 2, strlen(path) + 1, char);
2063 if (_abspath(p, p1, MAXPATHLEN) == 0) {
2068 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2074 /* Either path is relative, or starts with a drive letter. */
2075 /* If the path starts with a drive letter, then dir is
2077 a/b) it is absolute/x:relative on the same drive.
2078 c) path is on current drive, and dir is rooted
2079 In all the cases it is safe to drop the drive part
2081 if ( !sys_is_relative(path) ) {
2082 if ( ( ( sys_is_absolute(dir)
2083 || (isALPHA(dir[0]) && dir[1] == ':'
2084 && strnicmp(dir, path,1) == 0))
2085 && strnicmp(dir, path,1) == 0)
2086 || ( !(isALPHA(dir[0]) && dir[1] == ':')
2087 && toupper(path[0]) == current_drive())) {
2089 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2090 RETVAL = p; goto done;
2092 RETVAL = NULL; goto done;
2096 /* Need to prepend the absolute path of dir. */
2097 char p1[MAXPATHLEN];
2099 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
2102 if (p1[ l - 1 ] != '/') {
2106 Copy(path, p1 + l, strlen(path) + 1, char);
2107 if (_abspath(p, p1, MAXPATHLEN) == 0) {
2121 /* Backslashes are already converted to slashes. */
2122 /* Remove trailing slashes */
2124 while (l > 0 && RETVAL[l-1] == '/')
2126 ST(0) = sv_newmortal();
2127 sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
2128 /* Remove duplicate slashes, skipping the first three, which
2129 may be parts of a server-based path */
2130 s = t = 3 + SvPV_force(sv, n_a);
2132 /* Do not worry about multibyte chars here, this would contradict the
2133 eventual UTFization, and currently most other places break too... */
2135 if (s[0] == t[-1] && s[0] == '/')
2136 s++; /* Skip duplicate / */
2142 SvCUR_set(sv, t - SvPVX(sv));
2147 typedef APIRET (*PELP)(PSZ path, ULONG type);
2149 /* Kernels after 2000/09/15 understand this too: */
2150 #ifndef LIBPATHSTRICT
2151 # define LIBPATHSTRICT 3
2155 ExtLIBPATH(ULONG ord, PSZ path, IV type)
2158 PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */
2163 what = BEGIN_LIBPATH;
2165 what = LIBPATHSTRICT;
2166 return (*(PELP)f)(path, what);
2169 #define extLibpath(to,type) \
2170 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
2172 #define extLibpath_set(p,type) \
2173 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
2175 XS(XS_Cwd_extLibpath)
2178 if (items < 0 || items > 1)
2179 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
2192 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
2193 RETVAL = extLibpath(to, type);
2194 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
2195 Perl_croak_nocontext("panic Cwd::extLibpath parameter");
2196 ST(0) = sv_newmortal();
2197 sv_setpv((SV*)ST(0), RETVAL);
2202 XS(XS_Cwd_extLibpath_set)
2205 if (items < 1 || items > 2)
2206 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2209 char * s = (char *)SvPV(ST(0),n_a);
2220 RETVAL = extLibpath_set(s, type);
2221 ST(0) = boolSV(RETVAL);
2222 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2227 /* Input: Address, BufLen
2229 DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
2230 ULONG * Offset, ULONG Address);
2233 DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
2234 (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
2235 ULONG * Offset, ULONG Address),
2236 (hmod, obj, BufLen, Buf, Offset, Address))
2238 enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full};
2241 module_name_at(void *pp, enum module_name_how how)
2243 char buf[MAXPATHLEN];
2246 ULONG obj, offset, rc;
2248 if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, (ULONG)pp))
2249 return &PL_sv_undef;
2250 if (how == mod_name_handle)
2251 return newSVuv(mod);
2253 if ( how == mod_name_full
2254 && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
2255 return &PL_sv_undef;
2261 return newSVpv(buf, 0);
2265 module_name_of_cv(SV *cv, enum module_name_how how)
2267 if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv)))
2268 croak("Not an XSUB reference");
2269 return module_name_at(CvXSUB(SvRV(cv)), how);
2272 /* Find module name to which *this* subroutine is compiled */
2273 #define module_name(how) module_name_at(&module_name_at, how)
2279 Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
2285 how = mod_name_full;
2287 how = (int)SvIV(ST(0));
2290 RETVAL = module_name(how);
2292 RETVAL = module_name_of_cv(ST(1), how);
2299 #define get_control87() _control87(0,0)
2300 #define set_control87 _control87
2302 XS(XS_OS2__control87)
2306 croak("Usage: OS2::_control87(new,mask)");
2308 unsigned new = (unsigned)SvIV(ST(0));
2309 unsigned mask = (unsigned)SvIV(ST(1));
2312 RETVAL = _control87(new, mask);
2313 ST(0) = sv_newmortal();
2314 sv_setiv(ST(0), (IV)RETVAL);
2319 XS(XS_OS2_get_control87)
2323 croak("Usage: OS2::get_control87()");
2327 RETVAL = get_control87();
2328 ST(0) = sv_newmortal();
2329 sv_setiv(ST(0), (IV)RETVAL);
2335 XS(XS_OS2_set_control87)
2338 if (items < 0 || items > 2)
2339 croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
2348 new = (unsigned)SvIV(ST(0));
2354 mask = (unsigned)SvIV(ST(1));
2357 RETVAL = set_control87(new, mask);
2358 ST(0) = sv_newmortal();
2359 sv_setiv(ST(0), (IV)RETVAL);
2367 char *file = __FILE__;
2371 if (_emx_env & 0x200) { /* OS/2 */
2372 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2373 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2374 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2376 newXS("OS2::Error", XS_OS2_Error, file);
2377 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2378 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2379 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2380 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2381 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2382 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2383 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2384 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2385 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2386 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2387 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2388 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2389 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2390 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2391 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2392 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2393 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
2394 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
2395 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
2396 newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
2397 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2400 sv_setiv(GvSV(gv), 1);
2402 gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
2404 sv_setiv(GvSV(gv), exe_is_aout());
2405 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2407 sv_setiv(GvSV(gv), _emx_rev);
2408 sv_setpv(GvSV(gv), _emx_vprt);
2410 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2412 sv_setiv(GvSV(gv), _emx_env);
2413 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2415 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2416 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
2418 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
2423 OS2_Perl_data_t OS2_Perl_data;
2425 extern void _emx_init(void*);
2427 static void jmp_out_of_atexit(void);
2429 #define FORCE_EMX_INIT_CONTRACT_ARGV 1
2430 #define FORCE_EMX_INIT_INSTALL_ATEXIT 2
2433 my_emx_init(void *layout) {
2434 static volatile void *p = 0; /* Cannot be on stack! */
2436 /* Can't just call emx_init(), since it moves the stack pointer */
2437 /* It also busts a lot of registers, so be extra careful */
2445 "popf\n" : : "r" (layout), "m" (p) );
2448 struct layout_table_t {
2469 static ULONG res; /* Cannot be on stack! */
2471 /* Can't just call __os_version(), since it does not follow C
2472 calling convention: it busts a lot of registers, so be extra careful */
2475 "call ___os_version\n"
2478 "popf\n" : "=m" (res) );
2484 force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
2486 /* Calling emx_init() will bust the top of stack: it installs an
2487 exception handler and puts argv data there. */
2488 char *oldarg, *oldenv;
2489 void *oldstackend, *oldstack;
2492 static ULONG os2_dll;
2493 ULONG rc, error = 0, out;
2495 static struct layout_table_t layout_table;
2497 char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
2499 EXCEPTIONREGISTRATIONRECORD xreg;
2503 layout_table.os2_dll = (ULONG)&os2_dll;
2504 layout_table.flags = 0x02000002; /* flags: application, OMF */
2506 DosGetInfoBlocks(&tib, &pib);
2507 oldarg = pib->pib_pchcmd;
2508 oldenv = pib->pib_pchenv;
2509 oldstack = tib->tib_pstack;
2510 oldstackend = tib->tib_pstacklimit;
2512 /* Minimize the damage to the stack via reducing the size of argv. */
2513 if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
2514 pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */
2515 pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */
2518 newstack = alloca(sizeof(*newstack));
2519 /* Emulate the stack probe */
2520 s = ((char*)newstack) + sizeof(*newstack);
2521 while (s > (char*)newstack) {
2526 /* Reassigning stack is documented to work */
2527 tib->tib_pstack = (void*)newstack;
2528 tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
2530 /* Can't just call emx_init(), since it moves the stack pointer */
2531 my_emx_init((void*)&layout_table);
2533 /* Remove the exception handler, cannot use it - too low on the stack.
2534 Check whether it is inside the new stack. */
2536 if (tib->tib_pexchain >= tib->tib_pstacklimit
2537 || tib->tib_pexchain < tib->tib_pstack) {
2540 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
2541 (unsigned long)tib->tib_pstack,
2542 (unsigned long)tib->tib_pexchain,
2543 (unsigned long)tib->tib_pstacklimit);
2546 if (tib->tib_pexchain != &(newstack->xreg)) {
2547 sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
2548 (unsigned long)tib->tib_pexchain,
2549 (unsigned long)&(newstack->xreg));
2551 rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
2553 sprintf(buf + strlen(buf),
2554 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
2557 /* ExceptionRecords should be on stack, in a correct order. Sigh... */
2558 preg->prev_structure = 0;
2559 preg->ExceptionHandler = _emx_exception;
2560 rc = DosSetExceptionHandler(preg);
2562 sprintf(buf + strlen(buf),
2563 "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
2564 DosWrite(2, buf, strlen(buf), &out);
2565 emx_exception_init = 1; /* Do it around spawn*() calls */
2568 emx_exception_init = 1; /* Do it around spawn*() calls */
2571 /* Restore the damage */
2572 pib->pib_pchcmd = oldarg;
2573 pib->pib_pchcmd = oldenv;
2574 tib->tib_pstacklimit = oldstackend;
2575 tib->tib_pstack = oldstack;
2576 emx_runtime_init = 1;
2578 DosWrite(2, buf, strlen(buf), &out);
2583 jmp_buf at_exit_buf;
2584 int longjmp_at_exit;
2587 jmp_out_of_atexit(void)
2589 if (longjmp_at_exit)
2590 longjmp(at_exit_buf, 1);
2593 extern void _CRT_term(void);
2595 int emx_runtime_secondary;
2598 Perl_OS2_term(void **p, int exitstatus, int flags)
2600 if (!emx_runtime_secondary)
2603 /* The principal executable is not running the same CRTL, so there
2604 is nobody to shutdown *this* CRTL except us... */
2605 if (flags & FORCE_EMX_DEINIT_EXIT) {
2606 if (p && !emx_exception_init)
2607 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
2608 /* Do not run the executable's CRTL's termination routines */
2609 exit(exitstatus); /* Run at-exit, flush buffers, etc */
2611 /* Run at-exit list, and jump out at the end */
2612 if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
2613 longjmp_at_exit = 1;
2614 exit(exitstatus); /* The first pass through "if" */
2617 /* Get here if we managed to jump out of exit(), or did not run atexit. */
2618 longjmp_at_exit = 0; /* Maybe exit() is called again? */
2619 #if 0 /* _atexit_n is not exported */
2620 if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
2621 _atexit_n = 0; /* Remove the atexit() handlers */
2623 /* Will segfault on program termination if we leave this dangling... */
2624 if (p && !emx_exception_init)
2625 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
2626 /* Typically there is no need to do this, done from _DLL_InitTerm() */
2627 if (flags & FORCE_EMX_DEINIT_CRT_TERM)
2628 _CRT_term(); /* Flush buffers, etc. */
2629 /* Now it is a good time to call exit() in the caller's CRTL... */
2632 #include <emx/startup.h>
2634 extern ULONG __os_version(); /* See system.doc */
2636 static int emx_wasnt_initialized;
2639 check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
2643 /* If _environ is not set, this code sits in a DLL which
2644 uses a CRT DLL which not compatible with the executable's
2645 CRT library. Some parts of the DLL are not initialized.
2647 if (_environ != NULL)
2648 return; /* Properly initialized */
2650 /* If the executable does not use EMX.DLL, EMX.DLL is not completely
2651 initialized either. Uninitialized EMX.DLL returns 0 in the low
2652 nibble of __os_version(). */
2653 v_emx = my_os_version();
2655 /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
2656 (=>_CRT_init=>_entry2) via a call to __os_version(), then
2657 reset when the EXE initialization code calls _text=>_init=>_entry2.
2658 The first time they are wrongly set to 0; the second time the
2659 EXE initialization code had already called emx_init=>initialize1
2660 which correctly set version_major, version_minor used by
2662 v_crt = (_osmajor | _osminor);
2664 if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */
2665 force_init_emx_runtime( preg,
2666 FORCE_EMX_INIT_CONTRACT_ARGV
2667 | FORCE_EMX_INIT_INSTALL_ATEXIT );
2668 emx_wasnt_initialized = 1;
2669 /* Update CRTL data basing on now-valid EMX runtime data */
2670 if (!v_crt) { /* The only wrong data are the versions. */
2671 v_emx = my_os_version(); /* *Now* it works */
2672 *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
2673 *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
2676 emx_runtime_secondary = 1;
2677 /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
2678 atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */
2680 if (env == NULL) { /* Fetch from the process info block */
2686 DosGetInfoBlocks(&tib, &pib);
2687 e = pib->pib_pchenv;
2688 while (*e) { /* Get count */
2690 e = e + strlen(e) + 1;
2692 New(1307, env, c + 1, char*);
2694 e = pib->pib_pchenv;
2697 e = e + strlen(e) + 1;
2701 _environ = _org_environ = env;
2704 #define ENTRY_POINT 0x10000
2709 struct layout_table_t *layout;
2710 if (emx_wasnt_initialized)
2712 /* Now we know that the principal executable is an EMX application
2713 - unless somebody did already play with delayed initialization... */
2714 /* With EMX applications to determine whether it is AOUT one needs
2715 to examine the start of the executable to find "layout" */
2716 if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */
2717 || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */
2718 || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */
2719 || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */
2720 return 0; /* ! EMX executable */
2722 Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
2723 return !(layout->flags & 2);
2727 Perl_OS2_init(char **env)
2729 Perl_OS2_init3(env, 0, 0);
2733 Perl_OS2_init3(char **env, void **preg, int flags)
2737 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2740 check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
2743 OS2_Perl_data.xs_init = &Xs_OS2_init;
2744 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2745 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2746 strcpy(PL_sh_path, SH_PATH);
2747 PL_sh_path[0] = shell[0];
2748 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2749 int l = strlen(shell), i;
2750 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2753 New(1304, PL_sh_path, l + 8, char);
2754 strncpy(PL_sh_path, shell, l);
2755 strcpy(PL_sh_path + l, "/sh.exe");
2756 for (i = 0; i < l; i++) {
2757 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2760 MUTEX_INIT(&start_thread_mutex);
2761 os2_mytype = my_type(); /* Do it before morphing. Needed? */
2762 /* Some DLLs reset FP flags on load. We may have been linked with them */
2763 _control87(MCW_EM, MCW_EM);
2770 my_tmpnam (char *str)
2772 char *p = getenv("TMP"), *tpath;
2774 if (!p) p = getenv("TEMP");
2775 tpath = tempnam(p, "pltmp");
2789 if (s.st_mode & S_IWOTH) {
2792 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2799 my_rmdir (__const__ char *s)
2801 char buf[MAXPATHLEN];
2802 STRLEN l = strlen(s);
2804 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX rmdir fails... */
2815 my_mkdir (__const__ char *s, long perm)
2817 char buf[MAXPATHLEN];
2818 STRLEN l = strlen(s);
2820 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
2825 return mkdir(s, perm);
2830 /* This code was contributed by Rocco Caputo. */
2832 my_flock(int handle, int o)
2834 FILELOCK rNull, rFull;
2835 ULONG timeout, handle_type, flag_word;
2837 int blocking, shared;
2838 static int use_my = -1;
2841 char *s = getenv("USE_PERL_FLOCK");
2847 if (!(_emx_env & 0x200) || !use_my)
2848 return flock(handle, o); /* Delegate to EMX. */
2850 /* is this a file? */
2851 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2852 (handle_type & 0xFF))
2857 /* set lock/unlock ranges */
2858 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2859 rFull.lRange = 0x7FFFFFFF;
2860 /* set timeout for blocking */
2861 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2862 /* shared or exclusive? */
2863 shared = (o & LOCK_SH) ? 1 : 0;
2864 /* do not block the unlock */
2865 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2866 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2871 case ERROR_INVALID_HANDLE:
2874 case ERROR_SHARING_BUFFER_EXCEEDED:
2877 case ERROR_LOCK_VIOLATION:
2878 break; /* not an error */
2879 case ERROR_INVALID_PARAMETER:
2880 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2881 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2884 case ERROR_INTERRUPT:
2892 /* lock may block */
2893 if (o & (LOCK_SH | LOCK_EX)) {
2894 /* for blocking operations */
2908 case ERROR_INVALID_HANDLE:
2911 case ERROR_SHARING_BUFFER_EXCEEDED:
2914 case ERROR_LOCK_VIOLATION:
2916 errno = EWOULDBLOCK;
2920 case ERROR_INVALID_PARAMETER:
2921 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2922 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2925 case ERROR_INTERRUPT:
2932 /* give away timeslice */
2941 static int pwent_cnt;
2942 static int _my_pwent = -1;
2947 if (_my_pwent == -1) {
2948 char *s = getenv("USE_PERL_PWENT");
2950 _my_pwent = atoi(s);
2964 if (!use_my_pwent()) {
2965 setpwent(); /* Delegate to EMX. */
2974 if (!use_my_pwent()) {
2975 endpwent(); /* Delegate to EMX. */
2983 if (!use_my_pwent())
2984 return getpwent(); /* Delegate to EMX. */
2986 return 0; /* Return one entry only */
2990 static int grent_cnt;
3007 return 0; /* Return one entry only */
3014 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
3015 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
3017 static struct passwd *
3018 passw_wrap(struct passwd *p)
3020 static struct passwd pw;
3023 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
3026 s = getenv("PW_PASSWD");
3028 s = (char*)pw_p; /* Make match impossible */
3035 my_getpwuid (uid_t id)
3037 return passw_wrap(getpwuid(id));
3041 my_getpwnam (__const__ char *n)
3043 return passw_wrap(getpwnam(n));
3047 gcvt_os2 (double value, int digits, char *buffer)
3049 return gcvt (value, digits, buffer);