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, 872}, /* WinIsWindow */
280 {&pmwin_handle, NULL, 899}, /* WinWindowFromId */
281 {&pmwin_handle, NULL, 900}, /* WinWindowFromPoint */
282 {&pmwin_handle, NULL, 919}, /* WinPostMsg */
285 static PFN ExtFCN[C_ARR_LEN(loadOrdinals)]; /* Labeled by ord ORD_*. */
286 const Perl_PFN * const pExtFCN = ExtFCN;
287 struct PMWIN_entries_t PMWIN_entries;
290 loadModule(const char *modname, int fail)
292 HMODULE h = (HMODULE)dlopen(modname, 0);
295 Perl_croak_nocontext("Error loading module '%s': %s",
301 loadByOrdinal(enum entries_ordinals ord, int fail)
303 if (ExtFCN[ord] == NULL) {
307 if (!loadOrdinals[ord].dll->handle)
308 loadOrdinals[ord].dll->handle
309 = loadModule(loadOrdinals[ord].dll->modname, fail);
310 if (!loadOrdinals[ord].dll->handle)
311 return 0; /* Possible with FAIL==0 only */
312 if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle,
313 loadOrdinals[ord].entrypoint,
314 loadOrdinals[ord].entryname,&fcn))) {
315 char buf[20], *s = (char*)loadOrdinals[ord].entryname;
320 sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint);
321 Perl_croak_nocontext(
322 "This version of OS/2 does not support %s.%s",
323 loadOrdinals[ord].dll->modname, s);
327 if ((long)ExtFCN[ord] == -1)
328 Perl_croak_nocontext("panic queryaddr");
333 init_PMWIN_entries(void)
337 for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++)
338 ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1);
341 /*****************************************************/
342 /* socket forwarders without linking with tcpip DLLs */
344 DeclFuncByORD(struct hostent *, gethostent, ORD_GETHOSTENT, (void), ())
345 DeclFuncByORD(struct netent *, getnetent, ORD_GETNETENT, (void), ())
346 DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ())
347 DeclFuncByORD(struct servent *, getservent, ORD_GETSERVENT, (void), ())
349 DeclVoidFuncByORD(sethostent, ORD_SETHOSTENT, (int x), (x))
350 DeclVoidFuncByORD(setnetent, ORD_SETNETENT, (int x), (x))
351 DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x))
352 DeclVoidFuncByORD(setservent, ORD_SETSERVENT, (int x), (x))
354 DeclVoidFuncByORD(endhostent, ORD_ENDHOSTENT, (void), ())
355 DeclVoidFuncByORD(endnetent, ORD_ENDNETENT, (void), ())
356 DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ())
357 DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ())
360 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
362 #define QSS_INI_BUFFER 1024
364 ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
365 static int pidtid_lookup;
368 get_sysinfo(ULONG pid, ULONG flags)
371 ULONG rc, buf_len = QSS_INI_BUFFER;
374 if (!pidtid_lookup) {
376 *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0);
378 if (pDosVerifyPidTid) { /* Warp3 or later */
379 /* Up to some fixpak QuerySysState() kills the system if a non-existent
381 if (!pDosVerifyPidTid(pid, 1))
384 New(1322, pbuffer, buf_len, char);
385 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
386 rc = QuerySysState(flags, pid, pbuffer, buf_len);
387 while (rc == ERROR_BUFFER_OVERFLOW) {
388 Renew(pbuffer, buf_len *= 2, char);
389 rc = QuerySysState(flags, pid, pbuffer, buf_len);
396 psi = (PQTOPLEVEL)pbuffer;
397 if (psi && pid && pid != psi->procdata->pid) {
399 Perl_croak_nocontext("panic: wrong pid in sysinfo");
404 #define PRIO_ERR 0x1111
414 psi = get_sysinfo(pid, QSS_PROCESS);
417 prio = psi->procdata->threads->priority;
423 setpriority(int which, int pid, int val)
425 ULONG rc, prio = sys_prio(pid);
427 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
428 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
429 /* Do not change class. */
430 return CheckOSError(DosSetPriority((pid < 0)
431 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
433 (32 - val) % 32 - (prio & 0xFF),
436 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
437 /* Documentation claims one can change both class and basevalue,
438 * but I find it wrong. */
439 /* Change class, but since delta == 0 denotes absolute 0, correct. */
440 if (CheckOSError(DosSetPriority((pid < 0)
441 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
442 priors[(32 - val) >> 5] + 1,
446 if ( ((32 - val) % 32) == 0 ) return 0;
447 return CheckOSError(DosSetPriority((pid < 0)
448 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
457 getpriority(int which /* ignored */, int pid)
461 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
463 if (ret == PRIO_ERR) {
466 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
469 /*****************************************************************************/
472 int emx_runtime_init; /* If 1, we need to manually init it */
473 int emx_exception_init; /* If 1, we need to manually set it */
475 /* There is no big sense to make it thread-specific, since signals
476 are delivered to thread 1 only. XXXX Maybe make it into an array? */
477 static int spawn_pid;
478 static int spawn_killed;
481 spawn_sighandler(int sig)
483 /* Some programs do not arrange for the keyboard signals to be
484 delivered to them. We need to deliver the signal manually. */
485 /* We may get a signal only if
486 a) kid does not receive keyboard signal: deliver it;
487 b) kid already died, and we get a signal. We may only hope
488 that the pid number was not reused.
492 sig = SIGKILL; /* Try harder. */
493 kill(spawn_pid, sig);
498 result(pTHX_ int flag, int pid)
501 Signal_t (*ihand)(); /* place to save signal during system() */
502 Signal_t (*qhand)(); /* place to save signal during system() */
508 if (pid < 0 || flag != 0)
514 ihand = rsignal(SIGINT, &spawn_sighandler);
515 qhand = rsignal(SIGQUIT, &spawn_sighandler);
517 r = wait4pid(pid, &status, 0);
518 } while (r == -1 && errno == EINTR);
519 rsignal(SIGINT, ihand);
520 rsignal(SIGQUIT, qhand);
522 PL_statusvalue = (U16)status;
525 return status & 0xFFFF;
527 ihand = rsignal(SIGINT, SIG_IGN);
528 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
529 rsignal(SIGINT, ihand);
530 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
533 return PL_statusvalue;
546 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
555 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
556 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
559 return (pib->pib_ultype);
563 file_type(char *path)
568 if (!(_emx_env & 0x200))
569 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
570 if (CheckOSError(DosQueryAppType(path, &apptype))) {
572 case ERROR_FILE_NOT_FOUND:
573 case ERROR_PATH_NOT_FOUND:
575 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
577 default: /* Found, but not an
578 executable, or some other
586 static ULONG os2_mytype;
588 /* Spawn/exec a program, revert to shell if needed. */
589 /* global PL_Argv[] contains arguments. */
591 extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
592 EXCEPTIONREGISTRATIONRECORD *,
597 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
603 static char * fargs[4]
604 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
605 char **argsp = fargs;
608 int new_stderr = -1, nostderr = 0;
618 if (strEQ(PL_Argv[0],"/bin/sh"))
619 PL_Argv[0] = PL_sh_path;
621 if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
622 && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
623 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
624 ) /* will spawnvp use PATH? */
625 TAINT_ENV(); /* testing IFS here is overkill, probably */
626 /* We should check PERL_SH* and PERLLIB_* as well? */
627 if (!really || !*(tmps = SvPV(really, n_a)))
632 if (_emx_env & 0x200) { /* OS/2. */
633 int type = file_type(tmps);
635 if (type == -1) { /* Not found */
640 else if (type == -2) { /* Not an EXE */
645 else if (type == -3) { /* Is a directory? */
646 /* Special-case this */
648 int l = strlen(tmps);
650 if (l + 5 <= sizeof tbuf) {
652 strcpy(tbuf + l, ".exe");
653 type = file_type(tbuf);
663 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
664 case FAPPTYP_WINDOWAPI:
666 if (os2_mytype != 3) { /* not PM */
667 if (flag == P_NOWAIT)
669 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
670 Perl_warner(aTHX_ WARN_EXEC, "Starting PM process with flag=%d, mytype=%d",
675 case FAPPTYP_NOTWINDOWCOMPAT:
677 if (os2_mytype != 0) { /* not full screen */
678 if (flag == P_NOWAIT)
680 else if ((flag & 7) != P_SESSION)
681 Perl_warner(aTHX_ WARN_EXEC, "Starting Full Screen process with flag=%d, mytype=%d",
686 case FAPPTYP_NOTSPEC:
687 /* Let the shell handle this... */
689 buf = ""; /* Pacify a warning */
690 file = 0; /* Pacify a warning */
698 new_stderr = dup(2); /* Preserve stderr */
699 if (new_stderr == -1) {
707 fl_stderr = fcntl(2, F_GETFD);
711 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
715 rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv));
717 if (execf == EXECF_TRUEEXEC)
718 rc = execvp(tmps,PL_Argv);
719 else if (execf == EXECF_EXEC)
720 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
721 else if (execf == EXECF_SPAWN_NOWAIT)
722 rc = spawnvp(flag,tmps,PL_Argv);
723 else if (execf == EXECF_SYNC)
724 rc = spawnvp(trueflag,tmps,PL_Argv);
725 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
726 rc = result(aTHX_ trueflag,
727 spawnvp(flag,tmps,PL_Argv));
729 if (rc < 0 && pass == 1
730 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
735 if (err == ENOENT || err == ENOEXEC) {
736 /* No such file, or is a script. */
737 /* Try adding script extensions to the file name, and
739 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
743 SV *scrsv = sv_2mortal(newSVpv(scr, 0));
744 SV *bufsv = sv_newmortal();
747 scr = SvPV(scrsv, n_a); /* free()ed later */
749 file = PerlIO_open(scr, "r");
754 buf = sv_gets(bufsv, file, 0 /* No append */);
756 buf = ""; /* XXX Needed? */
757 if (!buf[0]) { /* Empty... */
759 /* Special case: maybe from -Zexe build, so
760 there is an executable around (contrary to
761 documentation, DosQueryAppType sometimes (?)
762 does not append ".exe", so we could have
763 reached this place). */
764 sv_catpv(scrsv, ".exe");
765 scr = SvPV(scrsv, n_a); /* Reload */
766 if (PerlLIO_stat(scr,&PL_statbuf) >= 0
767 && !S_ISDIR(PL_statbuf.st_mode)) { /* Found */
771 } else { /* Restore */
772 SvCUR_set(scrsv, SvCUR(scrsv) - 4);
776 if (PerlIO_close(file) != 0) { /* Failure */
778 Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s",
779 scr, Strerror(errno));
780 buf = ""; /* Not #! */
786 } else if (buf[0] == 'e') {
787 if (strnEQ(buf, "extproc", 7)
790 } else if (buf[0] == 'E') {
791 if (strnEQ(buf, "EXTPROC", 7)
796 buf = ""; /* Not #! */
804 /* Do better than pdksh: allow a few args,
805 strip trailing whitespace. */
815 while (*s && !isSPACE(*s))
822 Perl_warner(aTHX_ WARN_EXEC, "Too many args on %.*s line of \"%s\"",
827 /* Can jump from far, buf/file invalid if force_shell: */
834 || (!buf[0] && file)) { /* File without magic */
835 /* In fact we tried all what pdksh would
836 try. There is no point in calling
837 pdksh, we may just emulate its logic. */
838 char *shell = getenv("EXECSHELL");
839 char *shell_opt = NULL;
845 shell = getenv("OS2_SHELL");
846 if (inicmd) { /* No spaces at start! */
848 while (*s && !isSPACE(*s)) {
850 inicmd = NULL; /* Cannot use */
858 /* Dosish shells will choke on slashes
859 in paths, fortunately, this is
860 important for zeroth arg only. */
867 /* If EXECSHELL is set, we do not set */
870 shell = ((_emx_env & 0x200)
873 nargs = shell_opt ? 2 : 1; /* shell file args */
874 exec_args[0] = shell;
875 exec_args[1] = shell_opt;
877 if (nargs == 2 && inicmd) {
878 /* Use the original cmd line */
879 /* XXXX This is good only until we refuse
880 quoted arguments... */
884 } else if (!buf[0] && inicmd) { /* No file */
885 /* Start with the original cmdline. */
886 /* XXXX This is good only until we refuse
887 quoted arguments... */
891 nargs = 2; /* shell -c */
894 while (a[1]) /* Get to the end */
896 a++; /* Copy finil NULL too */
897 while (a >= PL_Argv) {
898 *(a + nargs) = *a; /* PL_Argv was preallocated to be
903 PL_Argv[nargs] = argsp[nargs];
904 /* Enable pathless exec if #! (as pdksh). */
905 pass = (buf[0] == '#' ? 2 : 3);
909 /* Not found: restore errno */
913 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
914 char *no_dir = strrchr(PL_Argv[0], '/');
916 /* Do as pdksh port does: if not found with /, try without
919 PL_Argv[0] = no_dir + 1;
924 if (rc < 0 && ckWARN(WARN_EXEC))
925 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n",
926 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
928 PL_Argv[0], Strerror(errno));
929 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
930 && ((trueflag & 0xFF) == P_WAIT))
934 if (new_stderr != -1) { /* How can we use error codes? */
937 fcntl(2, F_SETFD, fl_stderr);
943 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
945 do_spawn3(pTHX_ char *cmd, int execf, int flag)
949 char *shell, *copt, *news = NULL;
950 int rc, seenspace = 0, mergestderr = 0;
953 if ((shell = getenv("EMXSHELL")) != NULL)
955 else if ((shell = getenv("SHELL")) != NULL)
957 else if ((shell = getenv("COMSPEC")) != NULL)
962 /* Consensus on perl5-porters is that it is _very_ important to
963 have a shell which will not change between computers with the
964 same architecture, to avoid "action on a distance".
965 And to have simple build, this shell should be sh. */
970 while (*cmd && isSPACE(*cmd))
973 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
974 STRLEN l = strlen(PL_sh_path);
976 New(1302, news, strlen(cmd) - 7 + l + 1, char);
977 strcpy(news, PL_sh_path);
978 strcpy(news + l, cmd + 7);
982 /* save an extra exec if possible */
983 /* see if there are shell metacharacters in it */
985 if (*cmd == '.' && isSPACE(cmd[1]))
988 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
991 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
995 for (s = cmd; *s; s++) {
996 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
997 if (*s == '\n' && s[1] == '\0') {
1000 } else if (*s == '\\' && !seenspace) {
1001 continue; /* Allow backslashes in names */
1002 } else if (*s == '>' && s >= cmd + 3
1003 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
1004 && isSPACE(s[-2]) ) {
1007 while (*t && isSPACE(*t))
1012 break; /* Allow 2>&1 as the last thing */
1015 /* We do not convert this to do_spawn_ve since shell
1016 should be smart enough to start itself gloriously. */
1018 if (execf == EXECF_TRUEEXEC)
1019 rc = execl(shell,shell,copt,cmd,(char*)0);
1020 else if (execf == EXECF_EXEC)
1021 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
1022 else if (execf == EXECF_SPAWN_NOWAIT)
1023 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
1024 else if (execf == EXECF_SPAWN_BYFLAG)
1025 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
1027 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
1028 if (execf == EXECF_SYNC)
1029 rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0);
1031 rc = result(aTHX_ P_WAIT,
1032 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
1033 if (rc < 0 && ckWARN(WARN_EXEC))
1034 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
1035 (execf == EXECF_SPAWN ? "spawn" : "exec"),
1036 shell, Strerror(errno));
1043 } else if (*s == ' ' || *s == '\t') {
1048 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
1049 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
1050 PL_Cmd = savepvn(cmd, s-cmd);
1052 for (s = PL_Cmd; *s;) {
1053 while (*s && isSPACE(*s)) s++;
1056 while (*s && !isSPACE(*s)) s++;
1062 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
1073 os2_do_aspawn(pTHX_ SV *really, register void **vmark, register void **vsp)
1075 register SV **mark = (SV **)vmark;
1076 register SV **sp = (SV **)vsp;
1079 int flag = P_WAIT, flag_set = 0;
1083 New(1301,PL_Argv, sp - mark + 3, char*);
1086 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
1088 flag = SvIVx(*mark);
1093 while (++mark <= sp) {
1095 *a++ = SvPVx(*mark, n_a);
1101 if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
1102 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
1104 rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0);
1112 os2_do_spawn(pTHX_ char *cmd)
1114 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
1118 do_spawn_nowait(pTHX_ char *cmd)
1120 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1124 Perl_do_exec(pTHX_ char *cmd)
1126 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1131 os2exec(pTHX_ char *cmd)
1133 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1137 my_syspopen(pTHX_ char *cmd, char *mode)
1141 register I32 this, that, newfd;
1144 int fh_fl = 0; /* Pacify the warning */
1146 /* `this' is what we use in the parent, `that' in the child. */
1147 this = (*mode == 'w');
1151 taint_proper("Insecure %s%s", "EXEC");
1155 /* Now we need to spawn the child. */
1156 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1157 int new = dup(p[this]);
1164 newfd = dup(*mode == 'r'); /* Preserve std* */
1166 /* This cannot happen due to fh being bad after pipe(), since
1167 pipe() should have created fh 0 and 1 even if they were
1168 initially closed. But we closed p[this] before. */
1169 if (errno != EBADF) {
1176 fh_fl = fcntl(*mode == 'r', F_GETFD);
1177 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1178 dup2(p[that], *mode == 'r');
1181 /* Where is `this' and newfd now? */
1182 fcntl(p[this], F_SETFD, FD_CLOEXEC);
1184 fcntl(newfd, F_SETFD, FD_CLOEXEC);
1185 pid = do_spawn_nowait(aTHX_ cmd);
1187 close(*mode == 'r'); /* It was closed initially */
1188 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1189 dup2(newfd, *mode == 'r'); /* Return std* back. */
1191 fcntl(*mode == 'r', F_SETFD, fh_fl);
1193 fcntl(*mode == 'r', F_SETFD, fh_fl);
1194 if (p[that] == (*mode == 'r'))
1200 if (p[that] < p[this]) { /* Make fh as small as possible */
1201 dup2(p[this], p[that]);
1205 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1206 (void)SvUPGRADE(sv,SVt_IV);
1208 PL_forkprocess = pid;
1209 return PerlIO_fdopen(p[this], mode);
1211 #else /* USE_POPEN */
1217 res = popen(cmd, mode);
1219 char *shell = getenv("EMXSHELL");
1221 my_setenv("EMXSHELL", PL_sh_path);
1222 res = popen(cmd, mode);
1223 my_setenv("EMXSHELL", shell);
1225 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1226 (void)SvUPGRADE(sv,SVt_IV);
1227 SvIVX(sv) = -1; /* A cooky. */
1230 #endif /* USE_POPEN */
1234 /******************************************************************/
1240 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1246 /*******************************************************************/
1247 /* not implemented in EMX 0.9d */
1249 char * ctermid(char *s) { return 0; }
1251 #ifdef MYTTYNAME /* was not in emx0.9a */
1252 void * ttyname(x) { return 0; }
1255 /*****************************************************************************/
1256 /* not implemented in C Set++ */
1259 int setuid(x) { errno = EINVAL; return -1; }
1260 int setgid(x) { errno = EINVAL; return -1; }
1263 /*****************************************************************************/
1264 /* stat() hack for char/block device */
1268 /* First attempt used DosQueryFSAttach which crashed the system when
1269 used with 5.001. Now just look for /dev/. */
1272 os2_stat(const char *name, struct stat *st)
1274 static int ino = SHRT_MAX;
1276 if (stricmp(name, "/dev/con") != 0
1277 && stricmp(name, "/dev/tty") != 0)
1278 return stat(name, st);
1280 memset(st, 0, sizeof *st);
1281 st->st_mode = S_IFCHR|0666;
1282 st->st_ino = (ino-- & 0x7FFF);
1289 #ifdef USE_PERL_SBRK
1291 /* SBRK() emulation, mostly moved to malloc.c. */
1294 sys_alloc(int size) {
1296 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1298 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1301 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1305 #endif /* USE_PERL_SBRK */
1309 char *tmppath = TMPPATH1;
1314 char *p = getenv("TMP"), *tpath;
1317 if (!p) p = getenv("TEMP");
1320 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1324 strcpy(tpath + len + 1, TMPPATH1);
1331 XS(XS_File__Copy_syscopy)
1334 if (items < 2 || items > 3)
1335 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1338 char * src = (char *)SvPV(ST(0),n_a);
1339 char * dst = (char *)SvPV(ST(1),n_a);
1346 flag = (unsigned long)SvIV(ST(2));
1349 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1350 ST(0) = sv_newmortal();
1351 sv_setiv(ST(0), (IV)RETVAL);
1356 #define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */
1357 #include "patchlevel.h"
1358 #undef PERL_PATCHLEVEL_H_IMPLICIT
1361 mod2fname(pTHX_ SV *sv)
1363 static char fname[9];
1364 int pos = 6, len, avlen;
1365 unsigned int sum = 0;
1369 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1371 if (SvTYPE(sv) != SVt_PVAV)
1372 Perl_croak_nocontext("Not array reference given to mod2fname");
1374 avlen = av_len((AV*)sv);
1376 Perl_croak_nocontext("Empty array reference given to mod2fname");
1378 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1379 strncpy(fname, s, 8);
1381 if (len < 6) pos = len;
1383 sum = 33 * sum + *(s++); /* Checksumming first chars to
1384 * get the capitalization into c.s. */
1387 while (avlen >= 0) {
1388 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1390 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1394 #ifdef USE_5005THREADS
1395 sum++; /* Avoid conflict of DLLs in memory. */
1397 /* We always load modules as *specific* DLLs, and with the full name.
1398 When loading a specific DLL by its full name, one cannot get a
1399 different DLL, even if a DLL with the same basename is loaded already.
1400 Thus there is no need to include the version into the mangling scheme. */
1402 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
1404 # ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
1405 # define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
1407 sum += COMPATIBLE_VERSION_SUM;
1409 fname[pos] = 'A' + (sum % 26);
1410 fname[pos + 1] = 'A' + (sum / 26 % 26);
1411 fname[pos + 2] = '\0';
1412 return (char *)fname;
1415 XS(XS_DynaLoader_mod2fname)
1419 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1424 RETVAL = mod2fname(aTHX_ sv);
1425 ST(0) = sv_newmortal();
1426 sv_setpv((SV*)ST(0), RETVAL);
1434 static char buf[300];
1437 int number = SvTRUE(get_sv("OS2::nsyserror", TRUE));
1439 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1443 sprintf(buf, "SYS%04d=%#x: ", rc, rc);
1444 s = buf + strlen(buf);
1447 if (DosGetMessage(NULL, 0, s, sizeof(buf) - 1 - (s-buf),
1448 rc, "OSO001.MSG", &len)) {
1450 sprintf(buf, "SYS%04d=%#x: ", rc, rc);
1451 s = buf + strlen(buf);
1453 sprintf(s, "[No description found in OSO001.MSG]");
1456 if (len && s[len - 1] == '\n')
1458 if (len && s[len - 1] == '\r')
1460 if (len && s[len - 1] == '.')
1462 if (len >= 10 && number && strnEQ(s, buf, 7)
1463 && s[7] == ':' && s[8] == ' ')
1464 /* Some messages start with SYSdddd:, some not */
1465 Move(s + 9, s, (len -= 9) + 1, char);
1473 char buf[300], *p, *o = PL_origargv[0], ok = 1;
1475 if (_execname(buf, sizeof buf) != 0)
1482 if (ok && *o != '/' && *o != '\\')
1484 } else if (ok && tolower(*o) != tolower(*p))
1489 if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */
1490 strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */
1504 perllib_mangle(char *s, unsigned int l)
1506 static char *newp, *oldp;
1507 static int newl, oldl, notfound;
1508 static char ret[STATIC_FILE_LENGTH+1];
1510 if (!newp && !notfound) {
1511 newp = getenv("PERLLIB_PREFIX");
1516 while (*newp && !isSPACE(*newp) && *newp != ';') {
1517 newp++; oldl++; /* Skip digits. */
1519 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1520 newp++; /* Skip whitespace. */
1522 newl = strlen(newp);
1523 if (newl == 0 || oldl == 0) {
1524 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1529 if (*s == '\\') *s = '/';
1542 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1545 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1546 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1548 strcpy(ret + newl, s + oldl);
1553 Perl_hab_GET() /* Needed if perl.h cannot be included */
1555 return perl_hab_GET();
1559 Perl_Register_MQ(int serve)
1564 if (Perl_os2_initial_mode++)
1566 DosGetInfoBlocks(&tib, &pib);
1567 Perl_os2_initial_mode = pib->pib_ultype;
1568 /* Try morphing into a PM application. */
1569 if (pib->pib_ultype != 3) /* 2 is VIO */
1570 pib->pib_ultype = 3; /* 3 is PM */
1571 init_PMWIN_entries();
1572 /* 64 messages if before OS/2 3.0, ignored otherwise */
1573 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1577 SAVEINT(cnt); /* Allow catch()ing. */
1579 _exit(188); /* Panic can try to create a window. */
1580 Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
1583 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
1584 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
1585 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
1587 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
1588 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1594 Perl_Serve_Messages(int force)
1599 if (Perl_hmq_servers > 0 && !force)
1601 if (Perl_hmq_refcnt <= 0)
1602 Perl_croak_nocontext("No message queue");
1603 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1605 if (msg.msg == WM_QUIT)
1606 Perl_croak_nocontext("QUITing...");
1607 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1613 Perl_Process_Messages(int force, I32 *cntp)
1617 if (Perl_hmq_servers > 0 && !force)
1619 if (Perl_hmq_refcnt <= 0)
1620 Perl_croak_nocontext("No message queue");
1621 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1624 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1625 if (msg.msg == WM_DESTROY)
1627 if (msg.msg == WM_CREATE)
1630 Perl_croak_nocontext("QUITing...");
1634 Perl_Deregister_MQ(int serve)
1641 if (--Perl_hmq_refcnt <= 0) {
1642 init_PMWIN_entries(); /* To be extra safe */
1643 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1645 /* Try morphing back from a PM application. */
1646 DosGetInfoBlocks(&tib, &pib);
1647 if (pib->pib_ultype == 3) /* 3 is PM */
1648 pib->pib_ultype = Perl_os2_initial_mode;
1650 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
1652 } else if (serve && Perl_hmq_servers <= 0) /* Last server exited */
1653 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1656 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1657 && ((path)[2] == '/' || (path)[2] == '\\'))
1658 #define sys_is_rooted _fnisabs
1659 #define sys_is_relative _fnisrel
1660 #define current_drive _getdrive
1662 #undef chdir /* Was _chdir2. */
1663 #define sys_chdir(p) (chdir(p) == 0)
1664 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1666 static int DOS_harderr_state = -1;
1672 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
1674 int arg1 = SvIV(ST(0));
1675 int arg2 = SvIV(ST(1));
1676 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1677 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1678 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1681 if (CheckOSError(DosError(a)))
1682 Perl_croak_nocontext("DosError(%d) failed", a);
1683 ST(0) = sv_newmortal();
1684 if (DOS_harderr_state >= 0)
1685 sv_setiv(ST(0), DOS_harderr_state);
1686 DOS_harderr_state = RETVAL;
1691 static signed char DOS_suppression_state = -1;
1693 XS(XS_OS2_Errors2Drive)
1697 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
1701 int suppress = SvOK(sv);
1702 char *s = suppress ? SvPV(sv, n_a) : NULL;
1703 char drive = (s ? *s : 0);
1706 if (suppress && !isALPHA(drive))
1707 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1708 if (CheckOSError(DosSuppressPopUps((suppress
1709 ? SPU_ENABLESUPPRESSION
1710 : SPU_DISABLESUPPRESSION),
1712 Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
1713 ST(0) = sv_newmortal();
1714 if (DOS_suppression_state > 0)
1715 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1716 else if (DOS_suppression_state == 0)
1717 sv_setpvn(ST(0), "", 0);
1718 DOS_suppression_state = drive;
1723 static const char * const si_fields[QSV_MAX] = {
1725 "MAX_TEXT_SESSIONS",
1729 "DYN_PRI_VARIATION",
1747 "FOREGROUND_FS_SESSION",
1748 "FOREGROUND_PROCESS"
1755 Perl_croak_nocontext("Usage: OS2::SysInfo()");
1757 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1758 APIRET rc = NO_ERROR; /* Return code */
1761 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1762 QSV_MAX, /* information */
1765 Perl_croak_nocontext("DosQuerySysInfo() failed");
1766 EXTEND(SP,2*QSV_MAX);
1767 while (i < QSV_MAX) {
1768 ST(j) = sv_newmortal();
1769 sv_setpv(ST(j++), si_fields[i]);
1770 ST(j) = sv_newmortal();
1771 sv_setiv(ST(j++), si[i]);
1775 XSRETURN(2 * QSV_MAX);
1778 XS(XS_OS2_BootDrive)
1782 Perl_croak_nocontext("Usage: OS2::BootDrive()");
1784 ULONG si[1] = {0}; /* System Information Data Buffer */
1785 APIRET rc = NO_ERROR; /* Return code */
1788 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1789 (PVOID)si, sizeof(si))))
1790 Perl_croak_nocontext("DosQuerySysInfo() failed");
1791 ST(0) = sv_newmortal();
1792 c = 'a' - 1 + si[0];
1793 sv_setpvn(ST(0), &c, 1);
1802 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
1804 bool serve = SvOK(ST(0));
1805 unsigned long pmq = perl_hmq_GET(serve);
1807 ST(0) = sv_newmortal();
1808 sv_setiv(ST(0), pmq);
1813 XS(XS_OS2_UnMorphPM)
1817 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
1819 bool serve = SvOK(ST(0));
1821 perl_hmq_UNSET(serve);
1826 XS(XS_OS2_Serve_Messages)
1830 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
1832 bool force = SvOK(ST(0));
1833 unsigned long cnt = Perl_Serve_Messages(force);
1835 ST(0) = sv_newmortal();
1836 sv_setiv(ST(0), cnt);
1841 XS(XS_OS2_Process_Messages)
1844 if (items < 1 || items > 2)
1845 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
1847 bool force = SvOK(ST(0));
1854 (void)SvIV(sv); /* Force SvIVX */
1856 Perl_croak_nocontext("Can't upgrade count to IV");
1858 cnt = Perl_Process_Messages(force, &cntr);
1861 cnt = Perl_Process_Messages(force, NULL);
1863 ST(0) = sv_newmortal();
1864 sv_setiv(ST(0), cnt);
1869 XS(XS_Cwd_current_drive)
1873 Perl_croak_nocontext("Usage: Cwd::current_drive()");
1877 RETVAL = current_drive();
1878 ST(0) = sv_newmortal();
1879 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1884 XS(XS_Cwd_sys_chdir)
1888 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
1891 char * path = (char *)SvPV(ST(0),n_a);
1894 RETVAL = sys_chdir(path);
1895 ST(0) = boolSV(RETVAL);
1896 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1901 XS(XS_Cwd_change_drive)
1905 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
1908 char d = (char)*SvPV(ST(0),n_a);
1911 RETVAL = change_drive(d);
1912 ST(0) = boolSV(RETVAL);
1913 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1918 XS(XS_Cwd_sys_is_absolute)
1922 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
1925 char * path = (char *)SvPV(ST(0),n_a);
1928 RETVAL = sys_is_absolute(path);
1929 ST(0) = boolSV(RETVAL);
1930 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1935 XS(XS_Cwd_sys_is_rooted)
1939 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
1942 char * path = (char *)SvPV(ST(0),n_a);
1945 RETVAL = sys_is_rooted(path);
1946 ST(0) = boolSV(RETVAL);
1947 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1952 XS(XS_Cwd_sys_is_relative)
1956 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
1959 char * path = (char *)SvPV(ST(0),n_a);
1962 RETVAL = sys_is_relative(path);
1963 ST(0) = boolSV(RETVAL);
1964 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1973 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
1977 RETVAL = _getcwd2(p, MAXPATHLEN);
1978 ST(0) = sv_newmortal();
1979 sv_setpv((SV*)ST(0), RETVAL);
1984 XS(XS_Cwd_sys_abspath)
1987 if (items < 1 || items > 2)
1988 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
1991 char * path = (char *)SvPV(ST(0),n_a);
1992 char * dir, *s, *t, *e;
2001 dir = (char *)SvPV(ST(1),n_a);
2003 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
2007 if (_abspath(p, path, MAXPATHLEN) == 0) {
2013 /* Absolute with drive: */
2014 if ( sys_is_absolute(path) ) {
2015 if (_abspath(p, path, MAXPATHLEN) == 0) {
2020 } else if (path[0] == '/' || path[0] == '\\') {
2021 /* Rooted, but maybe on different drive. */
2022 if (isALPHA(dir[0]) && dir[1] == ':' ) {
2023 char p1[MAXPATHLEN];
2025 /* Need to prepend the drive. */
2028 Copy(path, p1 + 2, strlen(path) + 1, char);
2030 if (_abspath(p, p1, MAXPATHLEN) == 0) {
2035 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2041 /* Either path is relative, or starts with a drive letter. */
2042 /* If the path starts with a drive letter, then dir is
2044 a/b) it is absolute/x:relative on the same drive.
2045 c) path is on current drive, and dir is rooted
2046 In all the cases it is safe to drop the drive part
2048 if ( !sys_is_relative(path) ) {
2049 if ( ( ( sys_is_absolute(dir)
2050 || (isALPHA(dir[0]) && dir[1] == ':'
2051 && strnicmp(dir, path,1) == 0))
2052 && strnicmp(dir, path,1) == 0)
2053 || ( !(isALPHA(dir[0]) && dir[1] == ':')
2054 && toupper(path[0]) == current_drive())) {
2056 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2057 RETVAL = p; goto done;
2059 RETVAL = NULL; goto done;
2063 /* Need to prepend the absolute path of dir. */
2064 char p1[MAXPATHLEN];
2066 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
2069 if (p1[ l - 1 ] != '/') {
2073 Copy(path, p1 + l, strlen(path) + 1, char);
2074 if (_abspath(p, p1, MAXPATHLEN) == 0) {
2088 /* Backslashes are already converted to slashes. */
2089 /* Remove trailing slashes */
2091 while (l > 0 && RETVAL[l-1] == '/')
2093 ST(0) = sv_newmortal();
2094 sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
2095 /* Remove duplicate slashes, skipping the first three, which
2096 may be parts of a server-based path */
2097 s = t = 3 + SvPV_force(sv, n_a);
2099 /* Do not worry about multibyte chars here, this would contradict the
2100 eventual UTFization, and currently most other places break too... */
2102 if (s[0] == t[-1] && s[0] == '/')
2103 s++; /* Skip duplicate / */
2109 SvCUR_set(sv, t - SvPVX(sv));
2114 typedef APIRET (*PELP)(PSZ path, ULONG type);
2116 /* Kernels after 2000/09/15 understand this too: */
2117 #ifndef LIBPATHSTRICT
2118 # define LIBPATHSTRICT 3
2122 ExtLIBPATH(ULONG ord, PSZ path, IV type)
2125 PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */
2130 what = BEGIN_LIBPATH;
2132 what = LIBPATHSTRICT;
2133 return (*(PELP)f)(path, what);
2136 #define extLibpath(to,type) \
2137 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
2139 #define extLibpath_set(p,type) \
2140 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
2142 XS(XS_Cwd_extLibpath)
2145 if (items < 0 || items > 1)
2146 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
2159 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
2160 RETVAL = extLibpath(to, type);
2161 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
2162 Perl_croak_nocontext("panic Cwd::extLibpath parameter");
2163 ST(0) = sv_newmortal();
2164 sv_setpv((SV*)ST(0), RETVAL);
2169 XS(XS_Cwd_extLibpath_set)
2172 if (items < 1 || items > 2)
2173 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2176 char * s = (char *)SvPV(ST(0),n_a);
2187 RETVAL = extLibpath_set(s, type);
2188 ST(0) = boolSV(RETVAL);
2189 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2194 #define get_control87() _control87(0,0)
2195 #define set_control87 _control87
2197 XS(XS_OS2__control87)
2201 croak("Usage: OS2::_control87(new,mask)");
2203 unsigned new = (unsigned)SvIV(ST(0));
2204 unsigned mask = (unsigned)SvIV(ST(1));
2207 RETVAL = _control87(new, mask);
2208 ST(0) = sv_newmortal();
2209 sv_setiv(ST(0), (IV)RETVAL);
2214 XS(XS_OS2_get_control87)
2218 croak("Usage: OS2::get_control87()");
2222 RETVAL = get_control87();
2223 ST(0) = sv_newmortal();
2224 sv_setiv(ST(0), (IV)RETVAL);
2230 XS(XS_OS2_set_control87)
2233 if (items < 0 || items > 2)
2234 croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
2243 new = (unsigned)SvIV(ST(0));
2249 mask = (unsigned)SvIV(ST(1));
2252 RETVAL = set_control87(new, mask);
2253 ST(0) = sv_newmortal();
2254 sv_setiv(ST(0), (IV)RETVAL);
2262 char *file = __FILE__;
2266 if (_emx_env & 0x200) { /* OS/2 */
2267 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2268 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2269 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2271 newXS("OS2::Error", XS_OS2_Error, file);
2272 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2273 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2274 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2275 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2276 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2277 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2278 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2279 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2280 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2281 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2282 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2283 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2284 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2285 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2286 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2287 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2288 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
2289 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
2290 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
2291 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2294 sv_setiv(GvSV(gv), 1);
2296 gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
2298 sv_setiv(GvSV(gv), exe_is_aout());
2299 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2301 sv_setiv(GvSV(gv), _emx_rev);
2302 sv_setpv(GvSV(gv), _emx_vprt);
2304 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2306 sv_setiv(GvSV(gv), _emx_env);
2307 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2309 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2310 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
2312 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
2317 OS2_Perl_data_t OS2_Perl_data;
2319 extern void _emx_init(void*);
2321 static void jmp_out_of_atexit(void);
2323 #define FORCE_EMX_INIT_CONTRACT_ARGV 1
2324 #define FORCE_EMX_INIT_INSTALL_ATEXIT 2
2327 my_emx_init(void *layout) {
2328 static volatile void *p = 0; /* Cannot be on stack! */
2330 /* Can't just call emx_init(), since it moves the stack pointer */
2331 /* It also busts a lot of registers, so be extra careful */
2339 "popf\n" : : "r" (layout), "m" (p) );
2342 struct layout_table_t {
2363 static ULONG res; /* Cannot be on stack! */
2365 /* Can't just call emx_init(), since it moves the stack pointer */
2366 /* It also busts a lot of registers, so be extra careful */
2369 "call ___os_version\n"
2372 "popf\n" : "=m" (res) );
2378 force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
2380 /* Calling emx_init() will bust the top of stack: it installs an
2381 exception handler and puts argv data there. */
2382 char *oldarg, *oldenv;
2383 void *oldstackend, *oldstack;
2386 static ULONG os2_dll;
2387 ULONG rc, error = 0, out;
2389 static struct layout_table_t layout_table;
2391 char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
2393 EXCEPTIONREGISTRATIONRECORD xreg;
2397 layout_table.os2_dll = (ULONG)&os2_dll;
2398 layout_table.flags = 0x02000002; /* flags: application, OMF */
2400 DosGetInfoBlocks(&tib, &pib);
2401 oldarg = pib->pib_pchcmd;
2402 oldenv = pib->pib_pchenv;
2403 oldstack = tib->tib_pstack;
2404 oldstackend = tib->tib_pstacklimit;
2406 /* Minimize the damage to the stack via reducing the size of argv. */
2407 if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
2408 pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */
2409 pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */
2412 newstack = alloca(sizeof(*newstack));
2413 /* Emulate the stack probe */
2414 s = ((char*)newstack) + sizeof(*newstack);
2415 while (s > (char*)newstack) {
2420 /* Reassigning stack is documented to work */
2421 tib->tib_pstack = (void*)newstack;
2422 tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
2424 /* Can't just call emx_init(), since it moves the stack pointer */
2425 my_emx_init((void*)&layout_table);
2427 /* Remove the exception handler, cannot use it - too low on the stack.
2428 Check whether it is inside the new stack. */
2430 if (tib->tib_pexchain >= tib->tib_pstacklimit
2431 || tib->tib_pexchain < tib->tib_pstack) {
2434 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
2435 (unsigned long)tib->tib_pstack,
2436 (unsigned long)tib->tib_pexchain,
2437 (unsigned long)tib->tib_pstacklimit);
2440 if (tib->tib_pexchain != &(newstack->xreg)) {
2441 sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
2442 (unsigned long)tib->tib_pexchain,
2443 (unsigned long)&(newstack->xreg));
2445 rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
2447 sprintf(buf + strlen(buf),
2448 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
2451 /* ExceptionRecords should be on stack, in a correct order. Sigh... */
2452 preg->prev_structure = 0;
2453 preg->ExceptionHandler = _emx_exception;
2454 rc = DosSetExceptionHandler(preg);
2456 sprintf(buf + strlen(buf),
2457 "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
2458 DosWrite(2, buf, strlen(buf), &out);
2459 emx_exception_init = 1; /* Do it around spawn*() calls */
2462 emx_exception_init = 1; /* Do it around spawn*() calls */
2465 /* Restore the damage */
2466 pib->pib_pchcmd = oldarg;
2467 pib->pib_pchcmd = oldenv;
2468 tib->tib_pstacklimit = oldstackend;
2469 tib->tib_pstack = oldstack;
2470 emx_runtime_init = 1;
2472 DosWrite(2, buf, strlen(buf), &out);
2477 jmp_buf at_exit_buf;
2478 int longjmp_at_exit;
2481 jmp_out_of_atexit(void)
2483 if (longjmp_at_exit)
2484 longjmp(at_exit_buf, 1);
2487 extern void _CRT_term(void);
2489 int emx_runtime_secondary;
2492 Perl_OS2_term(void **p, int exitstatus, int flags)
2494 if (!emx_runtime_secondary)
2497 /* The principal executable is not running the same CRTL, so there
2498 is nobody to shutdown *this* CRTL except us... */
2499 if (flags & FORCE_EMX_DEINIT_EXIT) {
2500 if (p && !emx_exception_init)
2501 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
2502 /* Do not run the executable's CRTL's termination routines */
2503 exit(exitstatus); /* Run at-exit, flush buffers, etc */
2505 /* Run at-exit list, and jump out at the end */
2506 if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
2507 longjmp_at_exit = 1;
2508 exit(exitstatus); /* The first pass through "if" */
2511 /* Get here if we managed to jump out of exit(), or did not run atexit. */
2512 longjmp_at_exit = 0; /* Maybe exit() is called again? */
2513 #if 0 /* _atexit_n is not exported */
2514 if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
2515 _atexit_n = 0; /* Remove the atexit() handlers */
2517 /* Will segfault on program termination if we leave this dangling... */
2518 if (p && !emx_exception_init)
2519 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
2520 /* Typically there is no need to do this, done from _DLL_InitTerm() */
2521 if (flags & FORCE_EMX_DEINIT_CRT_TERM)
2522 _CRT_term(); /* Flush buffers, etc. */
2523 /* Now it is a good time to call exit() in the caller's CRTL... */
2526 #include <emx/startup.h>
2528 extern ULONG __os_version(); /* See system.doc */
2530 static int emx_wasnt_initialized;
2533 check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
2537 /* If _environ is not set, this code sits in a DLL which
2538 uses a CRT DLL which not compatible with the executable's
2539 CRT library. Some parts of the DLL are not initialized.
2541 if (_environ != NULL)
2542 return; /* Properly initialized */
2544 /* If the executable does not use EMX.DLL, EMX.DLL is not completely
2545 initialized either. Uninitialized EMX.DLL returns 0 in the low
2546 nibble of __os_version(). */
2547 v_emx = my_os_version();
2549 /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
2550 (=>_CRT_init=>_entry2) via a call to __os_version(), then
2551 reset when the EXE initialization code calls _text=>_init=>_entry2.
2552 The first time they are wrongly set to 0; the second time the
2553 EXE initialization code had already called emx_init=>initialize1
2554 which correctly set version_major, version_minor used by
2556 v_crt = (_osmajor | _osminor);
2558 if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */
2559 force_init_emx_runtime( preg,
2560 FORCE_EMX_INIT_CONTRACT_ARGV
2561 | FORCE_EMX_INIT_INSTALL_ATEXIT );
2562 emx_wasnt_initialized = 1;
2563 /* Update CRTL data basing on now-valid EMX runtime data */
2564 if (!v_crt) { /* The only wrong data are the versions. */
2565 v_emx = my_os_version(); /* *Now* it works */
2566 *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
2567 *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
2570 emx_runtime_secondary = 1;
2571 /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
2572 atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */
2574 if (!env) { /* Fetch from the process info block */
2580 DosGetInfoBlocks(&tib, &pib);
2581 e = pib->pib_pchenv;
2582 while (*e) { /* Get count */
2584 e = e + strlen(e) + 1;
2586 e = pib->pib_pchenv;
2587 while (*e) { /* Get count */
2589 e = e + strlen(e) + 1;
2591 New(1307, env, c + 1, char*);
2593 e = pib->pib_pchenv;
2596 e = e + strlen(e) + 1;
2600 _environ = _org_environ = env;
2603 #define ENTRY_POINT 0x10000
2608 struct layout_table_t *layout;
2609 if (emx_wasnt_initialized)
2611 /* Now we know that the principal executable is an EMX application
2612 - unless somebody did already play with delayed initialization... */
2613 /* With EMX applications to determine whether it is AOUT one needs
2614 to examine the start of the executable to find "layout" */
2615 if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */
2616 || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */
2617 || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */
2618 || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */
2619 return 0; /* ! EMX executable */
2621 Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
2622 return !(layout->flags & 2);
2626 Perl_OS2_init(char **env)
2628 Perl_OS2_init3(env, 0, 0);
2632 Perl_OS2_init3(char **env, void **preg, int flags)
2636 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2639 check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
2642 OS2_Perl_data.xs_init = &Xs_OS2_init;
2643 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2644 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2645 strcpy(PL_sh_path, SH_PATH);
2646 PL_sh_path[0] = shell[0];
2647 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2648 int l = strlen(shell), i;
2649 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2652 New(1304, PL_sh_path, l + 8, char);
2653 strncpy(PL_sh_path, shell, l);
2654 strcpy(PL_sh_path + l, "/sh.exe");
2655 for (i = 0; i < l; i++) {
2656 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2659 MUTEX_INIT(&start_thread_mutex);
2660 os2_mytype = my_type(); /* Do it before morphing. Needed? */
2661 /* Some DLLs reset FP flags on load. We may have been linked with them */
2662 _control87(MCW_EM, MCW_EM);
2669 my_tmpnam (char *str)
2671 char *p = getenv("TMP"), *tpath;
2673 if (!p) p = getenv("TEMP");
2674 tpath = tempnam(p, "pltmp");
2688 if (s.st_mode & S_IWOTH) {
2691 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2698 my_rmdir (__const__ char *s)
2700 char buf[MAXPATHLEN];
2701 STRLEN l = strlen(s);
2703 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX rmdir fails... */
2714 my_mkdir (__const__ char *s, long perm)
2716 char buf[MAXPATHLEN];
2717 STRLEN l = strlen(s);
2719 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
2724 return mkdir(s, perm);
2729 /* This code was contributed by Rocco Caputo. */
2731 my_flock(int handle, int o)
2733 FILELOCK rNull, rFull;
2734 ULONG timeout, handle_type, flag_word;
2736 int blocking, shared;
2737 static int use_my = -1;
2740 char *s = getenv("USE_PERL_FLOCK");
2746 if (!(_emx_env & 0x200) || !use_my)
2747 return flock(handle, o); /* Delegate to EMX. */
2750 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2751 (handle_type & 0xFF))
2756 // set lock/unlock ranges
2757 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2758 rFull.lRange = 0x7FFFFFFF;
2759 // set timeout for blocking
2760 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2761 // shared or exclusive?
2762 shared = (o & LOCK_SH) ? 1 : 0;
2763 // do not block the unlock
2764 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2765 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2770 case ERROR_INVALID_HANDLE:
2773 case ERROR_SHARING_BUFFER_EXCEEDED:
2776 case ERROR_LOCK_VIOLATION:
2777 break; // not an error
2778 case ERROR_INVALID_PARAMETER:
2779 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2780 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2783 case ERROR_INTERRUPT:
2792 if (o & (LOCK_SH | LOCK_EX)) {
2793 // for blocking operations
2807 case ERROR_INVALID_HANDLE:
2810 case ERROR_SHARING_BUFFER_EXCEEDED:
2813 case ERROR_LOCK_VIOLATION:
2815 errno = EWOULDBLOCK;
2819 case ERROR_INVALID_PARAMETER:
2820 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2821 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2824 case ERROR_INTERRUPT:
2831 // give away timeslice
2840 static int pwent_cnt;
2841 static int _my_pwent = -1;
2846 if (_my_pwent == -1) {
2847 char *s = getenv("USE_PERL_PWENT");
2849 _my_pwent = atoi(s);
2863 if (!use_my_pwent()) {
2864 setpwent(); /* Delegate to EMX. */
2873 if (!use_my_pwent()) {
2874 endpwent(); /* Delegate to EMX. */
2882 if (!use_my_pwent())
2883 return getpwent(); /* Delegate to EMX. */
2885 return 0; // Return one entry only
2889 static int grent_cnt;
2906 return 0; // Return one entry only
2913 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
2914 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
2916 static struct passwd *
2917 passw_wrap(struct passwd *p)
2919 static struct passwd pw;
2922 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
2925 s = getenv("PW_PASSWD");
2927 s = (char*)pw_p; /* Make match impossible */
2934 my_getpwuid (uid_t id)
2936 return passw_wrap(getpwuid(id));
2940 my_getpwnam (__const__ char *n)
2942 return passw_wrap(getpwnam(n));