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
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 /*****************************************************************************/
188 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
189 #define C_ARR_LEN(sym) (sizeof(sym)/sizeof(*sym))
195 static struct dll_handle doscalls_handle = {"doscalls", 0};
196 static struct dll_handle tcp_handle = {"tcp32dll", 0};
197 static struct dll_handle pmwin_handle = {"pmwin", 0};
198 static struct dll_handle rexx_handle = {"rexx", 0};
199 static struct dll_handle rexxapi_handle = {"rexxapi", 0};
200 static struct dll_handle sesmgr_handle = {"sesmgr", 0};
201 static struct dll_handle pmshapi_handle = {"pmshapi", 0};
203 /* This should match enum entries_ordinals defined in os2ish.h. */
204 static const struct {
205 struct dll_handle *dll;
206 const char *entryname;
208 } loadOrdinals[ORD_NENTRIES] = {
209 {&doscalls_handle, NULL, 874}, /* DosQueryExtLibpath */
210 {&doscalls_handle, NULL, 873}, /* DosSetExtLibpath */
211 {&doscalls_handle, NULL, 460}, /* DosVerifyPidTid */
212 {&tcp_handle, "SETHOSTENT", 0},
213 {&tcp_handle, "SETNETENT" , 0},
214 {&tcp_handle, "SETPROTOENT", 0},
215 {&tcp_handle, "SETSERVENT", 0},
216 {&tcp_handle, "GETHOSTENT", 0},
217 {&tcp_handle, "GETNETENT" , 0},
218 {&tcp_handle, "GETPROTOENT", 0},
219 {&tcp_handle, "GETSERVENT", 0},
220 {&tcp_handle, "ENDHOSTENT", 0},
221 {&tcp_handle, "ENDNETENT", 0},
222 {&tcp_handle, "ENDPROTOENT", 0},
223 {&tcp_handle, "ENDSERVENT", 0},
224 {&pmwin_handle, NULL, 763}, /* WinInitialize */
225 {&pmwin_handle, NULL, 716}, /* WinCreateMsgQueue */
226 {&pmwin_handle, NULL, 726}, /* WinDestroyMsgQueue */
227 {&pmwin_handle, NULL, 918}, /* WinPeekMsg */
228 {&pmwin_handle, NULL, 915}, /* WinGetMsg */
229 {&pmwin_handle, NULL, 912}, /* WinDispatchMsg */
230 {&pmwin_handle, NULL, 753}, /* WinGetLastError */
231 {&pmwin_handle, NULL, 705}, /* WinCancelShutdown */
232 /* These are needed in extensions.
233 How to protect PMSHAPI: it comes through EMX functions? */
234 {&rexx_handle, "RexxStart", 0},
235 {&rexx_handle, "RexxVariablePool", 0},
236 {&rexxapi_handle, "RexxRegisterFunctionExe", 0},
237 {&rexxapi_handle, "RexxDeregisterFunction", 0},
238 {&sesmgr_handle, "DOSSMSETTITLE", 0}, /* Would not work runtime-loaded */
239 {&pmshapi_handle, "PRF32QUERYPROFILESIZE", 0},
240 {&pmshapi_handle, "PRF32OPENPROFILE", 0},
241 {&pmshapi_handle, "PRF32CLOSEPROFILE", 0},
242 {&pmshapi_handle, "PRF32QUERYPROFILE", 0},
243 {&pmshapi_handle, "PRF32RESET", 0},
244 {&pmshapi_handle, "PRF32QUERYPROFILEDATA", 0},
245 {&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0},
247 /* At least some of these do not work by name, since they need
248 WIN32 instead of WIN... */
250 These were generated with
251 nm I:\emx\lib\os2.a | fgrep -f API-list | grep = > API-list-entries
252 perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( ORD_$1,)" API-list-entries > API-list-ORD_
253 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
255 {&pmshapi_handle, NULL, 123}, /* WinChangeSwitchEntry */
256 {&pmshapi_handle, NULL, 124}, /* WinQuerySwitchEntry */
257 {&pmshapi_handle, NULL, 125}, /* WinQuerySwitchHandle */
258 {&pmshapi_handle, NULL, 126}, /* WinQuerySwitchList */
259 {&pmshapi_handle, NULL, 131}, /* WinSwitchToProgram */
260 {&pmwin_handle, NULL, 702}, /* WinBeginEnumWindows */
261 {&pmwin_handle, NULL, 737}, /* WinEndEnumWindows */
262 {&pmwin_handle, NULL, 740}, /* WinEnumDlgItem */
263 {&pmwin_handle, NULL, 756}, /* WinGetNextWindow */
264 {&pmwin_handle, NULL, 768}, /* WinIsChild */
265 {&pmwin_handle, NULL, 799}, /* WinQueryActiveWindow */
266 {&pmwin_handle, NULL, 805}, /* WinQueryClassName */
267 {&pmwin_handle, NULL, 817}, /* WinQueryFocus */
268 {&pmwin_handle, NULL, 834}, /* WinQueryWindow */
269 {&pmwin_handle, NULL, 837}, /* WinQueryWindowPos */
270 {&pmwin_handle, NULL, 838}, /* WinQueryWindowProcess */
271 {&pmwin_handle, NULL, 841}, /* WinQueryWindowText */
272 {&pmwin_handle, NULL, 842}, /* WinQueryWindowTextLength */
273 {&pmwin_handle, NULL, 860}, /* WinSetFocus */
274 {&pmwin_handle, NULL, 875}, /* WinSetWindowPos */
275 {&pmwin_handle, NULL, 877}, /* WinSetWindowText */
276 {&pmwin_handle, NULL, 883}, /* WinShowWindow */
277 {&pmwin_handle, NULL, 872}, /* WinIsWindow */
278 {&pmwin_handle, NULL, 899}, /* WinWindowFromId */
279 {&pmwin_handle, NULL, 900}, /* WinWindowFromPoint */
280 {&pmwin_handle, NULL, 919}, /* WinPostMsg */
283 static PFN ExtFCN[C_ARR_LEN(loadOrdinals)]; /* Labeled by ord ORD_*. */
284 const Perl_PFN * const pExtFCN = ExtFCN;
285 struct PMWIN_entries_t PMWIN_entries;
288 loadModule(const char *modname, int fail)
290 HMODULE h = (HMODULE)dlopen(modname, 0);
293 Perl_croak_nocontext("Error loading module '%s': %s",
299 loadByOrdinal(enum entries_ordinals ord, int fail)
301 if (ExtFCN[ord] == NULL) {
305 if (!loadOrdinals[ord].dll->handle)
306 loadOrdinals[ord].dll->handle
307 = loadModule(loadOrdinals[ord].dll->modname, fail);
308 if (!loadOrdinals[ord].dll->handle)
309 return 0; /* Possible with FAIL==0 only */
310 if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle,
311 loadOrdinals[ord].entrypoint,
312 loadOrdinals[ord].entryname,&fcn))) {
313 char buf[20], *s = (char*)loadOrdinals[ord].entryname;
318 sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint);
319 Perl_croak_nocontext(
320 "This version of OS/2 does not support %s.%s",
321 loadOrdinals[ord].dll->modname, s);
325 if ((long)ExtFCN[ord] == -1)
326 Perl_croak_nocontext("panic queryaddr");
331 init_PMWIN_entries(void)
335 for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++)
336 ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1);
339 /*****************************************************/
340 /* socket forwarders without linking with tcpip DLLs */
342 DeclFuncByORD(struct hostent *, gethostent, ORD_GETHOSTENT, (void), ())
343 DeclFuncByORD(struct netent *, getnetent, ORD_GETNETENT, (void), ())
344 DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ())
345 DeclFuncByORD(struct servent *, getservent, ORD_GETSERVENT, (void), ())
347 DeclVoidFuncByORD(sethostent, ORD_SETHOSTENT, (int x), (x))
348 DeclVoidFuncByORD(setnetent, ORD_SETNETENT, (int x), (x))
349 DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x))
350 DeclVoidFuncByORD(setservent, ORD_SETSERVENT, (int x), (x))
352 DeclVoidFuncByORD(endhostent, ORD_ENDHOSTENT, (void), ())
353 DeclVoidFuncByORD(endnetent, ORD_ENDNETENT, (void), ())
354 DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ())
355 DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ())
358 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
360 #define QSS_INI_BUFFER 1024
362 ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
363 static int pidtid_lookup;
366 get_sysinfo(ULONG pid, ULONG flags)
369 ULONG rc, buf_len = QSS_INI_BUFFER;
372 if (!pidtid_lookup) {
374 *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0);
376 if (pDosVerifyPidTid) { /* Warp3 or later */
377 /* Up to some fixpak QuerySysState() kills the system if a non-existent
379 if (!pDosVerifyPidTid(pid, 1))
382 New(1322, pbuffer, buf_len, char);
383 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
384 rc = QuerySysState(flags, pid, pbuffer, buf_len);
385 while (rc == ERROR_BUFFER_OVERFLOW) {
386 Renew(pbuffer, buf_len *= 2, char);
387 rc = QuerySysState(flags, pid, pbuffer, buf_len);
394 psi = (PQTOPLEVEL)pbuffer;
395 if (psi && pid && pid != psi->procdata->pid) {
397 Perl_croak_nocontext("panic: wrong pid in sysinfo");
402 #define PRIO_ERR 0x1111
412 psi = get_sysinfo(pid, QSS_PROCESS);
415 prio = psi->procdata->threads->priority;
421 setpriority(int which, int pid, int val)
423 ULONG rc, prio = sys_prio(pid);
425 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
426 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
427 /* Do not change class. */
428 return CheckOSError(DosSetPriority((pid < 0)
429 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
431 (32 - val) % 32 - (prio & 0xFF),
434 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
435 /* Documentation claims one can change both class and basevalue,
436 * but I find it wrong. */
437 /* Change class, but since delta == 0 denotes absolute 0, correct. */
438 if (CheckOSError(DosSetPriority((pid < 0)
439 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
440 priors[(32 - val) >> 5] + 1,
444 if ( ((32 - val) % 32) == 0 ) return 0;
445 return CheckOSError(DosSetPriority((pid < 0)
446 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
455 getpriority(int which /* ignored */, int pid)
459 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
461 if (ret == PRIO_ERR) {
464 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
467 /*****************************************************************************/
470 /* There is no big sense to make it thread-specific, since signals
471 are delivered to thread 1 only. XXXX Maybe make it into an array? */
472 static int spawn_pid;
473 static int spawn_killed;
476 spawn_sighandler(int sig)
478 /* Some programs do not arrange for the keyboard signals to be
479 delivered to them. We need to deliver the signal manually. */
480 /* We may get a signal only if
481 a) kid does not receive keyboard signal: deliver it;
482 b) kid already died, and we get a signal. We may only hope
483 that the pid number was not reused.
487 sig = SIGKILL; /* Try harder. */
488 kill(spawn_pid, sig);
493 result(pTHX_ int flag, int pid)
496 Signal_t (*ihand)(); /* place to save signal during system() */
497 Signal_t (*qhand)(); /* place to save signal during system() */
503 if (pid < 0 || flag != 0)
509 ihand = rsignal(SIGINT, &spawn_sighandler);
510 qhand = rsignal(SIGQUIT, &spawn_sighandler);
512 r = wait4pid(pid, &status, 0);
513 } while (r == -1 && errno == EINTR);
514 rsignal(SIGINT, ihand);
515 rsignal(SIGQUIT, qhand);
517 PL_statusvalue = (U16)status;
520 return status & 0xFFFF;
522 ihand = rsignal(SIGINT, SIG_IGN);
523 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
524 rsignal(SIGINT, ihand);
525 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
528 return PL_statusvalue;
532 #define EXECF_SPAWN 0
534 #define EXECF_TRUEEXEC 2
535 #define EXECF_SPAWN_NOWAIT 3
536 #define EXECF_SPAWN_BYFLAG 4
538 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
547 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
548 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
551 return (pib->pib_ultype);
555 file_type(char *path)
560 if (!(_emx_env & 0x200))
561 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
562 if (CheckOSError(DosQueryAppType(path, &apptype))) {
564 case ERROR_FILE_NOT_FOUND:
565 case ERROR_PATH_NOT_FOUND:
567 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
569 default: /* Found, but not an
570 executable, or some other
578 static ULONG os2_mytype;
580 /* Spawn/exec a program, revert to shell if needed. */
581 /* global PL_Argv[] contains arguments. */
584 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
590 static char * fargs[4]
591 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
592 char **argsp = fargs;
595 int new_stderr = -1, nostderr = 0;
605 if (strEQ(PL_Argv[0],"/bin/sh"))
606 PL_Argv[0] = PL_sh_path;
608 if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
609 && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
610 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
611 ) /* will spawnvp use PATH? */
612 TAINT_ENV(); /* testing IFS here is overkill, probably */
613 /* We should check PERL_SH* and PERLLIB_* as well? */
614 if (!really || !*(tmps = SvPV(really, n_a)))
619 if (_emx_env & 0x200) { /* OS/2. */
620 int type = file_type(tmps);
622 if (type == -1) { /* Not found */
627 else if (type == -2) { /* Not an EXE */
632 else if (type == -3) { /* Is a directory? */
633 /* Special-case this */
635 int l = strlen(tmps);
637 if (l + 5 <= sizeof tbuf) {
639 strcpy(tbuf + l, ".exe");
640 type = file_type(tbuf);
650 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
651 case FAPPTYP_WINDOWAPI:
653 if (os2_mytype != 3) { /* not PM */
654 if (flag == P_NOWAIT)
656 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
657 Perl_warner(aTHX_ WARN_EXEC, "Starting PM process with flag=%d, mytype=%d",
662 case FAPPTYP_NOTWINDOWCOMPAT:
664 if (os2_mytype != 0) { /* not full screen */
665 if (flag == P_NOWAIT)
667 else if ((flag & 7) != P_SESSION)
668 Perl_warner(aTHX_ WARN_EXEC, "Starting Full Screen process with flag=%d, mytype=%d",
673 case FAPPTYP_NOTSPEC:
674 /* Let the shell handle this... */
676 buf = ""; /* Pacify a warning */
677 file = 0; /* Pacify a warning */
685 new_stderr = dup(2); /* Preserve stderr */
686 if (new_stderr == -1) {
694 fl_stderr = fcntl(2, F_GETFD);
698 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
702 rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv));
704 if (execf == EXECF_TRUEEXEC)
705 rc = execvp(tmps,PL_Argv);
706 else if (execf == EXECF_EXEC)
707 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
708 else if (execf == EXECF_SPAWN_NOWAIT)
709 rc = spawnvp(flag,tmps,PL_Argv);
710 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
711 rc = result(aTHX_ trueflag,
712 spawnvp(flag,tmps,PL_Argv));
714 if (rc < 0 && pass == 1
715 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
720 if (err == ENOENT || err == ENOEXEC) {
721 /* No such file, or is a script. */
722 /* Try adding script extensions to the file name, and
724 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
728 SV *scrsv = sv_2mortal(newSVpv(scr, 0));
729 SV *bufsv = sv_newmortal();
732 scr = SvPV(scrsv, n_a); /* free()ed later */
734 file = PerlIO_open(scr, "r");
739 buf = sv_gets(bufsv, file, 0 /* No append */);
741 buf = ""; /* XXX Needed? */
742 if (!buf[0]) { /* Empty... */
744 /* Special case: maybe from -Zexe build, so
745 there is an executable around (contrary to
746 documentation, DosQueryAppType sometimes (?)
747 does not append ".exe", so we could have
748 reached this place). */
749 sv_catpv(scrsv, ".exe");
750 scr = SvPV(scrsv, n_a); /* Reload */
751 if (PerlLIO_stat(scr,&PL_statbuf) >= 0
752 && !S_ISDIR(PL_statbuf.st_mode)) { /* Found */
756 } else { /* Restore */
757 SvCUR_set(scrsv, SvCUR(scrsv) - 4);
761 if (PerlIO_close(file) != 0) { /* Failure */
763 Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s",
764 scr, Strerror(errno));
765 buf = ""; /* Not #! */
771 } else if (buf[0] == 'e') {
772 if (strnEQ(buf, "extproc", 7)
775 } else if (buf[0] == 'E') {
776 if (strnEQ(buf, "EXTPROC", 7)
781 buf = ""; /* Not #! */
789 /* Do better than pdksh: allow a few args,
790 strip trailing whitespace. */
800 while (*s && !isSPACE(*s))
807 Perl_warner(aTHX_ WARN_EXEC, "Too many args on %.*s line of \"%s\"",
812 /* Can jump from far, buf/file invalid if force_shell: */
819 || (!buf[0] && file)) { /* File without magic */
820 /* In fact we tried all what pdksh would
821 try. There is no point in calling
822 pdksh, we may just emulate its logic. */
823 char *shell = getenv("EXECSHELL");
824 char *shell_opt = NULL;
830 shell = getenv("OS2_SHELL");
831 if (inicmd) { /* No spaces at start! */
833 while (*s && !isSPACE(*s)) {
835 inicmd = NULL; /* Cannot use */
843 /* Dosish shells will choke on slashes
844 in paths, fortunately, this is
845 important for zeroth arg only. */
852 /* If EXECSHELL is set, we do not set */
855 shell = ((_emx_env & 0x200)
858 nargs = shell_opt ? 2 : 1; /* shell file args */
859 exec_args[0] = shell;
860 exec_args[1] = shell_opt;
862 if (nargs == 2 && inicmd) {
863 /* Use the original cmd line */
864 /* XXXX This is good only until we refuse
865 quoted arguments... */
869 } else if (!buf[0] && inicmd) { /* No file */
870 /* Start with the original cmdline. */
871 /* XXXX This is good only until we refuse
872 quoted arguments... */
876 nargs = 2; /* shell -c */
879 while (a[1]) /* Get to the end */
881 a++; /* Copy finil NULL too */
882 while (a >= PL_Argv) {
883 *(a + nargs) = *a; /* PL_Argv was preallocated to be
888 PL_Argv[nargs] = argsp[nargs];
889 /* Enable pathless exec if #! (as pdksh). */
890 pass = (buf[0] == '#' ? 2 : 3);
894 /* Not found: restore errno */
898 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
899 char *no_dir = strrchr(PL_Argv[0], '/');
901 /* Do as pdksh port does: if not found with /, try without
904 PL_Argv[0] = no_dir + 1;
909 if (rc < 0 && ckWARN(WARN_EXEC))
910 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n",
911 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
913 PL_Argv[0], Strerror(errno));
914 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
915 && ((trueflag & 0xFF) == P_WAIT))
919 if (new_stderr != -1) { /* How can we use error codes? */
922 fcntl(2, F_SETFD, fl_stderr);
928 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
930 do_spawn3(pTHX_ char *cmd, int execf, int flag)
934 char *shell, *copt, *news = NULL;
935 int rc, seenspace = 0, mergestderr = 0;
938 if ((shell = getenv("EMXSHELL")) != NULL)
940 else if ((shell = getenv("SHELL")) != NULL)
942 else if ((shell = getenv("COMSPEC")) != NULL)
947 /* Consensus on perl5-porters is that it is _very_ important to
948 have a shell which will not change between computers with the
949 same architecture, to avoid "action on a distance".
950 And to have simple build, this shell should be sh. */
955 while (*cmd && isSPACE(*cmd))
958 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
959 STRLEN l = strlen(PL_sh_path);
961 New(1302, news, strlen(cmd) - 7 + l + 1, char);
962 strcpy(news, PL_sh_path);
963 strcpy(news + l, cmd + 7);
967 /* save an extra exec if possible */
968 /* see if there are shell metacharacters in it */
970 if (*cmd == '.' && isSPACE(cmd[1]))
973 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
976 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
980 for (s = cmd; *s; s++) {
981 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
982 if (*s == '\n' && s[1] == '\0') {
985 } else if (*s == '\\' && !seenspace) {
986 continue; /* Allow backslashes in names */
987 } else if (*s == '>' && s >= cmd + 3
988 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
989 && isSPACE(s[-2]) ) {
992 while (*t && isSPACE(*t))
997 break; /* Allow 2>&1 as the last thing */
1000 /* We do not convert this to do_spawn_ve since shell
1001 should be smart enough to start itself gloriously. */
1003 if (execf == EXECF_TRUEEXEC)
1004 rc = execl(shell,shell,copt,cmd,(char*)0);
1005 else if (execf == EXECF_EXEC)
1006 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
1007 else if (execf == EXECF_SPAWN_NOWAIT)
1008 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
1009 else if (execf == EXECF_SPAWN_BYFLAG)
1010 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
1012 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
1013 rc = result(aTHX_ P_WAIT,
1014 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
1015 if (rc < 0 && ckWARN(WARN_EXEC))
1016 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
1017 (execf == EXECF_SPAWN ? "spawn" : "exec"),
1018 shell, Strerror(errno));
1025 } else if (*s == ' ' || *s == '\t') {
1030 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
1031 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
1032 PL_Cmd = savepvn(cmd, s-cmd);
1034 for (s = PL_Cmd; *s;) {
1035 while (*s && isSPACE(*s)) s++;
1038 while (*s && !isSPACE(*s)) s++;
1044 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
1055 os2_do_aspawn(pTHX_ SV *really, register void **vmark, register void **vsp)
1057 register SV **mark = (SV **)vmark;
1058 register SV **sp = (SV **)vsp;
1061 int flag = P_WAIT, flag_set = 0;
1065 New(1301,PL_Argv, sp - mark + 3, char*);
1068 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
1070 flag = SvIVx(*mark);
1075 while (++mark <= sp) {
1077 *a++ = SvPVx(*mark, n_a);
1083 if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
1084 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
1086 rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0);
1094 os2_do_spawn(pTHX_ char *cmd)
1096 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
1100 do_spawn_nowait(pTHX_ char *cmd)
1102 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1106 Perl_do_exec(pTHX_ char *cmd)
1108 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1113 os2exec(pTHX_ char *cmd)
1115 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1119 my_syspopen(pTHX_ char *cmd, char *mode)
1123 register I32 this, that, newfd;
1126 int fh_fl = 0; /* Pacify the warning */
1128 /* `this' is what we use in the parent, `that' in the child. */
1129 this = (*mode == 'w');
1133 taint_proper("Insecure %s%s", "EXEC");
1137 /* Now we need to spawn the child. */
1138 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1139 int new = dup(p[this]);
1146 newfd = dup(*mode == 'r'); /* Preserve std* */
1148 /* This cannot happen due to fh being bad after pipe(), since
1149 pipe() should have created fh 0 and 1 even if they were
1150 initially closed. But we closed p[this] before. */
1151 if (errno != EBADF) {
1158 fh_fl = fcntl(*mode == 'r', F_GETFD);
1159 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1160 dup2(p[that], *mode == 'r');
1163 /* Where is `this' and newfd now? */
1164 fcntl(p[this], F_SETFD, FD_CLOEXEC);
1166 fcntl(newfd, F_SETFD, FD_CLOEXEC);
1167 pid = do_spawn_nowait(aTHX_ cmd);
1169 close(*mode == 'r'); /* It was closed initially */
1170 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1171 dup2(newfd, *mode == 'r'); /* Return std* back. */
1173 fcntl(*mode == 'r', F_SETFD, fh_fl);
1175 fcntl(*mode == 'r', F_SETFD, fh_fl);
1176 if (p[that] == (*mode == 'r'))
1182 if (p[that] < p[this]) { /* Make fh as small as possible */
1183 dup2(p[this], p[that]);
1187 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1188 (void)SvUPGRADE(sv,SVt_IV);
1190 PL_forkprocess = pid;
1191 return PerlIO_fdopen(p[this], mode);
1193 #else /* USE_POPEN */
1199 res = popen(cmd, mode);
1201 char *shell = getenv("EMXSHELL");
1203 my_setenv("EMXSHELL", PL_sh_path);
1204 res = popen(cmd, mode);
1205 my_setenv("EMXSHELL", shell);
1207 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1208 (void)SvUPGRADE(sv,SVt_IV);
1209 SvIVX(sv) = -1; /* A cooky. */
1212 #endif /* USE_POPEN */
1216 /******************************************************************/
1222 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1228 /*******************************************************************/
1229 /* not implemented in EMX 0.9d */
1231 char * ctermid(char *s) { return 0; }
1233 #ifdef MYTTYNAME /* was not in emx0.9a */
1234 void * ttyname(x) { return 0; }
1237 /*****************************************************************************/
1238 /* not implemented in C Set++ */
1241 int setuid(x) { errno = EINVAL; return -1; }
1242 int setgid(x) { errno = EINVAL; return -1; }
1245 /*****************************************************************************/
1246 /* stat() hack for char/block device */
1250 /* First attempt used DosQueryFSAttach which crashed the system when
1251 used with 5.001. Now just look for /dev/. */
1254 os2_stat(const char *name, struct stat *st)
1256 static int ino = SHRT_MAX;
1258 if (stricmp(name, "/dev/con") != 0
1259 && stricmp(name, "/dev/tty") != 0)
1260 return stat(name, st);
1262 memset(st, 0, sizeof *st);
1263 st->st_mode = S_IFCHR|0666;
1264 st->st_ino = (ino-- & 0x7FFF);
1271 #ifdef USE_PERL_SBRK
1273 /* SBRK() emulation, mostly moved to malloc.c. */
1276 sys_alloc(int size) {
1278 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1280 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1283 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1287 #endif /* USE_PERL_SBRK */
1291 char *tmppath = TMPPATH1;
1296 char *p = getenv("TMP"), *tpath;
1299 if (!p) p = getenv("TEMP");
1302 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1306 strcpy(tpath + len + 1, TMPPATH1);
1313 XS(XS_File__Copy_syscopy)
1316 if (items < 2 || items > 3)
1317 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1320 char * src = (char *)SvPV(ST(0),n_a);
1321 char * dst = (char *)SvPV(ST(1),n_a);
1328 flag = (unsigned long)SvIV(ST(2));
1331 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1332 ST(0) = sv_newmortal();
1333 sv_setiv(ST(0), (IV)RETVAL);
1338 #define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */
1339 #include "patchlevel.h"
1340 #undef PERL_PATCHLEVEL_H_IMPLICIT
1343 mod2fname(pTHX_ SV *sv)
1345 static char fname[9];
1346 int pos = 6, len, avlen;
1347 unsigned int sum = 0;
1351 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1353 if (SvTYPE(sv) != SVt_PVAV)
1354 Perl_croak_nocontext("Not array reference given to mod2fname");
1356 avlen = av_len((AV*)sv);
1358 Perl_croak_nocontext("Empty array reference given to mod2fname");
1360 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1361 strncpy(fname, s, 8);
1363 if (len < 6) pos = len;
1365 sum = 33 * sum + *(s++); /* Checksumming first chars to
1366 * get the capitalization into c.s. */
1369 while (avlen >= 0) {
1370 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1372 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1377 sum++; /* Avoid conflict of DLLs in memory. */
1379 /* We always load modules as *specific* DLLs, and with the full name.
1380 When loading a specific DLL by its full name, one cannot get a
1381 different DLL, even if a DLL with the same basename is loaded already.
1382 Thus there is no need to include the version into the mangling scheme. */
1384 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
1386 # ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
1387 # define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
1389 sum += COMPATIBLE_VERSION_SUM;
1391 fname[pos] = 'A' + (sum % 26);
1392 fname[pos + 1] = 'A' + (sum / 26 % 26);
1393 fname[pos + 2] = '\0';
1394 return (char *)fname;
1397 XS(XS_DynaLoader_mod2fname)
1401 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1406 RETVAL = mod2fname(aTHX_ sv);
1407 ST(0) = sv_newmortal();
1408 sv_setpv((SV*)ST(0), RETVAL);
1416 static char buf[300];
1419 int number = SvTRUE(get_sv("OS2::nsyserror", TRUE));
1421 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1425 sprintf(buf, "SYS%04d=%#x: ", rc, rc);
1426 s = buf + strlen(buf);
1429 if (DosGetMessage(NULL, 0, s, sizeof(buf) - 1 - (s-buf),
1430 rc, "OSO001.MSG", &len)) {
1432 sprintf(buf, "SYS%04d=%#x: ", rc, rc);
1433 s = buf + strlen(buf);
1435 sprintf(s, "[No description found in OSO001.MSG]");
1438 if (len && s[len - 1] == '\n')
1440 if (len && s[len - 1] == '\r')
1442 if (len && s[len - 1] == '.')
1444 if (len >= 10 && number && strnEQ(s, buf, 7)
1445 && s[7] == ':' && s[8] == ' ')
1446 /* Some messages start with SYSdddd:, some not */
1447 Move(s + 9, s, (len -= 9) + 1, char);
1455 char buf[300], *p, *o = PL_origargv[0], ok = 1;
1457 if (_execname(buf, sizeof buf) != 0)
1464 if (ok && *o != '/' && *o != '\\')
1466 } else if (ok && tolower(*o) != tolower(*p))
1471 if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */
1472 strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */
1486 perllib_mangle(char *s, unsigned int l)
1488 static char *newp, *oldp;
1489 static int newl, oldl, notfound;
1490 static char ret[STATIC_FILE_LENGTH+1];
1492 if (!newp && !notfound) {
1493 newp = getenv("PERLLIB_PREFIX");
1498 while (*newp && !isSPACE(*newp) && *newp != ';') {
1499 newp++; oldl++; /* Skip digits. */
1501 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1502 newp++; /* Skip whitespace. */
1504 newl = strlen(newp);
1505 if (newl == 0 || oldl == 0) {
1506 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1511 if (*s == '\\') *s = '/';
1524 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1527 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1528 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1530 strcpy(ret + newl, s + oldl);
1535 Perl_hab_GET() /* Needed if perl.h cannot be included */
1537 return perl_hab_GET();
1541 Perl_Register_MQ(int serve)
1546 if (Perl_os2_initial_mode++)
1548 DosGetInfoBlocks(&tib, &pib);
1549 Perl_os2_initial_mode = pib->pib_ultype;
1550 /* Try morphing into a PM application. */
1551 if (pib->pib_ultype != 3) /* 2 is VIO */
1552 pib->pib_ultype = 3; /* 3 is PM */
1553 init_PMWIN_entries();
1554 /* 64 messages if before OS/2 3.0, ignored otherwise */
1555 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1559 SAVEINT(cnt); /* Allow catch()ing. */
1561 _exit(188); /* Panic can try to create a window. */
1562 Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
1565 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
1566 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
1567 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
1569 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
1570 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1576 Perl_Serve_Messages(int force)
1581 if (Perl_hmq_servers > 0 && !force)
1583 if (Perl_hmq_refcnt <= 0)
1584 Perl_croak_nocontext("No message queue");
1585 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1587 if (msg.msg == WM_QUIT)
1588 Perl_croak_nocontext("QUITing...");
1589 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1595 Perl_Process_Messages(int force, I32 *cntp)
1599 if (Perl_hmq_servers > 0 && !force)
1601 if (Perl_hmq_refcnt <= 0)
1602 Perl_croak_nocontext("No message queue");
1603 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1606 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1607 if (msg.msg == WM_DESTROY)
1609 if (msg.msg == WM_CREATE)
1612 Perl_croak_nocontext("QUITing...");
1616 Perl_Deregister_MQ(int serve)
1623 if (--Perl_hmq_refcnt <= 0) {
1624 init_PMWIN_entries(); /* To be extra safe */
1625 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1627 /* Try morphing back from a PM application. */
1628 DosGetInfoBlocks(&tib, &pib);
1629 if (pib->pib_ultype == 3) /* 3 is PM */
1630 pib->pib_ultype = Perl_os2_initial_mode;
1632 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
1634 } else if (serve && Perl_hmq_servers <= 0) /* Last server exited */
1635 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1638 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1639 && ((path)[2] == '/' || (path)[2] == '\\'))
1640 #define sys_is_rooted _fnisabs
1641 #define sys_is_relative _fnisrel
1642 #define current_drive _getdrive
1644 #undef chdir /* Was _chdir2. */
1645 #define sys_chdir(p) (chdir(p) == 0)
1646 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1648 static int DOS_harderr_state = -1;
1654 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
1656 int arg1 = SvIV(ST(0));
1657 int arg2 = SvIV(ST(1));
1658 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1659 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1660 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1663 if (CheckOSError(DosError(a)))
1664 Perl_croak_nocontext("DosError(%d) failed", a);
1665 ST(0) = sv_newmortal();
1666 if (DOS_harderr_state >= 0)
1667 sv_setiv(ST(0), DOS_harderr_state);
1668 DOS_harderr_state = RETVAL;
1673 static signed char DOS_suppression_state = -1;
1675 XS(XS_OS2_Errors2Drive)
1679 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
1683 int suppress = SvOK(sv);
1684 char *s = suppress ? SvPV(sv, n_a) : NULL;
1685 char drive = (s ? *s : 0);
1688 if (suppress && !isALPHA(drive))
1689 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1690 if (CheckOSError(DosSuppressPopUps((suppress
1691 ? SPU_ENABLESUPPRESSION
1692 : SPU_DISABLESUPPRESSION),
1694 Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
1695 ST(0) = sv_newmortal();
1696 if (DOS_suppression_state > 0)
1697 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1698 else if (DOS_suppression_state == 0)
1699 sv_setpvn(ST(0), "", 0);
1700 DOS_suppression_state = drive;
1705 static const char * const si_fields[QSV_MAX] = {
1707 "MAX_TEXT_SESSIONS",
1711 "DYN_PRI_VARIATION",
1729 "FOREGROUND_FS_SESSION",
1730 "FOREGROUND_PROCESS"
1737 Perl_croak_nocontext("Usage: OS2::SysInfo()");
1739 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1740 APIRET rc = NO_ERROR; /* Return code */
1743 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1744 QSV_MAX, /* information */
1747 Perl_croak_nocontext("DosQuerySysInfo() failed");
1748 EXTEND(SP,2*QSV_MAX);
1749 while (i < QSV_MAX) {
1750 ST(j) = sv_newmortal();
1751 sv_setpv(ST(j++), si_fields[i]);
1752 ST(j) = sv_newmortal();
1753 sv_setiv(ST(j++), si[i]);
1757 XSRETURN(2 * QSV_MAX);
1760 XS(XS_OS2_BootDrive)
1764 Perl_croak_nocontext("Usage: OS2::BootDrive()");
1766 ULONG si[1] = {0}; /* System Information Data Buffer */
1767 APIRET rc = NO_ERROR; /* Return code */
1770 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1771 (PVOID)si, sizeof(si))))
1772 Perl_croak_nocontext("DosQuerySysInfo() failed");
1773 ST(0) = sv_newmortal();
1774 c = 'a' - 1 + si[0];
1775 sv_setpvn(ST(0), &c, 1);
1784 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
1786 bool serve = SvOK(ST(0));
1787 unsigned long pmq = perl_hmq_GET(serve);
1789 ST(0) = sv_newmortal();
1790 sv_setiv(ST(0), pmq);
1795 XS(XS_OS2_UnMorphPM)
1799 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
1801 bool serve = SvOK(ST(0));
1803 perl_hmq_UNSET(serve);
1808 XS(XS_OS2_Serve_Messages)
1812 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
1814 bool force = SvOK(ST(0));
1815 unsigned long cnt = Perl_Serve_Messages(force);
1817 ST(0) = sv_newmortal();
1818 sv_setiv(ST(0), cnt);
1823 XS(XS_OS2_Process_Messages)
1826 if (items < 1 || items > 2)
1827 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
1829 bool force = SvOK(ST(0));
1836 (void)SvIV(sv); /* Force SvIVX */
1838 Perl_croak_nocontext("Can't upgrade count to IV");
1840 cnt = Perl_Process_Messages(force, &cntr);
1843 cnt = Perl_Process_Messages(force, NULL);
1845 ST(0) = sv_newmortal();
1846 sv_setiv(ST(0), cnt);
1851 XS(XS_Cwd_current_drive)
1855 Perl_croak_nocontext("Usage: Cwd::current_drive()");
1859 RETVAL = current_drive();
1860 ST(0) = sv_newmortal();
1861 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1866 XS(XS_Cwd_sys_chdir)
1870 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
1873 char * path = (char *)SvPV(ST(0),n_a);
1876 RETVAL = sys_chdir(path);
1877 ST(0) = boolSV(RETVAL);
1878 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1883 XS(XS_Cwd_change_drive)
1887 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
1890 char d = (char)*SvPV(ST(0),n_a);
1893 RETVAL = change_drive(d);
1894 ST(0) = boolSV(RETVAL);
1895 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1900 XS(XS_Cwd_sys_is_absolute)
1904 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
1907 char * path = (char *)SvPV(ST(0),n_a);
1910 RETVAL = sys_is_absolute(path);
1911 ST(0) = boolSV(RETVAL);
1912 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1917 XS(XS_Cwd_sys_is_rooted)
1921 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
1924 char * path = (char *)SvPV(ST(0),n_a);
1927 RETVAL = sys_is_rooted(path);
1928 ST(0) = boolSV(RETVAL);
1929 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1934 XS(XS_Cwd_sys_is_relative)
1938 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
1941 char * path = (char *)SvPV(ST(0),n_a);
1944 RETVAL = sys_is_relative(path);
1945 ST(0) = boolSV(RETVAL);
1946 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1955 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
1959 RETVAL = _getcwd2(p, MAXPATHLEN);
1960 ST(0) = sv_newmortal();
1961 sv_setpv((SV*)ST(0), RETVAL);
1966 XS(XS_Cwd_sys_abspath)
1969 if (items < 1 || items > 2)
1970 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
1973 char * path = (char *)SvPV(ST(0),n_a);
1974 char * dir, *s, *t, *e;
1983 dir = (char *)SvPV(ST(1),n_a);
1985 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1989 if (_abspath(p, path, MAXPATHLEN) == 0) {
1995 /* Absolute with drive: */
1996 if ( sys_is_absolute(path) ) {
1997 if (_abspath(p, path, MAXPATHLEN) == 0) {
2002 } else if (path[0] == '/' || path[0] == '\\') {
2003 /* Rooted, but maybe on different drive. */
2004 if (isALPHA(dir[0]) && dir[1] == ':' ) {
2005 char p1[MAXPATHLEN];
2007 /* Need to prepend the drive. */
2010 Copy(path, p1 + 2, strlen(path) + 1, char);
2012 if (_abspath(p, p1, MAXPATHLEN) == 0) {
2017 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2023 /* Either path is relative, or starts with a drive letter. */
2024 /* If the path starts with a drive letter, then dir is
2026 a/b) it is absolute/x:relative on the same drive.
2027 c) path is on current drive, and dir is rooted
2028 In all the cases it is safe to drop the drive part
2030 if ( !sys_is_relative(path) ) {
2031 if ( ( ( sys_is_absolute(dir)
2032 || (isALPHA(dir[0]) && dir[1] == ':'
2033 && strnicmp(dir, path,1) == 0))
2034 && strnicmp(dir, path,1) == 0)
2035 || ( !(isALPHA(dir[0]) && dir[1] == ':')
2036 && toupper(path[0]) == current_drive())) {
2038 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2039 RETVAL = p; goto done;
2041 RETVAL = NULL; goto done;
2045 /* Need to prepend the absolute path of dir. */
2046 char p1[MAXPATHLEN];
2048 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
2051 if (p1[ l - 1 ] != '/') {
2055 Copy(path, p1 + l, strlen(path) + 1, char);
2056 if (_abspath(p, p1, MAXPATHLEN) == 0) {
2070 /* Backslashes are already converted to slashes. */
2071 /* Remove trailing slashes */
2073 while (l > 0 && RETVAL[l-1] == '/')
2075 ST(0) = sv_newmortal();
2076 sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
2077 /* Remove duplicate slashes, skipping the first three, which
2078 may be parts of a server-based path */
2079 s = t = 3 + SvPV_force(sv, n_a);
2081 /* Do not worry about multibyte chars here, this would contradict the
2082 eventual UTFization, and currently most other places break too... */
2084 if (s[0] == t[-1] && s[0] == '/')
2085 s++; /* Skip duplicate / */
2091 SvCUR_set(sv, t - SvPVX(sv));
2096 typedef APIRET (*PELP)(PSZ path, ULONG type);
2098 /* Kernels after 2000/09/15 understand this too: */
2099 #ifndef LIBPATHSTRICT
2100 # define LIBPATHSTRICT 3
2104 ExtLIBPATH(ULONG ord, PSZ path, IV type)
2107 PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */
2112 what = BEGIN_LIBPATH;
2114 what = LIBPATHSTRICT;
2115 return (*(PELP)f)(path, what);
2118 #define extLibpath(to,type) \
2119 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
2121 #define extLibpath_set(p,type) \
2122 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
2124 XS(XS_Cwd_extLibpath)
2127 if (items < 0 || items > 1)
2128 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
2141 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
2142 RETVAL = extLibpath(to, type);
2143 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
2144 Perl_croak_nocontext("panic Cwd::extLibpath parameter");
2145 ST(0) = sv_newmortal();
2146 sv_setpv((SV*)ST(0), RETVAL);
2151 XS(XS_Cwd_extLibpath_set)
2154 if (items < 1 || items > 2)
2155 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2158 char * s = (char *)SvPV(ST(0),n_a);
2169 RETVAL = extLibpath_set(s, type);
2170 ST(0) = boolSV(RETVAL);
2171 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2176 #define get_control87() _control87(0,0)
2177 #define set_control87 _control87
2179 XS(XS_OS2__control87)
2183 croak("Usage: OS2::_control87(new,mask)");
2185 unsigned new = (unsigned)SvIV(ST(0));
2186 unsigned mask = (unsigned)SvIV(ST(1));
2189 RETVAL = _control87(new, mask);
2190 ST(0) = sv_newmortal();
2191 sv_setiv(ST(0), (IV)RETVAL);
2196 XS(XS_OS2_get_control87)
2200 croak("Usage: OS2::get_control87()");
2204 RETVAL = get_control87();
2205 ST(0) = sv_newmortal();
2206 sv_setiv(ST(0), (IV)RETVAL);
2212 XS(XS_OS2_set_control87)
2215 if (items < 0 || items > 2)
2216 croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
2225 new = (unsigned)SvIV(ST(0));
2231 mask = (unsigned)SvIV(ST(1));
2234 RETVAL = set_control87(new, mask);
2235 ST(0) = sv_newmortal();
2236 sv_setiv(ST(0), (IV)RETVAL);
2244 char *file = __FILE__;
2248 if (_emx_env & 0x200) { /* OS/2 */
2249 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2250 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2251 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2253 newXS("OS2::Error", XS_OS2_Error, file);
2254 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2255 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2256 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2257 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2258 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2259 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2260 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2261 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2262 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2263 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2264 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2265 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2266 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2267 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2268 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2269 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2270 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
2271 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
2272 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
2273 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2276 sv_setiv(GvSV(gv), 1);
2278 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2280 sv_setiv(GvSV(gv), _emx_rev);
2281 sv_setpv(GvSV(gv), _emx_vprt);
2283 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2285 sv_setiv(GvSV(gv), _emx_env);
2286 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2288 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2289 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
2291 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
2296 OS2_Perl_data_t OS2_Perl_data;
2299 Perl_OS2_init(char **env)
2305 OS2_Perl_data.xs_init = &Xs_OS2_init;
2306 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2307 if (environ == NULL && env) {
2310 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2311 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2312 strcpy(PL_sh_path, SH_PATH);
2313 PL_sh_path[0] = shell[0];
2314 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2315 int l = strlen(shell), i;
2316 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2319 New(1304, PL_sh_path, l + 8, char);
2320 strncpy(PL_sh_path, shell, l);
2321 strcpy(PL_sh_path + l, "/sh.exe");
2322 for (i = 0; i < l; i++) {
2323 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2326 MUTEX_INIT(&start_thread_mutex);
2327 os2_mytype = my_type(); /* Do it before morphing. Needed? */
2328 /* Some DLLs reset FP flags on load. We may have been linked with them */
2329 _control87(MCW_EM, MCW_EM);
2336 my_tmpnam (char *str)
2338 char *p = getenv("TMP"), *tpath;
2340 if (!p) p = getenv("TEMP");
2341 tpath = tempnam(p, "pltmp");
2355 if (s.st_mode & S_IWOTH) {
2358 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2365 my_rmdir (__const__ char *s)
2367 char buf[MAXPATHLEN];
2368 STRLEN l = strlen(s);
2370 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX rmdir fails... */
2381 my_mkdir (__const__ char *s, long perm)
2383 char buf[MAXPATHLEN];
2384 STRLEN l = strlen(s);
2386 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
2391 return mkdir(s, perm);
2396 /* This code was contributed by Rocco Caputo. */
2398 my_flock(int handle, int o)
2400 FILELOCK rNull, rFull;
2401 ULONG timeout, handle_type, flag_word;
2403 int blocking, shared;
2404 static int use_my = -1;
2407 char *s = getenv("USE_PERL_FLOCK");
2413 if (!(_emx_env & 0x200) || !use_my)
2414 return flock(handle, o); /* Delegate to EMX. */
2417 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2418 (handle_type & 0xFF))
2423 // set lock/unlock ranges
2424 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2425 rFull.lRange = 0x7FFFFFFF;
2426 // set timeout for blocking
2427 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2428 // shared or exclusive?
2429 shared = (o & LOCK_SH) ? 1 : 0;
2430 // do not block the unlock
2431 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2432 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2437 case ERROR_INVALID_HANDLE:
2440 case ERROR_SHARING_BUFFER_EXCEEDED:
2443 case ERROR_LOCK_VIOLATION:
2444 break; // not an error
2445 case ERROR_INVALID_PARAMETER:
2446 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2447 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2450 case ERROR_INTERRUPT:
2459 if (o & (LOCK_SH | LOCK_EX)) {
2460 // for blocking operations
2474 case ERROR_INVALID_HANDLE:
2477 case ERROR_SHARING_BUFFER_EXCEEDED:
2480 case ERROR_LOCK_VIOLATION:
2482 errno = EWOULDBLOCK;
2486 case ERROR_INVALID_PARAMETER:
2487 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2488 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2491 case ERROR_INTERRUPT:
2498 // give away timeslice
2507 static int pwent_cnt;
2508 static int _my_pwent = -1;
2513 if (_my_pwent == -1) {
2514 char *s = getenv("USE_PERL_PWENT");
2516 _my_pwent = atoi(s);
2530 if (!use_my_pwent()) {
2531 setpwent(); /* Delegate to EMX. */
2540 if (!use_my_pwent()) {
2541 endpwent(); /* Delegate to EMX. */
2549 if (!use_my_pwent())
2550 return getpwent(); /* Delegate to EMX. */
2552 return 0; // Return one entry only
2556 static int grent_cnt;
2573 return 0; // Return one entry only
2580 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
2581 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
2583 static struct passwd *
2584 passw_wrap(struct passwd *p)
2586 static struct passwd pw;
2589 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
2592 s = getenv("PW_PASSWD");
2594 s = (char*)pw_p; /* Make match impossible */
2601 my_getpwuid (uid_t id)
2603 return passw_wrap(getpwuid(id));
2607 my_getpwnam (__const__ char *n)
2609 return passw_wrap(getpwnam(n));