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);
1980 #ifndef INCOMPLETE_TAINTS
1981 SvTAINTED_on(ST(0));
1987 XS(XS_Cwd_sys_abspath)
1990 if (items < 1 || items > 2)
1991 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
1994 char * path = (char *)SvPV(ST(0),n_a);
1995 char * dir, *s, *t, *e;
2004 dir = (char *)SvPV(ST(1),n_a);
2006 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
2010 if (_abspath(p, path, MAXPATHLEN) == 0) {
2016 /* Absolute with drive: */
2017 if ( sys_is_absolute(path) ) {
2018 if (_abspath(p, path, MAXPATHLEN) == 0) {
2023 } else if (path[0] == '/' || path[0] == '\\') {
2024 /* Rooted, but maybe on different drive. */
2025 if (isALPHA(dir[0]) && dir[1] == ':' ) {
2026 char p1[MAXPATHLEN];
2028 /* Need to prepend the drive. */
2031 Copy(path, p1 + 2, strlen(path) + 1, char);
2033 if (_abspath(p, p1, MAXPATHLEN) == 0) {
2038 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2044 /* Either path is relative, or starts with a drive letter. */
2045 /* If the path starts with a drive letter, then dir is
2047 a/b) it is absolute/x:relative on the same drive.
2048 c) path is on current drive, and dir is rooted
2049 In all the cases it is safe to drop the drive part
2051 if ( !sys_is_relative(path) ) {
2052 if ( ( ( sys_is_absolute(dir)
2053 || (isALPHA(dir[0]) && dir[1] == ':'
2054 && strnicmp(dir, path,1) == 0))
2055 && strnicmp(dir, path,1) == 0)
2056 || ( !(isALPHA(dir[0]) && dir[1] == ':')
2057 && toupper(path[0]) == current_drive())) {
2059 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2060 RETVAL = p; goto done;
2062 RETVAL = NULL; goto done;
2066 /* Need to prepend the absolute path of dir. */
2067 char p1[MAXPATHLEN];
2069 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
2072 if (p1[ l - 1 ] != '/') {
2076 Copy(path, p1 + l, strlen(path) + 1, char);
2077 if (_abspath(p, p1, MAXPATHLEN) == 0) {
2091 /* Backslashes are already converted to slashes. */
2092 /* Remove trailing slashes */
2094 while (l > 0 && RETVAL[l-1] == '/')
2096 ST(0) = sv_newmortal();
2097 sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
2098 /* Remove duplicate slashes, skipping the first three, which
2099 may be parts of a server-based path */
2100 s = t = 3 + SvPV_force(sv, n_a);
2102 /* Do not worry about multibyte chars here, this would contradict the
2103 eventual UTFization, and currently most other places break too... */
2105 if (s[0] == t[-1] && s[0] == '/')
2106 s++; /* Skip duplicate / */
2112 SvCUR_set(sv, t - SvPVX(sv));
2117 typedef APIRET (*PELP)(PSZ path, ULONG type);
2119 /* Kernels after 2000/09/15 understand this too: */
2120 #ifndef LIBPATHSTRICT
2121 # define LIBPATHSTRICT 3
2125 ExtLIBPATH(ULONG ord, PSZ path, IV type)
2128 PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */
2133 what = BEGIN_LIBPATH;
2135 what = LIBPATHSTRICT;
2136 return (*(PELP)f)(path, what);
2139 #define extLibpath(to,type) \
2140 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
2142 #define extLibpath_set(p,type) \
2143 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
2145 XS(XS_Cwd_extLibpath)
2148 if (items < 0 || items > 1)
2149 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
2162 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
2163 RETVAL = extLibpath(to, type);
2164 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
2165 Perl_croak_nocontext("panic Cwd::extLibpath parameter");
2166 ST(0) = sv_newmortal();
2167 sv_setpv((SV*)ST(0), RETVAL);
2172 XS(XS_Cwd_extLibpath_set)
2175 if (items < 1 || items > 2)
2176 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2179 char * s = (char *)SvPV(ST(0),n_a);
2190 RETVAL = extLibpath_set(s, type);
2191 ST(0) = boolSV(RETVAL);
2192 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2197 #define get_control87() _control87(0,0)
2198 #define set_control87 _control87
2200 XS(XS_OS2__control87)
2204 croak("Usage: OS2::_control87(new,mask)");
2206 unsigned new = (unsigned)SvIV(ST(0));
2207 unsigned mask = (unsigned)SvIV(ST(1));
2210 RETVAL = _control87(new, mask);
2211 ST(0) = sv_newmortal();
2212 sv_setiv(ST(0), (IV)RETVAL);
2217 XS(XS_OS2_get_control87)
2221 croak("Usage: OS2::get_control87()");
2225 RETVAL = get_control87();
2226 ST(0) = sv_newmortal();
2227 sv_setiv(ST(0), (IV)RETVAL);
2233 XS(XS_OS2_set_control87)
2236 if (items < 0 || items > 2)
2237 croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
2246 new = (unsigned)SvIV(ST(0));
2252 mask = (unsigned)SvIV(ST(1));
2255 RETVAL = set_control87(new, mask);
2256 ST(0) = sv_newmortal();
2257 sv_setiv(ST(0), (IV)RETVAL);
2265 char *file = __FILE__;
2269 if (_emx_env & 0x200) { /* OS/2 */
2270 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2271 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2272 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2274 newXS("OS2::Error", XS_OS2_Error, file);
2275 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2276 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2277 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2278 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2279 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2280 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2281 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2282 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2283 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2284 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2285 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2286 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2287 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2288 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2289 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2290 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2291 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
2292 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
2293 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
2294 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2297 sv_setiv(GvSV(gv), 1);
2299 gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
2301 sv_setiv(GvSV(gv), exe_is_aout());
2302 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2304 sv_setiv(GvSV(gv), _emx_rev);
2305 sv_setpv(GvSV(gv), _emx_vprt);
2307 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2309 sv_setiv(GvSV(gv), _emx_env);
2310 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2312 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2313 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
2315 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
2320 OS2_Perl_data_t OS2_Perl_data;
2322 extern void _emx_init(void*);
2324 static void jmp_out_of_atexit(void);
2326 #define FORCE_EMX_INIT_CONTRACT_ARGV 1
2327 #define FORCE_EMX_INIT_INSTALL_ATEXIT 2
2330 my_emx_init(void *layout) {
2331 static volatile void *p = 0; /* Cannot be on stack! */
2333 /* Can't just call emx_init(), since it moves the stack pointer */
2334 /* It also busts a lot of registers, so be extra careful */
2342 "popf\n" : : "r" (layout), "m" (p) );
2345 struct layout_table_t {
2366 static ULONG res; /* Cannot be on stack! */
2368 /* Can't just call emx_init(), since it moves the stack pointer */
2369 /* It also busts a lot of registers, so be extra careful */
2372 "call ___os_version\n"
2375 "popf\n" : "=m" (res) );
2381 force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
2383 /* Calling emx_init() will bust the top of stack: it installs an
2384 exception handler and puts argv data there. */
2385 char *oldarg, *oldenv;
2386 void *oldstackend, *oldstack;
2389 static ULONG os2_dll;
2390 ULONG rc, error = 0, out;
2392 static struct layout_table_t layout_table;
2394 char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
2396 EXCEPTIONREGISTRATIONRECORD xreg;
2400 layout_table.os2_dll = (ULONG)&os2_dll;
2401 layout_table.flags = 0x02000002; /* flags: application, OMF */
2403 DosGetInfoBlocks(&tib, &pib);
2404 oldarg = pib->pib_pchcmd;
2405 oldenv = pib->pib_pchenv;
2406 oldstack = tib->tib_pstack;
2407 oldstackend = tib->tib_pstacklimit;
2409 /* Minimize the damage to the stack via reducing the size of argv. */
2410 if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
2411 pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */
2412 pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */
2415 newstack = alloca(sizeof(*newstack));
2416 /* Emulate the stack probe */
2417 s = ((char*)newstack) + sizeof(*newstack);
2418 while (s > (char*)newstack) {
2423 /* Reassigning stack is documented to work */
2424 tib->tib_pstack = (void*)newstack;
2425 tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
2427 /* Can't just call emx_init(), since it moves the stack pointer */
2428 my_emx_init((void*)&layout_table);
2430 /* Remove the exception handler, cannot use it - too low on the stack.
2431 Check whether it is inside the new stack. */
2433 if (tib->tib_pexchain >= tib->tib_pstacklimit
2434 || tib->tib_pexchain < tib->tib_pstack) {
2437 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
2438 (unsigned long)tib->tib_pstack,
2439 (unsigned long)tib->tib_pexchain,
2440 (unsigned long)tib->tib_pstacklimit);
2443 if (tib->tib_pexchain != &(newstack->xreg)) {
2444 sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
2445 (unsigned long)tib->tib_pexchain,
2446 (unsigned long)&(newstack->xreg));
2448 rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
2450 sprintf(buf + strlen(buf),
2451 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
2454 /* ExceptionRecords should be on stack, in a correct order. Sigh... */
2455 preg->prev_structure = 0;
2456 preg->ExceptionHandler = _emx_exception;
2457 rc = DosSetExceptionHandler(preg);
2459 sprintf(buf + strlen(buf),
2460 "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
2461 DosWrite(2, buf, strlen(buf), &out);
2462 emx_exception_init = 1; /* Do it around spawn*() calls */
2465 emx_exception_init = 1; /* Do it around spawn*() calls */
2468 /* Restore the damage */
2469 pib->pib_pchcmd = oldarg;
2470 pib->pib_pchcmd = oldenv;
2471 tib->tib_pstacklimit = oldstackend;
2472 tib->tib_pstack = oldstack;
2473 emx_runtime_init = 1;
2475 DosWrite(2, buf, strlen(buf), &out);
2480 jmp_buf at_exit_buf;
2481 int longjmp_at_exit;
2484 jmp_out_of_atexit(void)
2486 if (longjmp_at_exit)
2487 longjmp(at_exit_buf, 1);
2490 extern void _CRT_term(void);
2492 int emx_runtime_secondary;
2495 Perl_OS2_term(void **p, int exitstatus, int flags)
2497 if (!emx_runtime_secondary)
2500 /* The principal executable is not running the same CRTL, so there
2501 is nobody to shutdown *this* CRTL except us... */
2502 if (flags & FORCE_EMX_DEINIT_EXIT) {
2503 if (p && !emx_exception_init)
2504 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
2505 /* Do not run the executable's CRTL's termination routines */
2506 exit(exitstatus); /* Run at-exit, flush buffers, etc */
2508 /* Run at-exit list, and jump out at the end */
2509 if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
2510 longjmp_at_exit = 1;
2511 exit(exitstatus); /* The first pass through "if" */
2514 /* Get here if we managed to jump out of exit(), or did not run atexit. */
2515 longjmp_at_exit = 0; /* Maybe exit() is called again? */
2516 #if 0 /* _atexit_n is not exported */
2517 if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
2518 _atexit_n = 0; /* Remove the atexit() handlers */
2520 /* Will segfault on program termination if we leave this dangling... */
2521 if (p && !emx_exception_init)
2522 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
2523 /* Typically there is no need to do this, done from _DLL_InitTerm() */
2524 if (flags & FORCE_EMX_DEINIT_CRT_TERM)
2525 _CRT_term(); /* Flush buffers, etc. */
2526 /* Now it is a good time to call exit() in the caller's CRTL... */
2529 #include <emx/startup.h>
2531 extern ULONG __os_version(); /* See system.doc */
2533 static int emx_wasnt_initialized;
2536 check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
2540 /* If _environ is not set, this code sits in a DLL which
2541 uses a CRT DLL which not compatible with the executable's
2542 CRT library. Some parts of the DLL are not initialized.
2544 if (_environ != NULL)
2545 return; /* Properly initialized */
2547 /* If the executable does not use EMX.DLL, EMX.DLL is not completely
2548 initialized either. Uninitialized EMX.DLL returns 0 in the low
2549 nibble of __os_version(). */
2550 v_emx = my_os_version();
2552 /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
2553 (=>_CRT_init=>_entry2) via a call to __os_version(), then
2554 reset when the EXE initialization code calls _text=>_init=>_entry2.
2555 The first time they are wrongly set to 0; the second time the
2556 EXE initialization code had already called emx_init=>initialize1
2557 which correctly set version_major, version_minor used by
2559 v_crt = (_osmajor | _osminor);
2561 if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */
2562 force_init_emx_runtime( preg,
2563 FORCE_EMX_INIT_CONTRACT_ARGV
2564 | FORCE_EMX_INIT_INSTALL_ATEXIT );
2565 emx_wasnt_initialized = 1;
2566 /* Update CRTL data basing on now-valid EMX runtime data */
2567 if (!v_crt) { /* The only wrong data are the versions. */
2568 v_emx = my_os_version(); /* *Now* it works */
2569 *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
2570 *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
2573 emx_runtime_secondary = 1;
2574 /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
2575 atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */
2577 if (env == NULL) { /* Fetch from the process info block */
2583 DosGetInfoBlocks(&tib, &pib);
2584 e = pib->pib_pchenv;
2585 while (*e) { /* Get count */
2587 e = e + strlen(e) + 1;
2589 New(1307, env, c + 1, char*);
2591 e = pib->pib_pchenv;
2594 e = e + strlen(e) + 1;
2598 _environ = _org_environ = env;
2601 #define ENTRY_POINT 0x10000
2606 struct layout_table_t *layout;
2607 if (emx_wasnt_initialized)
2609 /* Now we know that the principal executable is an EMX application
2610 - unless somebody did already play with delayed initialization... */
2611 /* With EMX applications to determine whether it is AOUT one needs
2612 to examine the start of the executable to find "layout" */
2613 if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */
2614 || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */
2615 || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */
2616 || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */
2617 return 0; /* ! EMX executable */
2619 Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
2620 return !(layout->flags & 2);
2624 Perl_OS2_init(char **env)
2626 Perl_OS2_init3(env, 0, 0);
2630 Perl_OS2_init3(char **env, void **preg, int flags)
2634 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2637 check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
2640 OS2_Perl_data.xs_init = &Xs_OS2_init;
2641 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2642 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2643 strcpy(PL_sh_path, SH_PATH);
2644 PL_sh_path[0] = shell[0];
2645 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2646 int l = strlen(shell), i;
2647 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2650 New(1304, PL_sh_path, l + 8, char);
2651 strncpy(PL_sh_path, shell, l);
2652 strcpy(PL_sh_path + l, "/sh.exe");
2653 for (i = 0; i < l; i++) {
2654 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2657 MUTEX_INIT(&start_thread_mutex);
2658 os2_mytype = my_type(); /* Do it before morphing. Needed? */
2659 /* Some DLLs reset FP flags on load. We may have been linked with them */
2660 _control87(MCW_EM, MCW_EM);
2667 my_tmpnam (char *str)
2669 char *p = getenv("TMP"), *tpath;
2671 if (!p) p = getenv("TEMP");
2672 tpath = tempnam(p, "pltmp");
2686 if (s.st_mode & S_IWOTH) {
2689 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2696 my_rmdir (__const__ char *s)
2698 char buf[MAXPATHLEN];
2699 STRLEN l = strlen(s);
2701 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX rmdir fails... */
2712 my_mkdir (__const__ char *s, long perm)
2714 char buf[MAXPATHLEN];
2715 STRLEN l = strlen(s);
2717 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
2722 return mkdir(s, perm);
2727 /* This code was contributed by Rocco Caputo. */
2729 my_flock(int handle, int o)
2731 FILELOCK rNull, rFull;
2732 ULONG timeout, handle_type, flag_word;
2734 int blocking, shared;
2735 static int use_my = -1;
2738 char *s = getenv("USE_PERL_FLOCK");
2744 if (!(_emx_env & 0x200) || !use_my)
2745 return flock(handle, o); /* Delegate to EMX. */
2748 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2749 (handle_type & 0xFF))
2754 // set lock/unlock ranges
2755 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2756 rFull.lRange = 0x7FFFFFFF;
2757 // set timeout for blocking
2758 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2759 // shared or exclusive?
2760 shared = (o & LOCK_SH) ? 1 : 0;
2761 // do not block the unlock
2762 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2763 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2768 case ERROR_INVALID_HANDLE:
2771 case ERROR_SHARING_BUFFER_EXCEEDED:
2774 case ERROR_LOCK_VIOLATION:
2775 break; // not an error
2776 case ERROR_INVALID_PARAMETER:
2777 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2778 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2781 case ERROR_INTERRUPT:
2790 if (o & (LOCK_SH | LOCK_EX)) {
2791 // for blocking operations
2805 case ERROR_INVALID_HANDLE:
2808 case ERROR_SHARING_BUFFER_EXCEEDED:
2811 case ERROR_LOCK_VIOLATION:
2813 errno = EWOULDBLOCK;
2817 case ERROR_INVALID_PARAMETER:
2818 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2819 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2822 case ERROR_INTERRUPT:
2829 // give away timeslice
2838 static int pwent_cnt;
2839 static int _my_pwent = -1;
2844 if (_my_pwent == -1) {
2845 char *s = getenv("USE_PERL_PWENT");
2847 _my_pwent = atoi(s);
2861 if (!use_my_pwent()) {
2862 setpwent(); /* Delegate to EMX. */
2871 if (!use_my_pwent()) {
2872 endpwent(); /* Delegate to EMX. */
2880 if (!use_my_pwent())
2881 return getpwent(); /* Delegate to EMX. */
2883 return 0; // Return one entry only
2887 static int grent_cnt;
2904 return 0; // Return one entry only
2911 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
2912 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
2914 static struct passwd *
2915 passw_wrap(struct passwd *p)
2917 static struct passwd pw;
2920 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
2923 s = getenv("PW_PASSWD");
2925 s = (char*)pw_p; /* Make match impossible */
2932 my_getpwuid (uid_t id)
2934 return passw_wrap(getpwuid(id));
2938 my_getpwnam (__const__ char *n)
2940 return passw_wrap(getpwnam(n));