3 #define INCL_DOSFILEMGR
6 /* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */
7 #define INCL_DOSPROCESS
8 #define SPU_DISABLESUPPRESSION 0
9 #define SPU_ENABLESUPPRESSION 1
12 #include <sys/uflags.h>
15 * Various Unix compatibility functions for OS/2
29 typedef void (*emx_startroutine)(void *);
30 typedef void* (*pthreads_startroutine)(void *);
39 const char *pthreads_states[] = {
50 enum pthreads_state state;
53 thread_join_t *thread_join_data;
54 int thread_join_count;
55 perl_mutex start_thread_mutex;
58 pthread_join(perl_os_thread tid, void **status)
60 MUTEX_LOCK(&start_thread_mutex);
61 switch (thread_join_data[tid].state) {
62 case pthreads_st_exited:
63 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
64 MUTEX_UNLOCK(&start_thread_mutex);
65 *status = thread_join_data[tid].status;
67 case pthreads_st_waited:
68 MUTEX_UNLOCK(&start_thread_mutex);
69 Perl_croak_nocontext("join with a thread with a waiter");
72 thread_join_data[tid].state = pthreads_st_waited;
73 COND_INIT(&thread_join_data[tid].cond);
74 MUTEX_UNLOCK(&start_thread_mutex);
75 COND_WAIT(&thread_join_data[tid].cond, NULL);
76 COND_DESTROY(&thread_join_data[tid].cond);
77 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
78 *status = thread_join_data[tid].status;
81 MUTEX_UNLOCK(&start_thread_mutex);
82 Perl_croak_nocontext("join: unknown thread state: '%s'",
83 pthreads_states[thread_join_data[tid].state]);
90 pthread_startit(void *arg)
92 /* Thread is already started, we need to transfer control only */
93 pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
94 int tid = pthread_self();
97 arg = ((void**)arg)[1];
98 if (tid >= thread_join_count) {
99 int oc = thread_join_count;
101 thread_join_count = tid + 5 + tid/5;
102 if (thread_join_data) {
103 Renew(thread_join_data, thread_join_count, thread_join_t);
104 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
106 Newz(1323, thread_join_data, thread_join_count, thread_join_t);
109 if (thread_join_data[tid].state != pthreads_st_none)
110 Perl_croak_nocontext("attempt to reuse thread id %i", tid);
111 thread_join_data[tid].state = pthreads_st_run;
112 /* Now that we copied/updated the guys, we may release the caller... */
113 MUTEX_UNLOCK(&start_thread_mutex);
114 thread_join_data[tid].status = (*start_routine)(arg);
115 switch (thread_join_data[tid].state) {
116 case pthreads_st_waited:
117 COND_SIGNAL(&thread_join_data[tid].cond);
120 thread_join_data[tid].state = pthreads_st_exited;
126 pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
127 void *(*start_routine)(void*), void *arg)
131 args[0] = (void*)start_routine;
134 MUTEX_LOCK(&start_thread_mutex);
135 *tid = _beginthread(pthread_startit, /*stack*/ NULL,
136 /*stacksize*/ 10*1024*1024, (void*)args);
137 MUTEX_LOCK(&start_thread_mutex);
138 MUTEX_UNLOCK(&start_thread_mutex);
139 return *tid ? 0 : EINVAL;
143 pthread_detach(perl_os_thread tid)
145 MUTEX_LOCK(&start_thread_mutex);
146 switch (thread_join_data[tid].state) {
147 case pthreads_st_waited:
148 MUTEX_UNLOCK(&start_thread_mutex);
149 Perl_croak_nocontext("detach on a thread with a waiter");
151 case pthreads_st_run:
152 thread_join_data[tid].state = pthreads_st_detached;
153 MUTEX_UNLOCK(&start_thread_mutex);
156 MUTEX_UNLOCK(&start_thread_mutex);
157 Perl_croak_nocontext("detach: unknown thread state: '%s'",
158 pthreads_states[thread_join_data[tid].state]);
164 /* This is a very bastardized version: */
166 os2_cond_wait(perl_cond *c, perl_mutex *m)
170 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
171 Perl_croak_nocontext("panic: COND_WAIT-reset: rc=%i", rc);
172 if (m) MUTEX_UNLOCK(m);
173 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
174 && (rc != ERROR_INTERRUPT))
175 Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc);
176 if (rc == ERROR_INTERRUPT)
178 if (m) MUTEX_LOCK(m);
182 /*****************************************************************************/
183 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
184 static PFN ExtFCN[2]; /* Labeled by ord below. */
185 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
186 #define ORD_QUERY_ELP 0
187 #define ORD_SET_ELP 1
188 struct PMWIN_entries_t PMWIN_entries;
191 loadByOrd(char *modname, ULONG ord)
193 if (ExtFCN[ord] == NULL) {
194 static HMODULE hdosc = 0;
199 if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
201 || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
202 Perl_croak_nocontext("This version of OS/2 does not support %s.%i",
203 modname, loadOrd[ord]);
206 if ((long)ExtFCN[ord] == -1)
207 Perl_croak_nocontext("panic queryaddr");
211 init_PMWIN_entries(void)
213 static HMODULE hpmwin = 0;
214 static const int ords[] = {
215 763, /* Initialize */
216 716, /* CreateMsgQueue */
217 726, /* DestroyMsgQueue */
220 912, /* DispatchMsg */
229 if (CheckOSError(DosLoadModule(buf, sizeof buf, "pmwin", &hpmwin)))
230 Perl_croak_nocontext("This version of OS/2 does not support pmwin: error in %s", buf);
232 if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
233 ((PFN*)&PMWIN_entries)+i)))
234 Perl_croak_nocontext("This version of OS/2 does not support pmwin.%d", ords[i]);
241 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
243 #define QSS_INI_BUFFER 1024
246 get_sysinfo(ULONG pid, ULONG flags)
249 ULONG rc, buf_len = QSS_INI_BUFFER;
251 New(1322, pbuffer, buf_len, char);
252 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
253 rc = QuerySysState(flags, pid, pbuffer, buf_len);
254 while (rc == ERROR_BUFFER_OVERFLOW) {
255 Renew(pbuffer, buf_len *= 2, char);
256 rc = QuerySysState(flags, pid, pbuffer, buf_len);
263 return (PQTOPLEVEL)pbuffer;
266 #define PRIO_ERR 0x1111
274 psi = get_sysinfo(pid, QSS_PROCESS);
278 if (pid != psi->procdata->pid) {
280 Perl_croak_nocontext("panic: wrong pid in sysinfo");
282 prio = psi->procdata->threads->priority;
288 setpriority(int which, int pid, int val)
293 prio = sys_prio(pid);
295 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
296 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
297 /* Do not change class. */
298 return CheckOSError(DosSetPriority((pid < 0)
299 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
301 (32 - val) % 32 - (prio & 0xFF),
304 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
305 /* Documentation claims one can change both class and basevalue,
306 * but I find it wrong. */
307 /* Change class, but since delta == 0 denotes absolute 0, correct. */
308 if (CheckOSError(DosSetPriority((pid < 0)
309 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
310 priors[(32 - val) >> 5] + 1,
314 if ( ((32 - val) % 32) == 0 ) return 0;
315 return CheckOSError(DosSetPriority((pid < 0)
316 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
322 /* else return CheckOSError(DosSetPriority((pid < 0) */
323 /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
324 /* priors[(32 - val) >> 5] + 1, */
325 /* (32 - val) % 32 - (prio & 0xFF), */
331 getpriority(int which /* ignored */, int pid)
337 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
338 /* DosGetInfoBlocks has old priority! */
339 /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
340 /* if (pid != pib->pib_ulpid) { */
342 if (ret == PRIO_ERR) {
346 /* ret = tib->tib_ptib2->tib2_ulpri; */
347 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
350 /*****************************************************************************/
353 /* There is no big sense to make it thread-specific, since signals
354 are delivered to thread 1 only. XXXX Maybe make it into an array? */
355 static int spawn_pid;
356 static int spawn_killed;
359 spawn_sighandler(int sig)
361 /* Some programs do not arrange for the keyboard signals to be
362 delivered to them. We need to deliver the signal manually. */
363 /* We may get a signal only if
364 a) kid does not receive keyboard signal: deliver it;
365 b) kid already died, and we get a signal. We may only hope
366 that the pid number was not reused.
370 sig = SIGKILL; /* Try harder. */
371 kill(spawn_pid, sig);
376 result(pTHX_ int flag, int pid)
380 Signal_t (*ihand)(); /* place to save signal during system() */
381 Signal_t (*qhand)(); /* place to save signal during system() */
387 if (pid < 0 || flag != 0)
393 ihand = rsignal(SIGINT, &spawn_sighandler);
394 qhand = rsignal(SIGQUIT, &spawn_sighandler);
396 r = wait4pid(pid, &status, 0);
397 } while (r == -1 && errno == EINTR);
398 rsignal(SIGINT, ihand);
399 rsignal(SIGQUIT, qhand);
401 PL_statusvalue = (U16)status;
404 return status & 0xFFFF;
406 ihand = rsignal(SIGINT, SIG_IGN);
407 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
408 rsignal(SIGINT, ihand);
409 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
412 return PL_statusvalue;
416 #define EXECF_SPAWN 0
418 #define EXECF_TRUEEXEC 2
419 #define EXECF_SPAWN_NOWAIT 3
420 #define EXECF_SPAWN_BYFLAG 4
422 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
431 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
432 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
435 return (pib->pib_ultype);
439 file_type(char *path)
444 if (!(_emx_env & 0x200))
445 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
446 if (CheckOSError(DosQueryAppType(path, &apptype))) {
448 case ERROR_FILE_NOT_FOUND:
449 case ERROR_PATH_NOT_FOUND:
451 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
453 default: /* Found, but not an
454 executable, or some other
462 static ULONG os2_mytype;
464 /* Spawn/exec a program, revert to shell if needed. */
465 /* global PL_Argv[] contains arguments. */
468 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
474 char buf[256], *s = 0, scrbuf[280];
476 static char * fargs[4]
477 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
478 char **argsp = fargs;
481 int new_stderr = -1, nostderr = 0, fl_stderr;
488 if (strEQ(PL_Argv[0],"/bin/sh"))
489 PL_Argv[0] = PL_sh_path;
491 if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
492 && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
493 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
494 ) /* will spawnvp use PATH? */
495 TAINT_ENV(); /* testing IFS here is overkill, probably */
496 /* We should check PERL_SH* and PERLLIB_* as well? */
497 if (!really || !*(tmps = SvPV(really, n_a)))
502 if (_emx_env & 0x200) { /* OS/2. */
503 int type = file_type(tmps);
505 if (type == -1) { /* Not found */
510 else if (type == -2) { /* Not an EXE */
515 else if (type == -3) { /* Is a directory? */
516 /* Special-case this */
518 int l = strlen(tmps);
520 if (l + 5 <= sizeof tbuf) {
522 strcpy(tbuf + l, ".exe");
523 type = file_type(tbuf);
533 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
534 case FAPPTYP_WINDOWAPI:
536 if (os2_mytype != 3) { /* not PM */
537 if (flag == P_NOWAIT)
539 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
540 Perl_warner(aTHX_ WARN_EXEC, "Starting PM process with flag=%d, mytype=%d",
545 case FAPPTYP_NOTWINDOWCOMPAT:
547 if (os2_mytype != 0) { /* not full screen */
548 if (flag == P_NOWAIT)
550 else if ((flag & 7) != P_SESSION)
551 Perl_warner(aTHX_ WARN_EXEC, "Starting Full Screen process with flag=%d, mytype=%d",
556 case FAPPTYP_NOTSPEC:
557 /* Let the shell handle this... */
566 new_stderr = dup(2); /* Preserve stderr */
567 if (new_stderr == -1) {
575 fl_stderr = fcntl(2, F_GETFD);
579 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
583 rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv));
585 if (execf == EXECF_TRUEEXEC)
586 rc = execvp(tmps,PL_Argv);
587 else if (execf == EXECF_EXEC)
588 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
589 else if (execf == EXECF_SPAWN_NOWAIT)
590 rc = spawnvp(flag,tmps,PL_Argv);
591 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
592 rc = result(aTHX_ trueflag,
593 spawnvp(flag,tmps,PL_Argv));
595 if (rc < 0 && pass == 1
596 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
601 if (err == ENOENT || err == ENOEXEC) {
602 /* No such file, or is a script. */
603 /* Try adding script extensions to the file name, and
605 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
614 if (l >= sizeof scrbuf) {
617 Perl_warner(aTHX_ WARN_EXEC, "Size of scriptname too big: %d", l);
625 file = fopen(scr, "r");
629 if (!fgets(buf, sizeof buf, file)) { /* Empty... */
633 /* Special case: maybe from -Zexe build, so
634 there is an executable around (contrary to
635 documentation, DosQueryAppType sometimes (?)
636 does not append ".exe", so we could have
637 reached this place). */
638 if (l + 5 < sizeof scrbuf) {
639 strcpy(scrbuf + l, ".exe");
640 if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
641 && !S_ISDIR(PL_statbuf.st_mode)) {
651 if (fclose(file) != 0) { /* Failure */
653 Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s",
654 scr, Strerror(errno));
655 buf[0] = 0; /* Not #! */
661 } else if (buf[0] == 'e') {
662 if (strnEQ(buf, "extproc", 7)
665 } else if (buf[0] == 'E') {
666 if (strnEQ(buf, "EXTPROC", 7)
671 buf[0] = 0; /* Not #! */
679 /* Do better than pdksh: allow a few args,
680 strip trailing whitespace. */
690 while (*s && !isSPACE(*s))
697 Perl_warner(aTHX_ WARN_EXEC, "Too many args on %.*s line of \"%s\"",
708 || (!buf[0] && file)) { /* File without magic */
709 /* In fact we tried all what pdksh would
710 try. There is no point in calling
711 pdksh, we may just emulate its logic. */
712 char *shell = getenv("EXECSHELL");
713 char *shell_opt = NULL;
719 shell = getenv("OS2_SHELL");
720 if (inicmd) { /* No spaces at start! */
722 while (*s && !isSPACE(*s)) {
724 inicmd = NULL; /* Cannot use */
732 /* Dosish shells will choke on slashes
733 in paths, fortunately, this is
734 important for zeroth arg only. */
741 /* If EXECSHELL is set, we do not set */
744 shell = ((_emx_env & 0x200)
747 nargs = shell_opt ? 2 : 1; /* shell file args */
748 exec_args[0] = shell;
749 exec_args[1] = shell_opt;
751 if (nargs == 2 && inicmd) {
752 /* Use the original cmd line */
753 /* XXXX This is good only until we refuse
754 quoted arguments... */
758 } else if (!buf[0] && inicmd) { /* No file */
759 /* Start with the original cmdline. */
760 /* XXXX This is good only until we refuse
761 quoted arguments... */
765 nargs = 2; /* shell -c */
768 while (a[1]) /* Get to the end */
770 a++; /* Copy finil NULL too */
771 while (a >= PL_Argv) {
772 *(a + nargs) = *a; /* PL_Argv was preallocated to be
777 PL_Argv[nargs] = argsp[nargs];
778 /* Enable pathless exec if #! (as pdksh). */
779 pass = (buf[0] == '#' ? 2 : 3);
783 /* Not found: restore errno */
787 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
788 char *no_dir = strrchr(PL_Argv[0], '/');
790 /* Do as pdksh port does: if not found with /, try without
793 PL_Argv[0] = no_dir + 1;
798 if (rc < 0 && ckWARN(WARN_EXEC))
799 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n",
800 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
802 PL_Argv[0], Strerror(errno));
803 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
804 && ((trueflag & 0xFF) == P_WAIT))
808 if (new_stderr != -1) { /* How can we use error codes? */
811 fcntl(2, F_SETFD, fl_stderr);
817 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
819 do_spawn3(pTHX_ char *cmd, int execf, int flag)
825 char *shell, *copt, *news = NULL;
826 int rc, err, seenspace = 0, mergestderr = 0;
827 char fullcmd[MAXNAMLEN + 1];
830 if ((shell = getenv("EMXSHELL")) != NULL)
832 else if ((shell = getenv("SHELL")) != NULL)
834 else if ((shell = getenv("COMSPEC")) != NULL)
839 /* Consensus on perl5-porters is that it is _very_ important to
840 have a shell which will not change between computers with the
841 same architecture, to avoid "action on a distance".
842 And to have simple build, this shell should be sh. */
847 while (*cmd && isSPACE(*cmd))
850 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
851 STRLEN l = strlen(PL_sh_path);
853 New(1302, news, strlen(cmd) - 7 + l + 1, char);
854 strcpy(news, PL_sh_path);
855 strcpy(news + l, cmd + 7);
859 /* save an extra exec if possible */
860 /* see if there are shell metacharacters in it */
862 if (*cmd == '.' && isSPACE(cmd[1]))
865 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
868 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
872 for (s = cmd; *s; s++) {
873 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
874 if (*s == '\n' && s[1] == '\0') {
877 } else if (*s == '\\' && !seenspace) {
878 continue; /* Allow backslashes in names */
879 } else if (*s == '>' && s >= cmd + 3
880 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
881 && isSPACE(s[-2]) ) {
884 while (*t && isSPACE(*t))
889 break; /* Allow 2>&1 as the last thing */
892 /* We do not convert this to do_spawn_ve since shell
893 should be smart enough to start itself gloriously. */
895 if (execf == EXECF_TRUEEXEC)
896 rc = execl(shell,shell,copt,cmd,(char*)0);
897 else if (execf == EXECF_EXEC)
898 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
899 else if (execf == EXECF_SPAWN_NOWAIT)
900 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
901 else if (execf == EXECF_SPAWN_BYFLAG)
902 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
904 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
905 rc = result(aTHX_ P_WAIT,
906 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
907 if (rc < 0 && ckWARN(WARN_EXEC))
908 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
909 (execf == EXECF_SPAWN ? "spawn" : "exec"),
910 shell, Strerror(errno));
917 } else if (*s == ' ' || *s == '\t') {
922 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
923 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
924 PL_Cmd = savepvn(cmd, s-cmd);
926 for (s = PL_Cmd; *s;) {
927 while (*s && isSPACE(*s)) s++;
930 while (*s && !isSPACE(*s)) s++;
936 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
947 os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp)
952 int flag = P_WAIT, flag_set = 0;
956 New(1301,PL_Argv, sp - mark + 3, char*);
959 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
966 while (++mark <= sp) {
968 *a++ = SvPVx(*mark, n_a);
974 if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
975 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
977 rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0);
985 os2_do_spawn(pTHX_ char *cmd)
988 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
992 do_spawn_nowait(pTHX_ char *cmd)
995 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
999 Perl_do_exec(pTHX_ char *cmd)
1002 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1007 os2exec(pTHX_ char *cmd)
1010 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1014 my_syspopen(pTHX_ char *cmd, char *mode)
1019 register I32 this, that, newfd;
1020 register I32 pid, rc;
1025 /* `this' is what we use in the parent, `that' in the child. */
1026 this = (*mode == 'w');
1030 taint_proper("Insecure %s%s", "EXEC");
1034 /* Now we need to spawn the child. */
1035 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1036 int new = dup(p[this]);
1043 newfd = dup(*mode == 'r'); /* Preserve std* */
1045 /* This cannot happen due to fh being bad after pipe(), since
1046 pipe() should have created fh 0 and 1 even if they were
1047 initially closed. But we closed p[this] before. */
1048 if (errno != EBADF) {
1055 fh_fl = fcntl(*mode == 'r', F_GETFD);
1056 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1057 dup2(p[that], *mode == 'r');
1060 /* Where is `this' and newfd now? */
1061 fcntl(p[this], F_SETFD, FD_CLOEXEC);
1063 fcntl(newfd, F_SETFD, FD_CLOEXEC);
1064 pid = do_spawn_nowait(aTHX_ cmd);
1066 close(*mode == 'r'); /* It was closed initially */
1067 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1068 dup2(newfd, *mode == 'r'); /* Return std* back. */
1070 fcntl(*mode == 'r', F_SETFD, fh_fl);
1072 fcntl(*mode == 'r', F_SETFD, fh_fl);
1073 if (p[that] == (*mode == 'r'))
1079 if (p[that] < p[this]) { /* Make fh as small as possible */
1080 dup2(p[this], p[that]);
1084 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1085 (void)SvUPGRADE(sv,SVt_IV);
1087 PL_forkprocess = pid;
1088 return PerlIO_fdopen(p[this], mode);
1090 #else /* USE_POPEN */
1096 res = popen(cmd, mode);
1098 char *shell = getenv("EMXSHELL");
1100 my_setenv("EMXSHELL", PL_sh_path);
1101 res = popen(cmd, mode);
1102 my_setenv("EMXSHELL", shell);
1104 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1105 (void)SvUPGRADE(sv,SVt_IV);
1106 SvIVX(sv) = -1; /* A cooky. */
1109 #endif /* USE_POPEN */
1113 /******************************************************************/
1119 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1125 /*******************************************************************/
1126 /* not implemented in EMX 0.9d */
1128 char * ctermid(char *s) { return 0; }
1130 #ifdef MYTTYNAME /* was not in emx0.9a */
1131 void * ttyname(x) { return 0; }
1134 /******************************************************************/
1135 /* my socket forwarders - EMX lib only provides static forwarders */
1137 static HMODULE htcp = 0;
1142 static BYTE buf[20];
1145 if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
1147 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1148 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1149 return (void *) ((void * (*)(void)) fcn) ();
1154 tcp1(char *name, int arg)
1156 static BYTE buf[20];
1159 if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
1161 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1162 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1163 ((void (*)(int)) fcn) (arg);
1166 void * gethostent() { return tcp0("GETHOSTENT"); }
1167 void * getnetent() { return tcp0("GETNETENT"); }
1168 void * getprotoent() { return tcp0("GETPROTOENT"); }
1169 void * getservent() { return tcp0("GETSERVENT"); }
1170 void sethostent(x) { tcp1("SETHOSTENT", x); }
1171 void setnetent(x) { tcp1("SETNETENT", x); }
1172 void setprotoent(x) { tcp1("SETPROTOENT", x); }
1173 void setservent(x) { tcp1("SETSERVENT", x); }
1174 void endhostent() { tcp0("ENDHOSTENT"); }
1175 void endnetent() { tcp0("ENDNETENT"); }
1176 void endprotoent() { tcp0("ENDPROTOENT"); }
1177 void endservent() { tcp0("ENDSERVENT"); }
1179 /*****************************************************************************/
1180 /* not implemented in C Set++ */
1183 int setuid(x) { errno = EINVAL; return -1; }
1184 int setgid(x) { errno = EINVAL; return -1; }
1187 /*****************************************************************************/
1188 /* stat() hack for char/block device */
1192 /* First attempt used DosQueryFSAttach which crashed the system when
1193 used with 5.001. Now just look for /dev/. */
1196 os2_stat(char *name, struct stat *st)
1198 static int ino = SHRT_MAX;
1200 if (stricmp(name, "/dev/con") != 0
1201 && stricmp(name, "/dev/tty") != 0)
1202 return stat(name, st);
1204 memset(st, 0, sizeof *st);
1205 st->st_mode = S_IFCHR|0666;
1206 st->st_ino = (ino-- & 0x7FFF);
1213 #ifdef USE_PERL_SBRK
1215 /* SBRK() emulation, mostly moved to malloc.c. */
1218 sys_alloc(int size) {
1220 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1222 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1225 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1229 #endif /* USE_PERL_SBRK */
1233 char *tmppath = TMPPATH1;
1238 char *p = getenv("TMP"), *tpath;
1241 if (!p) p = getenv("TEMP");
1244 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1248 strcpy(tpath + len + 1, TMPPATH1);
1255 XS(XS_File__Copy_syscopy)
1258 if (items < 2 || items > 3)
1259 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1262 char * src = (char *)SvPV(ST(0),n_a);
1263 char * dst = (char *)SvPV(ST(1),n_a);
1270 flag = (unsigned long)SvIV(ST(2));
1273 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1274 ST(0) = sv_newmortal();
1275 sv_setiv(ST(0), (IV)RETVAL);
1280 #include "patchlevel.h"
1283 mod2fname(pTHX_ SV *sv)
1285 static char fname[9];
1286 int pos = 6, len, avlen;
1287 unsigned int sum = 0;
1293 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1295 if (SvTYPE(sv) != SVt_PVAV)
1296 Perl_croak_nocontext("Not array reference given to mod2fname");
1298 avlen = av_len((AV*)sv);
1300 Perl_croak_nocontext("Empty array reference given to mod2fname");
1302 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1303 strncpy(fname, s, 8);
1305 if (len < 6) pos = len;
1307 sum = 33 * sum + *(s++); /* Checksumming first chars to
1308 * get the capitalization into c.s. */
1311 while (avlen >= 0) {
1312 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1314 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1319 sum++; /* Avoid conflict of DLLs in memory. */
1321 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* */
1322 fname[pos] = 'A' + (sum % 26);
1323 fname[pos + 1] = 'A' + (sum / 26 % 26);
1324 fname[pos + 2] = '\0';
1325 return (char *)fname;
1328 XS(XS_DynaLoader_mod2fname)
1332 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1337 RETVAL = mod2fname(aTHX_ sv);
1338 ST(0) = sv_newmortal();
1339 sv_setpv((SV*)ST(0), RETVAL);
1347 static char buf[300];
1350 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1353 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1354 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1357 if (len && buf[len - 1] == '\n')
1359 if (len && buf[len - 1] == '\r')
1361 if (len && buf[len - 1] == '.')
1373 if (_execname(buf, sizeof buf) != 0)
1374 return PL_origargv[0];
1387 perllib_mangle(char *s, unsigned int l)
1389 static char *newp, *oldp;
1390 static int newl, oldl, notfound;
1391 static char ret[STATIC_FILE_LENGTH+1];
1393 if (!newp && !notfound) {
1394 newp = getenv("PERLLIB_PREFIX");
1399 while (*newp && !isSPACE(*newp) && *newp != ';') {
1400 newp++; oldl++; /* Skip digits. */
1402 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1403 newp++; /* Skip whitespace. */
1405 newl = strlen(newp);
1406 if (newl == 0 || oldl == 0) {
1407 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1412 if (*s == '\\') *s = '/';
1425 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1428 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1429 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1431 strcpy(ret + newl, s + oldl);
1436 Perl_hab_GET() /* Needed if perl.h cannot be included */
1438 return perl_hab_GET();
1442 Perl_Register_MQ(int serve)
1447 if (Perl_os2_initial_mode++)
1449 DosGetInfoBlocks(&tib, &pib);
1450 Perl_os2_initial_mode = pib->pib_ultype;
1451 Perl_hmq_refcnt = 1;
1452 /* Try morphing into a PM application. */
1453 if (pib->pib_ultype != 3) /* 2 is VIO */
1454 pib->pib_ultype = 3; /* 3 is PM */
1455 init_PMWIN_entries();
1456 /* 64 messages if before OS/2 3.0, ignored otherwise */
1457 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1461 _exit(188); /* Panic can try to create a window. */
1462 Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
1468 Perl_Serve_Messages(int force)
1473 if (Perl_hmq_servers && !force)
1475 if (!Perl_hmq_refcnt)
1476 Perl_croak_nocontext("No message queue");
1477 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1479 if (msg.msg == WM_QUIT)
1480 Perl_croak_nocontext("QUITing...");
1481 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1487 Perl_Process_Messages(int force, I32 *cntp)
1491 if (Perl_hmq_servers && !force)
1493 if (!Perl_hmq_refcnt)
1494 Perl_croak_nocontext("No message queue");
1495 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1498 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1499 if (msg.msg == WM_DESTROY)
1501 if (msg.msg == WM_CREATE)
1504 Perl_croak_nocontext("QUITing...");
1508 Perl_Deregister_MQ(int serve)
1513 if (--Perl_hmq_refcnt == 0) {
1514 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1516 /* Try morphing back from a PM application. */
1517 if (pib->pib_ultype == 3) /* 3 is PM */
1518 pib->pib_ultype = Perl_os2_initial_mode;
1520 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
1525 extern void dlopen();
1526 void *fakedl = &dlopen; /* Pull in dynaloading part. */
1528 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1529 && ((path)[2] == '/' || (path)[2] == '\\'))
1530 #define sys_is_rooted _fnisabs
1531 #define sys_is_relative _fnisrel
1532 #define current_drive _getdrive
1534 #undef chdir /* Was _chdir2. */
1535 #define sys_chdir(p) (chdir(p) == 0)
1536 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1538 static int DOS_harderr_state = -1;
1544 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
1546 int arg1 = SvIV(ST(0));
1547 int arg2 = SvIV(ST(1));
1548 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1549 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1550 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1553 if (CheckOSError(DosError(a)))
1554 Perl_croak_nocontext("DosError(%d) failed", a);
1555 ST(0) = sv_newmortal();
1556 if (DOS_harderr_state >= 0)
1557 sv_setiv(ST(0), DOS_harderr_state);
1558 DOS_harderr_state = RETVAL;
1563 static signed char DOS_suppression_state = -1;
1565 XS(XS_OS2_Errors2Drive)
1569 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
1573 int suppress = SvOK(sv);
1574 char *s = suppress ? SvPV(sv, n_a) : NULL;
1575 char drive = (s ? *s : 0);
1578 if (suppress && !isALPHA(drive))
1579 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1580 if (CheckOSError(DosSuppressPopUps((suppress
1581 ? SPU_ENABLESUPPRESSION
1582 : SPU_DISABLESUPPRESSION),
1584 Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
1585 ST(0) = sv_newmortal();
1586 if (DOS_suppression_state > 0)
1587 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1588 else if (DOS_suppression_state == 0)
1589 sv_setpvn(ST(0), "", 0);
1590 DOS_suppression_state = drive;
1595 static const char * const si_fields[QSV_MAX] = {
1597 "MAX_TEXT_SESSIONS",
1601 "DYN_PRI_VARIATION",
1619 "FOREGROUND_FS_SESSION",
1620 "FOREGROUND_PROCESS"
1627 Perl_croak_nocontext("Usage: OS2::SysInfo()");
1629 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1630 APIRET rc = NO_ERROR; /* Return code */
1633 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1634 QSV_MAX, /* information */
1637 Perl_croak_nocontext("DosQuerySysInfo() failed");
1638 EXTEND(SP,2*QSV_MAX);
1639 while (i < QSV_MAX) {
1640 ST(j) = sv_newmortal();
1641 sv_setpv(ST(j++), si_fields[i]);
1642 ST(j) = sv_newmortal();
1643 sv_setiv(ST(j++), si[i]);
1647 XSRETURN(2 * QSV_MAX);
1650 XS(XS_OS2_BootDrive)
1654 Perl_croak_nocontext("Usage: OS2::BootDrive()");
1656 ULONG si[1] = {0}; /* System Information Data Buffer */
1657 APIRET rc = NO_ERROR; /* Return code */
1660 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1661 (PVOID)si, sizeof(si))))
1662 Perl_croak_nocontext("DosQuerySysInfo() failed");
1663 ST(0) = sv_newmortal();
1664 c = 'a' - 1 + si[0];
1665 sv_setpvn(ST(0), &c, 1);
1674 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
1676 bool serve = SvOK(ST(0));
1677 unsigned long pmq = perl_hmq_GET(serve);
1679 ST(0) = sv_newmortal();
1680 sv_setiv(ST(0), pmq);
1685 XS(XS_OS2_UnMorphPM)
1689 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
1691 bool serve = SvOK(ST(0));
1693 perl_hmq_UNSET(serve);
1698 XS(XS_OS2_Serve_Messages)
1702 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
1704 bool force = SvOK(ST(0));
1705 unsigned long cnt = Perl_Serve_Messages(force);
1707 ST(0) = sv_newmortal();
1708 sv_setiv(ST(0), cnt);
1713 XS(XS_OS2_Process_Messages)
1716 if (items < 1 || items > 2)
1717 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
1719 bool force = SvOK(ST(0));
1725 int fake = SvIV(sv); /* Force SvIVX */
1728 Perl_croak_nocontext("Can't upgrade count to IV");
1730 cnt = Perl_Process_Messages(force, &cntr);
1733 cnt = Perl_Process_Messages(force, NULL);
1735 ST(0) = sv_newmortal();
1736 sv_setiv(ST(0), cnt);
1741 XS(XS_Cwd_current_drive)
1745 Perl_croak_nocontext("Usage: Cwd::current_drive()");
1749 RETVAL = current_drive();
1750 ST(0) = sv_newmortal();
1751 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1756 XS(XS_Cwd_sys_chdir)
1760 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
1763 char * path = (char *)SvPV(ST(0),n_a);
1766 RETVAL = sys_chdir(path);
1767 ST(0) = boolSV(RETVAL);
1768 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1773 XS(XS_Cwd_change_drive)
1777 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
1780 char d = (char)*SvPV(ST(0),n_a);
1783 RETVAL = change_drive(d);
1784 ST(0) = boolSV(RETVAL);
1785 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1790 XS(XS_Cwd_sys_is_absolute)
1794 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
1797 char * path = (char *)SvPV(ST(0),n_a);
1800 RETVAL = sys_is_absolute(path);
1801 ST(0) = boolSV(RETVAL);
1802 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1807 XS(XS_Cwd_sys_is_rooted)
1811 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
1814 char * path = (char *)SvPV(ST(0),n_a);
1817 RETVAL = sys_is_rooted(path);
1818 ST(0) = boolSV(RETVAL);
1819 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1824 XS(XS_Cwd_sys_is_relative)
1828 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
1831 char * path = (char *)SvPV(ST(0),n_a);
1834 RETVAL = sys_is_relative(path);
1835 ST(0) = boolSV(RETVAL);
1836 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1845 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
1849 RETVAL = _getcwd2(p, MAXPATHLEN);
1850 ST(0) = sv_newmortal();
1851 sv_setpv((SV*)ST(0), RETVAL);
1856 XS(XS_Cwd_sys_abspath)
1859 if (items < 1 || items > 2)
1860 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
1863 char * path = (char *)SvPV(ST(0),n_a);
1871 dir = (char *)SvPV(ST(1),n_a);
1873 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1877 if (_abspath(p, path, MAXPATHLEN) == 0) {
1883 /* Absolute with drive: */
1884 if ( sys_is_absolute(path) ) {
1885 if (_abspath(p, path, MAXPATHLEN) == 0) {
1890 } else if (path[0] == '/' || path[0] == '\\') {
1891 /* Rooted, but maybe on different drive. */
1892 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1893 char p1[MAXPATHLEN];
1895 /* Need to prepend the drive. */
1898 Copy(path, p1 + 2, strlen(path) + 1, char);
1900 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1905 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1911 /* Either path is relative, or starts with a drive letter. */
1912 /* If the path starts with a drive letter, then dir is
1914 a/b) it is absolute/x:relative on the same drive.
1915 c) path is on current drive, and dir is rooted
1916 In all the cases it is safe to drop the drive part
1918 if ( !sys_is_relative(path) ) {
1921 if ( ( ( sys_is_absolute(dir)
1922 || (isALPHA(dir[0]) && dir[1] == ':'
1923 && strnicmp(dir, path,1) == 0))
1924 && strnicmp(dir, path,1) == 0)
1925 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1926 && toupper(path[0]) == current_drive())) {
1928 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1929 RETVAL = p; goto done;
1931 RETVAL = NULL; goto done;
1935 /* Need to prepend the absolute path of dir. */
1936 char p1[MAXPATHLEN];
1938 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1941 if (p1[ l - 1 ] != '/') {
1945 Copy(path, p1 + l, strlen(path) + 1, char);
1946 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1958 ST(0) = sv_newmortal();
1959 sv_setpv((SV*)ST(0), RETVAL);
1963 typedef APIRET (*PELP)(PSZ path, ULONG type);
1966 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1968 loadByOrd("doscalls",ord); /* Guarantied to load or die! */
1969 return (*(PELP)ExtFCN[ord])(path, type);
1972 #define extLibpath(type) \
1973 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1974 : BEGIN_LIBPATH))) \
1977 #define extLibpath_set(p,type) \
1978 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1981 XS(XS_Cwd_extLibpath)
1984 if (items < 0 || items > 1)
1985 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
1995 type = (int)SvIV(ST(0));
1998 RETVAL = extLibpath(type);
1999 ST(0) = sv_newmortal();
2000 sv_setpv((SV*)ST(0), RETVAL);
2005 XS(XS_Cwd_extLibpath_set)
2008 if (items < 1 || items > 2)
2009 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2012 char * s = (char *)SvPV(ST(0),n_a);
2020 type = (int)SvIV(ST(1));
2023 RETVAL = extLibpath_set(s, type);
2024 ST(0) = boolSV(RETVAL);
2025 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2033 char *file = __FILE__;
2037 if (_emx_env & 0x200) { /* OS/2 */
2038 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2039 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2040 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2042 newXS("OS2::Error", XS_OS2_Error, file);
2043 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2044 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2045 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2046 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2047 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2048 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2049 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2050 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2051 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2052 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2053 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2054 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2055 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2056 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2057 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2058 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2059 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2062 sv_setiv(GvSV(gv), 1);
2064 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2066 sv_setiv(GvSV(gv), _emx_rev);
2067 sv_setpv(GvSV(gv), _emx_vprt);
2069 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2071 sv_setiv(GvSV(gv), _emx_env);
2072 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2074 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2078 OS2_Perl_data_t OS2_Perl_data;
2081 Perl_OS2_init(char **env)
2087 OS2_Perl_data.xs_init = &Xs_OS2_init;
2088 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2089 if (environ == NULL && env) {
2092 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2093 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2094 strcpy(PL_sh_path, SH_PATH);
2095 PL_sh_path[0] = shell[0];
2096 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2097 int l = strlen(shell), i;
2098 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2101 New(1304, PL_sh_path, l + 8, char);
2102 strncpy(PL_sh_path, shell, l);
2103 strcpy(PL_sh_path + l, "/sh.exe");
2104 for (i = 0; i < l; i++) {
2105 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2108 MUTEX_INIT(&start_thread_mutex);
2109 os2_mytype = my_type(); /* Do it before morphing. Needed? */
2116 my_tmpnam (char *str)
2118 char *p = getenv("TMP"), *tpath;
2121 if (!p) p = getenv("TEMP");
2122 tpath = tempnam(p, "pltmp");
2136 if (s.st_mode & S_IWOTH) {
2139 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2145 /* This code was contributed by Rocco Caputo. */
2147 my_flock(int handle, int o)
2149 FILELOCK rNull, rFull;
2150 ULONG timeout, handle_type, flag_word;
2152 int blocking, shared;
2153 static int use_my = -1;
2156 char *s = getenv("USE_PERL_FLOCK");
2162 if (!(_emx_env & 0x200) || !use_my)
2163 return flock(handle, o); /* Delegate to EMX. */
2166 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2167 (handle_type & 0xFF))
2172 // set lock/unlock ranges
2173 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2174 rFull.lRange = 0x7FFFFFFF;
2175 // set timeout for blocking
2176 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2177 // shared or exclusive?
2178 shared = (o & LOCK_SH) ? 1 : 0;
2179 // do not block the unlock
2180 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2181 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2186 case ERROR_INVALID_HANDLE:
2189 case ERROR_SHARING_BUFFER_EXCEEDED:
2192 case ERROR_LOCK_VIOLATION:
2193 break; // not an error
2194 case ERROR_INVALID_PARAMETER:
2195 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2196 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2199 case ERROR_INTERRUPT:
2208 if (o & (LOCK_SH | LOCK_EX)) {
2209 // for blocking operations
2223 case ERROR_INVALID_HANDLE:
2226 case ERROR_SHARING_BUFFER_EXCEEDED:
2229 case ERROR_LOCK_VIOLATION:
2231 errno = EWOULDBLOCK;
2235 case ERROR_INVALID_PARAMETER:
2236 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2237 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2240 case ERROR_INTERRUPT:
2247 // give away timeslice