3 #define INCL_DOSFILEMGR
8 #include <sys/uflags.h>
11 * Various Unix compatibility functions for OS/2
25 typedef void (*emx_startroutine)(void *);
26 typedef void* (*pthreads_startroutine)(void *);
35 const char *pthreads_states[] = {
46 enum pthreads_state state;
49 thread_join_t *thread_join_data;
50 int thread_join_count;
51 perl_mutex start_thread_mutex;
54 pthread_join(perl_os_thread tid, void **status)
56 MUTEX_LOCK(&start_thread_mutex);
57 switch (thread_join_data[tid].state) {
58 case pthreads_st_exited:
59 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
60 MUTEX_UNLOCK(&start_thread_mutex);
61 *status = thread_join_data[tid].status;
63 case pthreads_st_waited:
64 MUTEX_UNLOCK(&start_thread_mutex);
65 croak("join with a thread with a waiter");
68 thread_join_data[tid].state = pthreads_st_waited;
69 COND_INIT(&thread_join_data[tid].cond);
70 MUTEX_UNLOCK(&start_thread_mutex);
71 COND_WAIT(&thread_join_data[tid].cond, NULL);
72 COND_DESTROY(&thread_join_data[tid].cond);
73 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
74 *status = thread_join_data[tid].status;
77 MUTEX_UNLOCK(&start_thread_mutex);
78 croak("join: unknown thread state: '%s'",
79 pthreads_states[thread_join_data[tid].state]);
86 pthread_startit(void *arg)
88 /* Thread is already started, we need to transfer control only */
89 pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
90 int tid = pthread_self();
93 arg = ((void**)arg)[1];
94 if (tid >= thread_join_count) {
95 int oc = thread_join_count;
97 thread_join_count = tid + 5 + tid/5;
98 if (thread_join_data) {
99 Renew(thread_join_data, thread_join_count, thread_join_t);
100 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
102 Newz(1323, thread_join_data, thread_join_count, thread_join_t);
105 if (thread_join_data[tid].state != pthreads_st_none)
106 croak("attempt to reuse thread id %i", tid);
107 thread_join_data[tid].state = pthreads_st_run;
108 /* Now that we copied/updated the guys, we may release the caller... */
109 MUTEX_UNLOCK(&start_thread_mutex);
110 thread_join_data[tid].status = (*start_routine)(arg);
111 switch (thread_join_data[tid].state) {
112 case pthreads_st_waited:
113 COND_SIGNAL(&thread_join_data[tid].cond);
116 thread_join_data[tid].state = pthreads_st_exited;
122 pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
123 void *(*start_routine)(void*), void *arg)
127 args[0] = (void*)start_routine;
130 MUTEX_LOCK(&start_thread_mutex);
131 *tid = _beginthread(pthread_startit, /*stack*/ NULL,
132 /*stacksize*/ 10*1024*1024, (void*)args);
133 MUTEX_LOCK(&start_thread_mutex);
134 MUTEX_UNLOCK(&start_thread_mutex);
135 return *tid ? 0 : EINVAL;
139 pthread_detach(perl_os_thread tid)
141 MUTEX_LOCK(&start_thread_mutex);
142 switch (thread_join_data[tid].state) {
143 case pthreads_st_waited:
144 MUTEX_UNLOCK(&start_thread_mutex);
145 croak("detach on a thread with a waiter");
147 case pthreads_st_run:
148 thread_join_data[tid].state = pthreads_st_detached;
149 MUTEX_UNLOCK(&start_thread_mutex);
152 MUTEX_UNLOCK(&start_thread_mutex);
153 croak("detach: unknown thread state: '%s'",
154 pthreads_states[thread_join_data[tid].state]);
160 /* This is a very bastardized version: */
162 os2_cond_wait(perl_cond *c, perl_mutex *m)
166 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
167 croak("panic: COND_WAIT-reset: rc=%i", rc);
168 if (m) MUTEX_UNLOCK(m);
169 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
170 && (rc != ERROR_INTERRUPT))
171 croak("panic: COND_WAIT: rc=%i", rc);
172 if (rc == ERROR_INTERRUPT)
174 if (m) MUTEX_LOCK(m);
178 /*****************************************************************************/
179 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
180 static PFN ExtFCN[2]; /* Labeled by ord below. */
181 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
182 #define ORD_QUERY_ELP 0
183 #define ORD_SET_ELP 1
184 struct PMWIN_entries_t PMWIN_entries;
187 loadByOrd(char *modname, ULONG ord)
189 if (ExtFCN[ord] == NULL) {
190 static HMODULE hdosc = 0;
195 if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
197 || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
198 croak("This version of OS/2 does not support %s.%i",
199 modname, loadOrd[ord]);
202 if ((long)ExtFCN[ord] == -1)
203 croak("panic queryaddr");
207 init_PMWIN_entries(void)
209 static HMODULE hpmwin = 0;
210 static const int ords[] = {
211 763, /* Initialize */
212 716, /* CreateMsgQueue */
213 726, /* DestroyMsgQueue */
216 912, /* DispatchMsg */
225 if (CheckOSError(DosLoadModule(buf, sizeof buf, "pmwin", &hpmwin)))
226 croak("This version of OS/2 does not support pmwin: error in %s", buf);
228 if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
229 ((PFN*)&PMWIN_entries)+i)))
230 croak("This version of OS/2 does not support pmwin.%d", ords[i]);
237 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
239 #define QSS_INI_BUFFER 1024
242 get_sysinfo(ULONG pid, ULONG flags)
245 ULONG rc, buf_len = QSS_INI_BUFFER;
247 New(1322, pbuffer, buf_len, char);
248 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
249 rc = QuerySysState(flags, pid, pbuffer, buf_len);
250 while (rc == ERROR_BUFFER_OVERFLOW) {
251 Renew(pbuffer, buf_len *= 2, char);
252 rc = QuerySysState(flags, pid, pbuffer, buf_len);
259 return (PQTOPLEVEL)pbuffer;
262 #define PRIO_ERR 0x1111
270 psi = get_sysinfo(pid, QSS_PROCESS);
274 if (pid != psi->procdata->pid) {
276 croak("panic: wrong pid in sysinfo");
278 prio = psi->procdata->threads->priority;
284 setpriority(int which, int pid, int val)
289 prio = sys_prio(pid);
291 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
292 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
293 /* Do not change class. */
294 return CheckOSError(DosSetPriority((pid < 0)
295 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
297 (32 - val) % 32 - (prio & 0xFF),
300 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
301 /* Documentation claims one can change both class and basevalue,
302 * but I find it wrong. */
303 /* Change class, but since delta == 0 denotes absolute 0, correct. */
304 if (CheckOSError(DosSetPriority((pid < 0)
305 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
306 priors[(32 - val) >> 5] + 1,
310 if ( ((32 - val) % 32) == 0 ) return 0;
311 return CheckOSError(DosSetPriority((pid < 0)
312 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
318 /* else return CheckOSError(DosSetPriority((pid < 0) */
319 /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
320 /* priors[(32 - val) >> 5] + 1, */
321 /* (32 - val) % 32 - (prio & 0xFF), */
327 getpriority(int which /* ignored */, int pid)
333 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
334 /* DosGetInfoBlocks has old priority! */
335 /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
336 /* if (pid != pib->pib_ulpid) { */
338 if (ret == PRIO_ERR) {
342 /* ret = tib->tib_ptib2->tib2_ulpri; */
343 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
346 /*****************************************************************************/
349 /* There is no big sense to make it thread-specific, since signals
350 are delivered to thread 1 only. XXXX Maybe make it into an array? */
351 static int spawn_pid;
352 static int spawn_killed;
355 spawn_sighandler(int sig)
357 /* Some programs do not arrange for the keyboard signals to be
358 delivered to them. We need to deliver the signal manually. */
359 /* We may get a signal only if
360 a) kid does not receive keyboard signal: deliver it;
361 b) kid already died, and we get a signal. We may only hope
362 that the pid number was not reused.
366 sig = SIGKILL; /* Try harder. */
367 kill(spawn_pid, sig);
372 result(int flag, int pid)
375 Signal_t (*ihand)(); /* place to save signal during system() */
376 Signal_t (*qhand)(); /* place to save signal during system() */
382 if (pid < 0 || flag != 0)
388 ihand = rsignal(SIGINT, &spawn_sighandler);
389 qhand = rsignal(SIGQUIT, &spawn_sighandler);
391 r = wait4pid(pid, &status, 0);
392 } while (r == -1 && errno == EINTR);
393 rsignal(SIGINT, ihand);
394 rsignal(SIGQUIT, qhand);
396 PL_statusvalue = (U16)status;
399 return status & 0xFFFF;
401 ihand = rsignal(SIGINT, SIG_IGN);
402 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
403 rsignal(SIGINT, ihand);
404 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
407 return PL_statusvalue;
411 #define EXECF_SPAWN 0
413 #define EXECF_TRUEEXEC 2
414 #define EXECF_SPAWN_NOWAIT 3
416 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
425 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
426 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
429 return (pib->pib_ultype);
433 file_type(char *path)
438 if (!(_emx_env & 0x200))
439 croak("file_type not implemented on DOS"); /* not OS/2. */
440 if (CheckOSError(DosQueryAppType(path, &apptype))) {
442 case ERROR_FILE_NOT_FOUND:
443 case ERROR_PATH_NOT_FOUND:
445 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
447 default: /* Found, but not an
448 executable, or some other
456 static ULONG os2_mytype;
458 /* Spawn/exec a program, revert to shell if needed. */
459 /* global PL_Argv[] contains arguments. */
462 do_spawn_ve(really, flag, execf, inicmd, addflag)
473 char buf[256], *s = 0, scrbuf[280];
475 static char * fargs[4]
476 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
477 char **argsp = fargs;
480 int new_stderr = -1, nostderr = 0, fl_stderr;
487 if (strEQ(PL_Argv[0],"/bin/sh"))
488 PL_Argv[0] = PL_sh_path;
490 if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
491 && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
492 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
493 ) /* will spawnvp use PATH? */
494 TAINT_ENV(); /* testing IFS here is overkill, probably */
495 /* We should check PERL_SH* and PERLLIB_* as well? */
496 if (!really || !*(tmps = SvPV(really, n_a)))
501 if (_emx_env & 0x200) { /* OS/2. */
502 int type = file_type(tmps);
504 if (type == -1) { /* Not found */
509 else if (type == -2) { /* Not an EXE */
514 else if (type == -3) { /* Is a directory? */
515 /* Special-case this */
517 int l = strlen(tmps);
519 if (l + 5 <= sizeof tbuf) {
521 strcpy(tbuf + l, ".exe");
522 type = file_type(tbuf);
532 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
533 case FAPPTYP_WINDOWAPI:
535 if (os2_mytype != 3) { /* not PM */
536 if (flag == P_NOWAIT)
538 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
539 warn("Starting PM process with flag=%d, mytype=%d",
544 case FAPPTYP_NOTWINDOWCOMPAT:
546 if (os2_mytype != 0) { /* not full screen */
547 if (flag == P_NOWAIT)
549 else if ((flag & 7) != P_SESSION)
550 warn("Starting Full Screen process with flag=%d, mytype=%d",
555 case FAPPTYP_NOTSPEC:
556 /* Let the shell handle this... */
565 new_stderr = dup(2); /* Preserve stderr */
566 if (new_stderr == -1) {
574 fl_stderr = fcntl(2, F_GETFD);
578 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
582 rc = result(trueflag, spawnvp(flag,tmps,PL_Argv));
584 if (execf == EXECF_TRUEEXEC)
585 rc = execvp(tmps,PL_Argv);
586 else if (execf == EXECF_EXEC)
587 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
588 else if (execf == EXECF_SPAWN_NOWAIT)
589 rc = spawnvp(flag,tmps,PL_Argv);
590 else /* EXECF_SPAWN */
591 rc = result(trueflag,
592 spawnvp(flag,tmps,PL_Argv));
594 if (rc < 0 && pass == 1
595 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
600 if (err == ENOENT || err == ENOEXEC) {
601 /* No such file, or is a script. */
602 /* Try adding script extensions to the file name, and
604 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
613 if (l >= sizeof scrbuf) {
616 warn("Size of scriptname too big: %d", l);
624 file = fopen(scr, "r");
628 if (!fgets(buf, sizeof buf, file)) { /* Empty... */
632 /* Special case: maybe from -Zexe build, so
633 there is an executable around (contrary to
634 documentation, DosQueryAppType sometimes (?)
635 does not append ".exe", so we could have
636 reached this place). */
637 if (l + 5 < sizeof scrbuf) {
638 strcpy(scrbuf + l, ".exe");
639 if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
640 && !S_ISDIR(PL_statbuf.st_mode)) {
650 if (fclose(file) != 0) { /* Failure */
652 warn("Error reading \"%s\": %s",
653 scr, Strerror(errno));
654 buf[0] = 0; /* Not #! */
660 } else if (buf[0] == 'e') {
661 if (strnEQ(buf, "extproc", 7)
664 } else if (buf[0] == 'E') {
665 if (strnEQ(buf, "EXTPROC", 7)
670 buf[0] = 0; /* Not #! */
678 /* Do better than pdksh: allow a few args,
679 strip trailing whitespace. */
689 while (*s && !isSPACE(*s))
696 warn("Too many args on %.*s line of \"%s\"",
707 || (!buf[0] && file)) { /* File without magic */
708 /* In fact we tried all what pdksh would
709 try. There is no point in calling
710 pdksh, we may just emulate its logic. */
711 char *shell = getenv("EXECSHELL");
712 char *shell_opt = NULL;
718 shell = getenv("OS2_SHELL");
719 if (inicmd) { /* No spaces at start! */
721 while (*s && !isSPACE(*s)) {
723 inicmd = NULL; /* Cannot use */
731 /* Dosish shells will choke on slashes
732 in paths, fortunately, this is
733 important for zeroth arg only. */
740 /* If EXECSHELL is set, we do not set */
743 shell = ((_emx_env & 0x200)
746 nargs = shell_opt ? 2 : 1; /* shell file args */
747 exec_args[0] = shell;
748 exec_args[1] = shell_opt;
750 if (nargs == 2 && inicmd) {
751 /* Use the original cmd line */
752 /* XXXX This is good only until we refuse
753 quoted arguments... */
757 } else if (!buf[0] && inicmd) { /* No file */
758 /* Start with the original cmdline. */
759 /* XXXX This is good only until we refuse
760 quoted arguments... */
764 nargs = 2; /* shell -c */
767 while (a[1]) /* Get to the end */
769 a++; /* Copy finil NULL too */
770 while (a >= PL_Argv) {
771 *(a + nargs) = *a; /* PL_Argv was preallocated to be
776 PL_Argv[nargs] = argsp[nargs];
777 /* Enable pathless exec if #! (as pdksh). */
778 pass = (buf[0] == '#' ? 2 : 3);
782 /* Not found: restore errno */
786 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
787 char *no_dir = strrchr(PL_Argv[0], '/');
789 /* Do as pdksh port does: if not found with /, try without
792 PL_Argv[0] = no_dir + 1;
797 if (rc < 0 && PL_dowarn)
798 warn("Can't %s \"%s\": %s\n",
799 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
801 PL_Argv[0], Strerror(errno));
802 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
803 && ((trueflag & 0xFF) == P_WAIT))
804 rc = 255 << 8; /* Emulate the fork(). */
807 if (new_stderr != -1) { /* How can we use error codes? */
810 fcntl(2, F_SETFD, fl_stderr);
818 do_aspawn(really,mark,sp)
827 int flag = P_WAIT, trueflag, err, secondtry = 0;
831 New(1301,PL_Argv, sp - mark + 3, char*);
834 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
839 while (++mark <= sp) {
841 *a++ = SvPVx(*mark, n_a);
847 rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL, 0);
854 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
856 do_spawn2(cmd, execf)
863 char *shell, *copt, *news = NULL;
864 int rc, err, seenspace = 0, mergestderr = 0;
865 char fullcmd[MAXNAMLEN + 1];
868 if ((shell = getenv("EMXSHELL")) != NULL)
870 else if ((shell = getenv("SHELL")) != NULL)
872 else if ((shell = getenv("COMSPEC")) != NULL)
877 /* Consensus on perl5-porters is that it is _very_ important to
878 have a shell which will not change between computers with the
879 same architecture, to avoid "action on a distance".
880 And to have simple build, this shell should be sh. */
885 while (*cmd && isSPACE(*cmd))
888 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
889 STRLEN l = strlen(PL_sh_path);
891 New(1302, news, strlen(cmd) - 7 + l + 1, char);
892 strcpy(news, PL_sh_path);
893 strcpy(news + l, cmd + 7);
897 /* save an extra exec if possible */
898 /* see if there are shell metacharacters in it */
900 if (*cmd == '.' && isSPACE(cmd[1]))
903 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
906 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
910 for (s = cmd; *s; s++) {
911 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
912 if (*s == '\n' && s[1] == '\0') {
915 } else if (*s == '\\' && !seenspace) {
916 continue; /* Allow backslashes in names */
917 } else if (*s == '>' && s >= cmd + 3
918 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
919 && isSPACE(s[-2]) ) {
922 while (*t && isSPACE(*t))
927 break; /* Allow 2>&1 as the last thing */
930 /* We do not convert this to do_spawn_ve since shell
931 should be smart enough to start itself gloriously. */
933 if (execf == EXECF_TRUEEXEC)
934 rc = execl(shell,shell,copt,cmd,(char*)0);
935 else if (execf == EXECF_EXEC)
936 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
937 else if (execf == EXECF_SPAWN_NOWAIT)
938 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
940 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
942 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
943 if (rc < 0 && PL_dowarn)
944 warn("Can't %s \"%s\": %s",
945 (execf == EXECF_SPAWN ? "spawn" : "exec"),
946 shell, Strerror(errno));
947 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
952 } else if (*s == ' ' || *s == '\t') {
957 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
958 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
959 PL_Cmd = savepvn(cmd, s-cmd);
961 for (s = PL_Cmd; *s;) {
962 while (*s && isSPACE(*s)) s++;
965 while (*s && !isSPACE(*s)) s++;
971 rc = do_spawn_ve(NULL, 0, execf, cmd, mergestderr);
984 return do_spawn2(cmd, EXECF_SPAWN);
991 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
998 do_spawn2(cmd, EXECF_EXEC);
1006 return do_spawn2(cmd, EXECF_TRUEEXEC);
1010 my_syspopen(cmd,mode)
1017 register I32 this, that, newfd;
1018 register I32 pid, rc;
1023 /* `this' is what we use in the parent, `that' in the child. */
1024 this = (*mode == 'w');
1028 taint_proper("Insecure %s%s", "EXEC");
1032 /* Now we need to spawn the child. */
1033 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1034 int new = dup(p[this]);
1041 newfd = dup(*mode == 'r'); /* Preserve std* */
1043 /* This cannot happen due to fh being bad after pipe(), since
1044 pipe() should have created fh 0 and 1 even if they were
1045 initially closed. But we closed p[this] before. */
1046 if (errno != EBADF) {
1053 fh_fl = fcntl(*mode == 'r', F_GETFD);
1054 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1055 dup2(p[that], *mode == 'r');
1058 /* Where is `this' and newfd now? */
1059 fcntl(p[this], F_SETFD, FD_CLOEXEC);
1061 fcntl(newfd, F_SETFD, FD_CLOEXEC);
1062 pid = do_spawn_nowait(cmd);
1064 close(*mode == 'r'); /* It was closed initially */
1065 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1066 dup2(newfd, *mode == 'r'); /* Return std* back. */
1068 fcntl(*mode == 'r', F_SETFD, fh_fl);
1070 fcntl(*mode == 'r', F_SETFD, fh_fl);
1071 if (p[that] == (*mode == 'r'))
1077 if (p[that] < p[this]) { /* Make fh as small as possible */
1078 dup2(p[this], p[that]);
1082 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1083 (void)SvUPGRADE(sv,SVt_IV);
1085 PL_forkprocess = pid;
1086 return PerlIO_fdopen(p[this], mode);
1088 #else /* USE_POPEN */
1094 res = popen(cmd, mode);
1096 char *shell = getenv("EMXSHELL");
1098 my_setenv("EMXSHELL", PL_sh_path);
1099 res = popen(cmd, mode);
1100 my_setenv("EMXSHELL", shell);
1102 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1103 (void)SvUPGRADE(sv,SVt_IV);
1104 SvIVX(sv) = -1; /* A cooky. */
1107 #endif /* USE_POPEN */
1111 /******************************************************************/
1117 croak(PL_no_func, "Unsupported function fork");
1123 /*******************************************************************/
1124 /* not implemented in EMX 0.9a */
1126 void * ctermid(x) { return 0; }
1128 #ifdef MYTTYNAME /* was not in emx0.9a */
1129 void * ttyname(x) { return 0; }
1132 /******************************************************************/
1133 /* my socket forwarders - EMX lib only provides static forwarders */
1135 static HMODULE htcp = 0;
1140 static BYTE buf[20];
1143 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1145 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1146 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1147 return (void *) ((void * (*)(void)) fcn) ();
1152 tcp1(char *name, int arg)
1154 static BYTE buf[20];
1157 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1159 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1160 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1161 ((void (*)(int)) fcn) (arg);
1164 void * gethostent() { return tcp0("GETHOSTENT"); }
1165 void * getnetent() { return tcp0("GETNETENT"); }
1166 void * getprotoent() { return tcp0("GETPROTOENT"); }
1167 void * getservent() { return tcp0("GETSERVENT"); }
1168 void sethostent(x) { tcp1("SETHOSTENT", x); }
1169 void setnetent(x) { tcp1("SETNETENT", x); }
1170 void setprotoent(x) { tcp1("SETPROTOENT", x); }
1171 void setservent(x) { tcp1("SETSERVENT", x); }
1172 void endhostent() { tcp0("ENDHOSTENT"); }
1173 void endnetent() { tcp0("ENDNETENT"); }
1174 void endprotoent() { tcp0("ENDPROTOENT"); }
1175 void endservent() { tcp0("ENDSERVENT"); }
1177 /*****************************************************************************/
1178 /* not implemented in C Set++ */
1181 int setuid(x) { errno = EINVAL; return -1; }
1182 int setgid(x) { errno = EINVAL; return -1; }
1185 /*****************************************************************************/
1186 /* stat() hack for char/block device */
1190 /* First attempt used DosQueryFSAttach which crashed the system when
1191 used with 5.001. Now just look for /dev/. */
1194 os2_stat(char *name, struct stat *st)
1196 static int ino = SHRT_MAX;
1198 if (stricmp(name, "/dev/con") != 0
1199 && stricmp(name, "/dev/tty") != 0)
1200 return stat(name, st);
1202 memset(st, 0, sizeof *st);
1203 st->st_mode = S_IFCHR|0666;
1204 st->st_ino = (ino-- & 0x7FFF);
1211 #ifdef USE_PERL_SBRK
1213 /* SBRK() emulation, mostly moved to malloc.c. */
1216 sys_alloc(int size) {
1218 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1220 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1223 croak("Got an error from DosAllocMem: %li", (long)rc);
1227 #endif /* USE_PERL_SBRK */
1231 char *tmppath = TMPPATH1;
1236 char *p = getenv("TMP"), *tpath;
1239 if (!p) p = getenv("TEMP");
1242 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1246 strcpy(tpath + len + 1, TMPPATH1);
1253 XS(XS_File__Copy_syscopy)
1256 if (items < 2 || items > 3)
1257 croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
1260 char * src = (char *)SvPV(ST(0),n_a);
1261 char * dst = (char *)SvPV(ST(1),n_a);
1268 flag = (unsigned long)SvIV(ST(2));
1271 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1272 ST(0) = sv_newmortal();
1273 sv_setiv(ST(0), (IV)RETVAL);
1278 #include "patchlevel.h"
1284 static char fname[9];
1285 int pos = 6, len, avlen;
1286 unsigned int sum = 0;
1292 if (!SvROK(sv)) croak("Not a reference given to mod2fname");
1294 if (SvTYPE(sv) != SVt_PVAV)
1295 croak("Not array reference given to mod2fname");
1297 avlen = av_len((AV*)sv);
1299 croak("Empty array reference given to mod2fname");
1301 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1302 strncpy(fname, s, 8);
1304 if (len < 6) pos = len;
1306 sum = 33 * sum + *(s++); /* Checksumming first chars to
1307 * get the capitalization into c.s. */
1310 while (avlen >= 0) {
1311 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1313 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1318 sum++; /* Avoid conflict of DLLs in memory. */
1320 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* */
1321 fname[pos] = 'A' + (sum % 26);
1322 fname[pos + 1] = 'A' + (sum / 26 % 26);
1323 fname[pos + 2] = '\0';
1324 return (char *)fname;
1327 XS(XS_DynaLoader_mod2fname)
1331 croak("Usage: DynaLoader::mod2fname(sv)");
1336 RETVAL = mod2fname(sv);
1337 ST(0) = sv_newmortal();
1338 sv_setpv((SV*)ST(0), RETVAL);
1346 static char buf[300];
1349 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1352 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1353 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1356 if (len > 0 && buf[len - 1] == '\n')
1357 buf[len - 1] = '\0';
1358 if (len > 1 && buf[len - 2] == '\r')
1359 buf[len - 2] = '\0';
1360 if (len > 2 && buf[len - 3] == '.')
1361 buf[len - 3] = '\0';
1366 perllib_mangle(char *s, unsigned int l)
1368 static char *newp, *oldp;
1369 static int newl, oldl, notfound;
1370 static char ret[STATIC_FILE_LENGTH+1];
1372 if (!newp && !notfound) {
1373 newp = getenv("PERLLIB_PREFIX");
1378 while (*newp && !isSPACE(*newp) && *newp != ';') {
1379 newp++; oldl++; /* Skip digits. */
1381 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1382 newp++; /* Skip whitespace. */
1384 newl = strlen(newp);
1385 if (newl == 0 || oldl == 0) {
1386 croak("Malformed PERLLIB_PREFIX");
1391 if (*s == '\\') *s = '/';
1404 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1407 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1408 croak("Malformed PERLLIB_PREFIX");
1410 strcpy(ret + newl, s + oldl);
1415 Perl_hab_GET() /* Needed if perl.h cannot be included */
1417 return perl_hab_GET();
1421 Perl_Register_MQ(int serve)
1426 if (Perl_os2_initial_mode++)
1428 DosGetInfoBlocks(&tib, &pib);
1429 Perl_os2_initial_mode = pib->pib_ultype;
1430 Perl_hmq_refcnt = 1;
1431 /* Try morphing into a PM application. */
1432 if (pib->pib_ultype != 3) /* 2 is VIO */
1433 pib->pib_ultype = 3; /* 3 is PM */
1434 init_PMWIN_entries();
1435 /* 64 messages if before OS/2 3.0, ignored otherwise */
1436 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1440 _exit(188); /* Panic can try to create a window. */
1441 croak("Cannot create a message queue, or morph to a PM application");
1447 Perl_Serve_Messages(int force)
1452 if (Perl_hmq_servers && !force)
1454 if (!Perl_hmq_refcnt)
1455 croak("No message queue");
1456 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1458 if (msg.msg == WM_QUIT)
1459 croak("QUITing...");
1460 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1466 Perl_Process_Messages(int force, I32 *cntp)
1470 if (Perl_hmq_servers && !force)
1472 if (!Perl_hmq_refcnt)
1473 croak("No message queue");
1474 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1477 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1478 if (msg.msg == WM_DESTROY)
1480 if (msg.msg == WM_CREATE)
1483 croak("QUITing...");
1487 Perl_Deregister_MQ(int serve)
1492 if (--Perl_hmq_refcnt == 0) {
1493 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1495 /* Try morphing back from a PM application. */
1496 if (pib->pib_ultype == 3) /* 3 is PM */
1497 pib->pib_ultype = Perl_os2_initial_mode;
1499 warn("Unexpected program mode %d when morphing back from PM",
1504 extern void dlopen();
1505 void *fakedl = &dlopen; /* Pull in dynaloading part. */
1507 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1508 && ((path)[2] == '/' || (path)[2] == '\\'))
1509 #define sys_is_rooted _fnisabs
1510 #define sys_is_relative _fnisrel
1511 #define current_drive _getdrive
1513 #undef chdir /* Was _chdir2. */
1514 #define sys_chdir(p) (chdir(p) == 0)
1515 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1517 static int DOS_harderr_state = -1;
1523 croak("Usage: OS2::Error(harderr, exception)");
1525 int arg1 = SvIV(ST(0));
1526 int arg2 = SvIV(ST(1));
1527 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1528 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1529 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1532 if (CheckOSError(DosError(a)))
1533 croak("DosError(%d) failed", a);
1534 ST(0) = sv_newmortal();
1535 if (DOS_harderr_state >= 0)
1536 sv_setiv(ST(0), DOS_harderr_state);
1537 DOS_harderr_state = RETVAL;
1542 static signed char DOS_suppression_state = -1;
1544 XS(XS_OS2_Errors2Drive)
1548 croak("Usage: OS2::Errors2Drive(drive)");
1552 int suppress = SvOK(sv);
1553 char *s = suppress ? SvPV(sv, n_a) : NULL;
1554 char drive = (s ? *s : 0);
1557 if (suppress && !isALPHA(drive))
1558 croak("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1559 if (CheckOSError(DosSuppressPopUps((suppress
1560 ? SPU_ENABLESUPPRESSION
1561 : SPU_DISABLESUPPRESSION),
1563 croak("DosSuppressPopUps(%c) failed", drive);
1564 ST(0) = sv_newmortal();
1565 if (DOS_suppression_state > 0)
1566 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1567 else if (DOS_suppression_state == 0)
1568 sv_setpvn(ST(0), "", 0);
1569 DOS_suppression_state = drive;
1574 static const char * const si_fields[QSV_MAX] = {
1576 "MAX_TEXT_SESSIONS",
1580 "DYN_PRI_VARIATION",
1598 "FOREGROUND_FS_SESSION",
1599 "FOREGROUND_PROCESS"
1606 croak("Usage: OS2::SysInfo()");
1608 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1609 APIRET rc = NO_ERROR; /* Return code */
1612 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1613 QSV_MAX, /* information */
1616 croak("DosQuerySysInfo() failed");
1617 EXTEND(SP,2*QSV_MAX);
1618 while (i < QSV_MAX) {
1619 ST(j) = sv_newmortal();
1620 sv_setpv(ST(j++), si_fields[i]);
1621 ST(j) = sv_newmortal();
1622 sv_setiv(ST(j++), si[i]);
1626 XSRETURN(2 * QSV_MAX);
1629 XS(XS_OS2_BootDrive)
1633 croak("Usage: OS2::BootDrive()");
1635 ULONG si[1] = {0}; /* System Information Data Buffer */
1636 APIRET rc = NO_ERROR; /* Return code */
1639 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1640 (PVOID)si, sizeof(si))))
1641 croak("DosQuerySysInfo() failed");
1642 ST(0) = sv_newmortal();
1643 c = 'a' - 1 + si[0];
1644 sv_setpvn(ST(0), &c, 1);
1653 croak("Usage: OS2::MorphPM(serve)");
1655 bool serve = SvOK(ST(0));
1656 unsigned long pmq = perl_hmq_GET(serve);
1658 ST(0) = sv_newmortal();
1659 sv_setiv(ST(0), pmq);
1664 XS(XS_OS2_UnMorphPM)
1668 croak("Usage: OS2::UnMorphPM(serve)");
1670 bool serve = SvOK(ST(0));
1672 perl_hmq_UNSET(serve);
1677 XS(XS_OS2_Serve_Messages)
1681 croak("Usage: OS2::Serve_Messages(force)");
1683 bool force = SvOK(ST(0));
1684 unsigned long cnt = Perl_Serve_Messages(force);
1686 ST(0) = sv_newmortal();
1687 sv_setiv(ST(0), cnt);
1692 XS(XS_OS2_Process_Messages)
1695 if (items < 1 || items > 2)
1696 croak("Usage: OS2::Process_Messages(force [, cnt])");
1698 bool force = SvOK(ST(0));
1704 int fake = SvIV(sv); /* Force SvIVX */
1707 croak("Can't upgrade count to IV");
1710 cnt = Perl_Process_Messages(force, cntp);
1711 ST(0) = sv_newmortal();
1712 sv_setiv(ST(0), cnt);
1717 XS(XS_Cwd_current_drive)
1721 croak("Usage: Cwd::current_drive()");
1725 RETVAL = current_drive();
1726 ST(0) = sv_newmortal();
1727 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1732 XS(XS_Cwd_sys_chdir)
1736 croak("Usage: Cwd::sys_chdir(path)");
1739 char * path = (char *)SvPV(ST(0),n_a);
1742 RETVAL = sys_chdir(path);
1743 ST(0) = boolSV(RETVAL);
1744 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1749 XS(XS_Cwd_change_drive)
1753 croak("Usage: Cwd::change_drive(d)");
1756 char d = (char)*SvPV(ST(0),n_a);
1759 RETVAL = change_drive(d);
1760 ST(0) = boolSV(RETVAL);
1761 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1766 XS(XS_Cwd_sys_is_absolute)
1770 croak("Usage: Cwd::sys_is_absolute(path)");
1773 char * path = (char *)SvPV(ST(0),n_a);
1776 RETVAL = sys_is_absolute(path);
1777 ST(0) = boolSV(RETVAL);
1778 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1783 XS(XS_Cwd_sys_is_rooted)
1787 croak("Usage: Cwd::sys_is_rooted(path)");
1790 char * path = (char *)SvPV(ST(0),n_a);
1793 RETVAL = sys_is_rooted(path);
1794 ST(0) = boolSV(RETVAL);
1795 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1800 XS(XS_Cwd_sys_is_relative)
1804 croak("Usage: Cwd::sys_is_relative(path)");
1807 char * path = (char *)SvPV(ST(0),n_a);
1810 RETVAL = sys_is_relative(path);
1811 ST(0) = boolSV(RETVAL);
1812 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1821 croak("Usage: Cwd::sys_cwd()");
1825 RETVAL = _getcwd2(p, MAXPATHLEN);
1826 ST(0) = sv_newmortal();
1827 sv_setpv((SV*)ST(0), RETVAL);
1832 XS(XS_Cwd_sys_abspath)
1835 if (items < 1 || items > 2)
1836 croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1839 char * path = (char *)SvPV(ST(0),n_a);
1847 dir = (char *)SvPV(ST(1),n_a);
1849 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1853 if (_abspath(p, path, MAXPATHLEN) == 0) {
1859 /* Absolute with drive: */
1860 if ( sys_is_absolute(path) ) {
1861 if (_abspath(p, path, MAXPATHLEN) == 0) {
1866 } else if (path[0] == '/' || path[0] == '\\') {
1867 /* Rooted, but maybe on different drive. */
1868 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1869 char p1[MAXPATHLEN];
1871 /* Need to prepend the drive. */
1874 Copy(path, p1 + 2, strlen(path) + 1, char);
1876 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1881 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1887 /* Either path is relative, or starts with a drive letter. */
1888 /* If the path starts with a drive letter, then dir is
1890 a/b) it is absolute/x:relative on the same drive.
1891 c) path is on current drive, and dir is rooted
1892 In all the cases it is safe to drop the drive part
1894 if ( !sys_is_relative(path) ) {
1897 if ( ( ( sys_is_absolute(dir)
1898 || (isALPHA(dir[0]) && dir[1] == ':'
1899 && strnicmp(dir, path,1) == 0))
1900 && strnicmp(dir, path,1) == 0)
1901 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1902 && toupper(path[0]) == current_drive())) {
1904 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1905 RETVAL = p; goto done;
1907 RETVAL = NULL; goto done;
1911 /* Need to prepend the absolute path of dir. */
1912 char p1[MAXPATHLEN];
1914 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1917 if (p1[ l - 1 ] != '/') {
1921 Copy(path, p1 + l, strlen(path) + 1, char);
1922 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1934 ST(0) = sv_newmortal();
1935 sv_setpv((SV*)ST(0), RETVAL);
1939 typedef APIRET (*PELP)(PSZ path, ULONG type);
1942 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1944 loadByOrd("doscalls",ord); /* Guarantied to load or die! */
1945 return (*(PELP)ExtFCN[ord])(path, type);
1948 #define extLibpath(type) \
1949 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1950 : BEGIN_LIBPATH))) \
1953 #define extLibpath_set(p,type) \
1954 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1957 XS(XS_Cwd_extLibpath)
1960 if (items < 0 || items > 1)
1961 croak("Usage: Cwd::extLibpath(type = 0)");
1971 type = (int)SvIV(ST(0));
1974 RETVAL = extLibpath(type);
1975 ST(0) = sv_newmortal();
1976 sv_setpv((SV*)ST(0), RETVAL);
1981 XS(XS_Cwd_extLibpath_set)
1984 if (items < 1 || items > 2)
1985 croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1988 char * s = (char *)SvPV(ST(0),n_a);
1996 type = (int)SvIV(ST(1));
1999 RETVAL = extLibpath_set(s, type);
2000 ST(0) = boolSV(RETVAL);
2001 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2009 char *file = __FILE__;
2013 if (_emx_env & 0x200) { /* OS/2 */
2014 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2015 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2016 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2018 newXS("OS2::Error", XS_OS2_Error, file);
2019 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2020 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2021 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2022 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2023 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2024 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2025 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2026 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2027 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2028 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2029 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2030 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2031 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2032 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2033 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2034 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2035 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2038 sv_setiv(GvSV(gv), 1);
2040 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2042 sv_setiv(GvSV(gv), _emx_rev);
2043 sv_setpv(GvSV(gv), _emx_vprt);
2045 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2047 sv_setiv(GvSV(gv), _emx_env);
2048 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2050 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2054 OS2_Perl_data_t OS2_Perl_data;
2057 Perl_OS2_init(char **env)
2063 OS2_Perl_data.xs_init = &Xs_OS2_init;
2064 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2065 if (environ == NULL) {
2068 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2069 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2070 strcpy(PL_sh_path, SH_PATH);
2071 PL_sh_path[0] = shell[0];
2072 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2073 int l = strlen(shell), i;
2074 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2077 New(1304, PL_sh_path, l + 8, char);
2078 strncpy(PL_sh_path, shell, l);
2079 strcpy(PL_sh_path + l, "/sh.exe");
2080 for (i = 0; i < l; i++) {
2081 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2084 MUTEX_INIT(&start_thread_mutex);
2085 os2_mytype = my_type(); /* Do it before morphing. Needed? */
2092 my_tmpnam (char *str)
2094 char *p = getenv("TMP"), *tpath;
2097 if (!p) p = getenv("TEMP");
2098 tpath = tempnam(p, "pltmp");
2112 if (s.st_mode & S_IWOTH) {
2115 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2121 /* This code was contributed by Rocco Caputo. */
2123 my_flock(int handle, int o)
2125 FILELOCK rNull, rFull;
2126 ULONG timeout, handle_type, flag_word;
2128 int blocking, shared;
2129 static int use_my = -1;
2132 char *s = getenv("USE_PERL_FLOCK");
2138 if (!(_emx_env & 0x200) || !use_my)
2139 return flock(handle, o); /* Delegate to EMX. */
2142 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2143 (handle_type & 0xFF))
2148 // set lock/unlock ranges
2149 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2150 rFull.lRange = 0x7FFFFFFF;
2151 // set timeout for blocking
2152 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2153 // shared or exclusive?
2154 shared = (o & LOCK_SH) ? 1 : 0;
2155 // do not block the unlock
2156 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2157 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2162 case ERROR_INVALID_HANDLE:
2165 case ERROR_SHARING_BUFFER_EXCEEDED:
2168 case ERROR_LOCK_VIOLATION:
2169 break; // not an error
2170 case ERROR_INVALID_PARAMETER:
2171 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2172 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2175 case ERROR_INTERRUPT:
2184 if (o & (LOCK_SH | LOCK_EX)) {
2185 // for blocking operations
2199 case ERROR_INVALID_HANDLE:
2202 case ERROR_SHARING_BUFFER_EXCEEDED:
2205 case ERROR_LOCK_VIOLATION:
2207 errno = EWOULDBLOCK;
2211 case ERROR_INVALID_PARAMETER:
2212 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2213 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2216 case ERROR_INTERRUPT:
2223 // give away timeslice