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)
472 char buf[256], *s = 0, scrbuf[280];
474 static char * fargs[4]
475 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
476 char **argsp = fargs;
485 if (strEQ(PL_Argv[0],"/bin/sh"))
486 PL_Argv[0] = PL_sh_path;
488 if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
489 && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
490 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
491 ) /* will spawnvp use PATH? */
492 TAINT_ENV(); /* testing IFS here is overkill, probably */
493 /* We should check PERL_SH* and PERLLIB_* as well? */
494 if (!really || !*(tmps = SvPV(really, n_a)))
499 if (_emx_env & 0x200) { /* OS/2. */
500 int type = file_type(tmps);
502 if (type == -1) { /* Not found */
507 else if (type == -2) { /* Not an EXE */
512 else if (type == -3) { /* Is a directory? */
513 /* Special-case this */
515 int l = strlen(tmps);
517 if (l + 5 <= sizeof tbuf) {
519 strcpy(tbuf + l, ".exe");
520 type = file_type(tbuf);
530 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
531 case FAPPTYP_WINDOWAPI:
533 if (os2_mytype != 3) { /* not PM */
534 if (flag == P_NOWAIT)
536 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
537 warn("Starting PM process with flag=%d, mytype=%d",
542 case FAPPTYP_NOTWINDOWCOMPAT:
544 if (os2_mytype != 0) { /* not full screen */
545 if (flag == P_NOWAIT)
547 else if ((flag & 7) != P_SESSION)
548 warn("Starting Full Screen process with flag=%d, mytype=%d",
553 case FAPPTYP_NOTSPEC:
554 /* Let the shell handle this... */
562 rc = result(trueflag, spawnvp(flag,tmps,PL_Argv));
564 if (execf == EXECF_TRUEEXEC)
565 rc = execvp(tmps,PL_Argv);
566 else if (execf == EXECF_EXEC)
567 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
568 else if (execf == EXECF_SPAWN_NOWAIT)
569 rc = spawnvp(flag,tmps,PL_Argv);
570 else /* EXECF_SPAWN */
571 rc = result(trueflag,
572 spawnvp(flag,tmps,PL_Argv));
574 if (rc < 0 && pass == 1
575 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
580 if (err == ENOENT || err == ENOEXEC) {
581 /* No such file, or is a script. */
582 /* Try adding script extensions to the file name, and
584 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
593 if (l >= sizeof scrbuf) {
596 croak("Size of scriptname too big: %d", l);
602 file = fopen(scr, "r");
606 if (!fgets(buf, sizeof buf, file)) { /* Empty... */
610 /* Special case: maybe from -Zexe build, so
611 there is an executable around (contrary to
612 documentation, DosQueryAppType sometimes (?)
613 does not append ".exe", so we could have
614 reached this place). */
615 if (l + 5 < sizeof scrbuf) {
616 strcpy(scrbuf + l, ".exe");
617 if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
618 && !S_ISDIR(PL_statbuf.st_mode)) {
628 if (fclose(file) != 0) { /* Failure */
630 warn("Error reading \"%s\": %s",
631 scr, Strerror(errno));
632 buf[0] = 0; /* Not #! */
638 } else if (buf[0] == 'e') {
639 if (strnEQ(buf, "extproc", 7)
642 } else if (buf[0] == 'E') {
643 if (strnEQ(buf, "EXTPROC", 7)
648 buf[0] = 0; /* Not #! */
656 /* Do better than pdksh: allow a few args,
657 strip trailing whitespace. */
667 while (*s && !isSPACE(*s))
674 warn("Too many args on %.*s line of \"%s\"",
685 || (!buf[0] && file)) { /* File without magic */
686 /* In fact we tried all what pdksh would
687 try. There is no point in calling
688 pdksh, we may just emulate its logic. */
689 char *shell = getenv("EXECSHELL");
690 char *shell_opt = NULL;
696 shell = getenv("OS2_SHELL");
697 if (inicmd) { /* No spaces at start! */
699 while (*s && !isSPACE(*s)) {
701 inicmd = NULL; /* Cannot use */
709 /* Dosish shells will choke on slashes
710 in paths, fortunately, this is
711 important for zeroth arg only. */
718 /* If EXECSHELL is set, we do not set */
721 shell = ((_emx_env & 0x200)
724 nargs = shell_opt ? 2 : 1; /* shell file args */
725 exec_args[0] = shell;
726 exec_args[1] = shell_opt;
728 if (nargs == 2 && inicmd) {
729 /* Use the original cmd line */
730 /* XXXX This is good only until we refuse
731 quoted arguments... */
735 } else if (!buf[0] && inicmd) { /* No file */
736 /* Start with the original cmdline. */
737 /* XXXX This is good only until we refuse
738 quoted arguments... */
742 nargs = 2; /* shell -c */
745 while (a[1]) /* Get to the end */
747 a++; /* Copy finil NULL too */
748 while (a >= PL_Argv) {
749 *(a + nargs) = *a; /* PL_Argv was preallocated to be
754 PL_Argv[nargs] = argsp[nargs];
755 /* Enable pathless exec if #! (as pdksh). */
756 pass = (buf[0] == '#' ? 2 : 3);
760 /* Not found: restore errno */
764 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
765 char *no_dir = strrchr(PL_Argv[0], '/');
767 /* Do as pdksh port does: if not found with /, try without
770 PL_Argv[0] = no_dir + 1;
775 if (rc < 0 && PL_dowarn)
776 warn("Can't %s \"%s\": %s\n",
777 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
779 PL_Argv[0], Strerror(errno));
780 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
781 && ((trueflag & 0xFF) == P_WAIT))
782 rc = 255 << 8; /* Emulate the fork(). */
789 do_aspawn(really,mark,sp)
798 int flag = P_WAIT, trueflag, err, secondtry = 0;
802 New(1301,PL_Argv, sp - mark + 3, char*);
805 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
810 while (++mark <= sp) {
812 *a++ = SvPVx(*mark, n_a);
818 rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL);
825 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
827 do_spawn2(cmd, execf)
834 char *shell, *copt, *news = NULL;
835 int rc, err, seenspace = 0;
836 char fullcmd[MAXNAMLEN + 1];
839 if ((shell = getenv("EMXSHELL")) != NULL)
841 else if ((shell = getenv("SHELL")) != NULL)
843 else if ((shell = getenv("COMSPEC")) != NULL)
848 /* Consensus on perl5-porters is that it is _very_ important to
849 have a shell which will not change between computers with the
850 same architecture, to avoid "action on a distance".
851 And to have simple build, this shell should be sh. */
856 while (*cmd && isSPACE(*cmd))
859 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
860 STRLEN l = strlen(PL_sh_path);
862 New(1302, news, strlen(cmd) - 7 + l + 1, char);
863 strcpy(news, PL_sh_path);
864 strcpy(news + l, cmd + 7);
868 /* save an extra exec if possible */
869 /* see if there are shell metacharacters in it */
871 if (*cmd == '.' && isSPACE(cmd[1]))
874 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
877 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
881 for (s = cmd; *s; s++) {
882 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
883 if (*s == '\n' && s[1] == '\0') {
886 } else if (*s == '\\' && !seenspace) {
887 continue; /* Allow backslashes in names */
889 /* We do not convert this to do_spawn_ve since shell
890 should be smart enough to start itself gloriously. */
892 if (execf == EXECF_TRUEEXEC)
893 rc = execl(shell,shell,copt,cmd,(char*)0);
894 else if (execf == EXECF_EXEC)
895 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
896 else if (execf == EXECF_SPAWN_NOWAIT)
897 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
899 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
901 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
902 if (rc < 0 && PL_dowarn)
903 warn("Can't %s \"%s\": %s",
904 (execf == EXECF_SPAWN ? "spawn" : "exec"),
905 shell, Strerror(errno));
906 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
911 } else if (*s == ' ' || *s == '\t') {
916 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
917 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
918 PL_Cmd = savepvn(cmd, s-cmd);
920 for (s = PL_Cmd; *s;) {
921 while (*s && isSPACE(*s)) s++;
924 while (*s && !isSPACE(*s)) s++;
930 rc = do_spawn_ve(NULL, 0, execf, cmd);
943 return do_spawn2(cmd, EXECF_SPAWN);
950 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
957 do_spawn2(cmd, EXECF_EXEC);
965 return do_spawn2(cmd, EXECF_TRUEEXEC);
969 my_syspopen(cmd,mode)
976 register I32 this, that, newfd;
977 register I32 pid, rc;
981 /* `this' is what we use in the parent, `that' in the child. */
982 this = (*mode == 'w');
986 taint_proper("Insecure %s%s", "EXEC");
990 /* Now we need to spawn the child. */
991 newfd = dup(*mode == 'r'); /* Preserve std* */
992 if (p[that] != (*mode == 'r')) {
993 dup2(p[that], *mode == 'r');
996 /* Where is `this' and newfd now? */
997 fcntl(p[this], F_SETFD, FD_CLOEXEC);
998 fcntl(newfd, F_SETFD, FD_CLOEXEC);
999 pid = do_spawn_nowait(cmd);
1000 if (newfd != (*mode == 'r')) {
1001 dup2(newfd, *mode == 'r'); /* Return std* back. */
1004 if (p[that] == (*mode == 'r'))
1010 if (p[that] < p[this]) {
1011 dup2(p[this], p[that]);
1015 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1016 (void)SvUPGRADE(sv,SVt_IV);
1018 PL_forkprocess = pid;
1019 return PerlIO_fdopen(p[this], mode);
1021 #else /* USE_POPEN */
1027 res = popen(cmd, mode);
1029 char *shell = getenv("EMXSHELL");
1031 my_setenv("EMXSHELL", PL_sh_path);
1032 res = popen(cmd, mode);
1033 my_setenv("EMXSHELL", shell);
1035 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1036 (void)SvUPGRADE(sv,SVt_IV);
1037 SvIVX(sv) = -1; /* A cooky. */
1040 #endif /* USE_POPEN */
1044 /******************************************************************/
1050 croak(PL_no_func, "Unsupported function fork");
1056 /*******************************************************************/
1057 /* not implemented in EMX 0.9a */
1059 void * ctermid(x) { return 0; }
1061 #ifdef MYTTYNAME /* was not in emx0.9a */
1062 void * ttyname(x) { return 0; }
1065 /******************************************************************/
1066 /* my socket forwarders - EMX lib only provides static forwarders */
1068 static HMODULE htcp = 0;
1073 static BYTE buf[20];
1076 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1078 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1079 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1080 return (void *) ((void * (*)(void)) fcn) ();
1085 tcp1(char *name, int arg)
1087 static BYTE buf[20];
1090 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1092 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1093 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1094 ((void (*)(int)) fcn) (arg);
1097 void * gethostent() { return tcp0("GETHOSTENT"); }
1098 void * getnetent() { return tcp0("GETNETENT"); }
1099 void * getprotoent() { return tcp0("GETPROTOENT"); }
1100 void * getservent() { return tcp0("GETSERVENT"); }
1101 void sethostent(x) { tcp1("SETHOSTENT", x); }
1102 void setnetent(x) { tcp1("SETNETENT", x); }
1103 void setprotoent(x) { tcp1("SETPROTOENT", x); }
1104 void setservent(x) { tcp1("SETSERVENT", x); }
1105 void endhostent() { tcp0("ENDHOSTENT"); }
1106 void endnetent() { tcp0("ENDNETENT"); }
1107 void endprotoent() { tcp0("ENDPROTOENT"); }
1108 void endservent() { tcp0("ENDSERVENT"); }
1110 /*****************************************************************************/
1111 /* not implemented in C Set++ */
1114 int setuid(x) { errno = EINVAL; return -1; }
1115 int setgid(x) { errno = EINVAL; return -1; }
1118 /*****************************************************************************/
1119 /* stat() hack for char/block device */
1123 /* First attempt used DosQueryFSAttach which crashed the system when
1124 used with 5.001. Now just look for /dev/. */
1127 os2_stat(char *name, struct stat *st)
1129 static int ino = SHRT_MAX;
1131 if (stricmp(name, "/dev/con") != 0
1132 && stricmp(name, "/dev/tty") != 0)
1133 return stat(name, st);
1135 memset(st, 0, sizeof *st);
1136 st->st_mode = S_IFCHR|0666;
1137 st->st_ino = (ino-- & 0x7FFF);
1144 #ifdef USE_PERL_SBRK
1146 /* SBRK() emulation, mostly moved to malloc.c. */
1149 sys_alloc(int size) {
1151 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1153 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1156 croak("Got an error from DosAllocMem: %li", (long)rc);
1160 #endif /* USE_PERL_SBRK */
1164 char *tmppath = TMPPATH1;
1169 char *p = getenv("TMP"), *tpath;
1172 if (!p) p = getenv("TEMP");
1175 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1178 strcpy(tpath + len + 1, TMPPATH1);
1184 XS(XS_File__Copy_syscopy)
1187 if (items < 2 || items > 3)
1188 croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
1191 char * src = (char *)SvPV(ST(0),n_a);
1192 char * dst = (char *)SvPV(ST(1),n_a);
1199 flag = (unsigned long)SvIV(ST(2));
1202 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1203 ST(0) = sv_newmortal();
1204 sv_setiv(ST(0), (IV)RETVAL);
1209 #include "patchlevel.h"
1215 static char fname[9];
1216 int pos = 6, len, avlen;
1217 unsigned int sum = 0;
1223 if (!SvROK(sv)) croak("Not a reference given to mod2fname");
1225 if (SvTYPE(sv) != SVt_PVAV)
1226 croak("Not array reference given to mod2fname");
1228 avlen = av_len((AV*)sv);
1230 croak("Empty array reference given to mod2fname");
1232 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1233 strncpy(fname, s, 8);
1235 if (len < 6) pos = len;
1237 sum = 33 * sum + *(s++); /* Checksumming first chars to
1238 * get the capitalization into c.s. */
1241 while (avlen >= 0) {
1242 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1244 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1249 sum++; /* Avoid conflict of DLLs in memory. */
1251 sum += PATCHLEVEL * 200 + SUBVERSION * 2; /* */
1252 fname[pos] = 'A' + (sum % 26);
1253 fname[pos + 1] = 'A' + (sum / 26 % 26);
1254 fname[pos + 2] = '\0';
1255 return (char *)fname;
1258 XS(XS_DynaLoader_mod2fname)
1262 croak("Usage: DynaLoader::mod2fname(sv)");
1267 RETVAL = mod2fname(sv);
1268 ST(0) = sv_newmortal();
1269 sv_setpv((SV*)ST(0), RETVAL);
1277 static char buf[300];
1280 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1283 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1284 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1287 if (len > 0 && buf[len - 1] == '\n')
1288 buf[len - 1] = '\0';
1289 if (len > 1 && buf[len - 2] == '\r')
1290 buf[len - 2] = '\0';
1291 if (len > 2 && buf[len - 3] == '.')
1292 buf[len - 3] = '\0';
1297 perllib_mangle(char *s, unsigned int l)
1299 static char *newp, *oldp;
1300 static int newl, oldl, notfound;
1301 static char ret[STATIC_FILE_LENGTH+1];
1303 if (!newp && !notfound) {
1304 newp = getenv("PERLLIB_PREFIX");
1309 while (*newp && !isSPACE(*newp) && *newp != ';') {
1310 newp++; oldl++; /* Skip digits. */
1312 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1313 newp++; /* Skip whitespace. */
1315 newl = strlen(newp);
1316 if (newl == 0 || oldl == 0) {
1317 croak("Malformed PERLLIB_PREFIX");
1322 if (*s == '\\') *s = '/';
1335 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1338 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1339 croak("Malformed PERLLIB_PREFIX");
1341 strcpy(ret + newl, s + oldl);
1346 Perl_hab_GET() /* Needed if perl.h cannot be included */
1348 return perl_hab_GET();
1352 Perl_Register_MQ(int serve)
1357 if (Perl_os2_initial_mode++)
1359 DosGetInfoBlocks(&tib, &pib);
1360 Perl_os2_initial_mode = pib->pib_ultype;
1361 Perl_hmq_refcnt = 1;
1362 /* Try morphing into a PM application. */
1363 if (pib->pib_ultype != 3) /* 2 is VIO */
1364 pib->pib_ultype = 3; /* 3 is PM */
1365 init_PMWIN_entries();
1366 /* 64 messages if before OS/2 3.0, ignored otherwise */
1367 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1371 _exit(188); /* Panic can try to create a window. */
1372 croak("Cannot create a message queue, or morph to a PM application");
1378 Perl_Serve_Messages(int force)
1383 if (Perl_hmq_servers && !force)
1385 if (!Perl_hmq_refcnt)
1386 croak("No message queue");
1387 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1389 if (msg.msg == WM_QUIT)
1390 croak("QUITing...");
1391 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1397 Perl_Process_Messages(int force, I32 *cntp)
1401 if (Perl_hmq_servers && !force)
1403 if (!Perl_hmq_refcnt)
1404 croak("No message queue");
1405 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1408 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1409 if (msg.msg == WM_DESTROY)
1411 if (msg.msg == WM_CREATE)
1414 croak("QUITing...");
1418 Perl_Deregister_MQ(int serve)
1423 if (--Perl_hmq_refcnt == 0) {
1424 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1426 /* Try morphing back from a PM application. */
1427 if (pib->pib_ultype == 3) /* 3 is PM */
1428 pib->pib_ultype = Perl_os2_initial_mode;
1430 warn("Unexpected program mode %d when morphing back from PM",
1435 extern void dlopen();
1436 void *fakedl = &dlopen; /* Pull in dynaloading part. */
1438 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1439 && ((path)[2] == '/' || (path)[2] == '\\'))
1440 #define sys_is_rooted _fnisabs
1441 #define sys_is_relative _fnisrel
1442 #define current_drive _getdrive
1444 #undef chdir /* Was _chdir2. */
1445 #define sys_chdir(p) (chdir(p) == 0)
1446 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1448 static int DOS_harderr_state = -1;
1454 croak("Usage: OS2::Error(harderr, exception)");
1456 int arg1 = SvIV(ST(0));
1457 int arg2 = SvIV(ST(1));
1458 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1459 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1460 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1463 if (CheckOSError(DosError(a)))
1464 croak("DosError(%d) failed", a);
1465 ST(0) = sv_newmortal();
1466 if (DOS_harderr_state >= 0)
1467 sv_setiv(ST(0), DOS_harderr_state);
1468 DOS_harderr_state = RETVAL;
1473 static signed char DOS_suppression_state = -1;
1475 XS(XS_OS2_Errors2Drive)
1479 croak("Usage: OS2::Errors2Drive(drive)");
1483 int suppress = SvOK(sv);
1484 char *s = suppress ? SvPV(sv, n_a) : NULL;
1485 char drive = (s ? *s : 0);
1488 if (suppress && !isALPHA(drive))
1489 croak("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1490 if (CheckOSError(DosSuppressPopUps((suppress
1491 ? SPU_ENABLESUPPRESSION
1492 : SPU_DISABLESUPPRESSION),
1494 croak("DosSuppressPopUps(%c) failed", drive);
1495 ST(0) = sv_newmortal();
1496 if (DOS_suppression_state > 0)
1497 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1498 else if (DOS_suppression_state == 0)
1499 sv_setpvn(ST(0), "", 0);
1500 DOS_suppression_state = drive;
1505 static const char * const si_fields[QSV_MAX] = {
1507 "MAX_TEXT_SESSIONS",
1511 "DYN_PRI_VARIATION",
1529 "FOREGROUND_FS_SESSION",
1530 "FOREGROUND_PROCESS"
1537 croak("Usage: OS2::SysInfo()");
1539 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1540 APIRET rc = NO_ERROR; /* Return code */
1543 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1544 QSV_MAX, /* information */
1547 croak("DosQuerySysInfo() failed");
1548 EXTEND(SP,2*QSV_MAX);
1549 while (i < QSV_MAX) {
1550 ST(j) = sv_newmortal();
1551 sv_setpv(ST(j++), si_fields[i]);
1552 ST(j) = sv_newmortal();
1553 sv_setiv(ST(j++), si[i]);
1557 XSRETURN(2 * QSV_MAX);
1560 XS(XS_OS2_BootDrive)
1564 croak("Usage: OS2::BootDrive()");
1566 ULONG si[1] = {0}; /* System Information Data Buffer */
1567 APIRET rc = NO_ERROR; /* Return code */
1570 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1571 (PVOID)si, sizeof(si))))
1572 croak("DosQuerySysInfo() failed");
1573 ST(0) = sv_newmortal();
1574 c = 'a' - 1 + si[0];
1575 sv_setpvn(ST(0), &c, 1);
1584 croak("Usage: OS2::MorphPM(serve)");
1586 bool serve = SvOK(ST(0));
1587 unsigned long pmq = perl_hmq_GET(serve);
1589 ST(0) = sv_newmortal();
1590 sv_setiv(ST(0), pmq);
1595 XS(XS_OS2_UnMorphPM)
1599 croak("Usage: OS2::UnMorphPM(serve)");
1601 bool serve = SvOK(ST(0));
1603 perl_hmq_UNSET(serve);
1608 XS(XS_OS2_Serve_Messages)
1612 croak("Usage: OS2::Serve_Messages(force)");
1614 bool force = SvOK(ST(0));
1615 unsigned long cnt = Perl_Serve_Messages(force);
1617 ST(0) = sv_newmortal();
1618 sv_setiv(ST(0), cnt);
1623 XS(XS_OS2_Process_Messages)
1626 if (items < 1 || items > 2)
1627 croak("Usage: OS2::Process_Messages(force [, cnt])");
1629 bool force = SvOK(ST(0));
1635 int fake = SvIV(sv); /* Force SvIVX */
1638 croak("Can't upgrade count to IV");
1641 cnt = Perl_Process_Messages(force, cntp);
1642 ST(0) = sv_newmortal();
1643 sv_setiv(ST(0), cnt);
1648 XS(XS_Cwd_current_drive)
1652 croak("Usage: Cwd::current_drive()");
1656 RETVAL = current_drive();
1657 ST(0) = sv_newmortal();
1658 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1663 XS(XS_Cwd_sys_chdir)
1667 croak("Usage: Cwd::sys_chdir(path)");
1670 char * path = (char *)SvPV(ST(0),n_a);
1673 RETVAL = sys_chdir(path);
1674 ST(0) = boolSV(RETVAL);
1675 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1680 XS(XS_Cwd_change_drive)
1684 croak("Usage: Cwd::change_drive(d)");
1687 char d = (char)*SvPV(ST(0),n_a);
1690 RETVAL = change_drive(d);
1691 ST(0) = boolSV(RETVAL);
1692 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1697 XS(XS_Cwd_sys_is_absolute)
1701 croak("Usage: Cwd::sys_is_absolute(path)");
1704 char * path = (char *)SvPV(ST(0),n_a);
1707 RETVAL = sys_is_absolute(path);
1708 ST(0) = boolSV(RETVAL);
1709 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1714 XS(XS_Cwd_sys_is_rooted)
1718 croak("Usage: Cwd::sys_is_rooted(path)");
1721 char * path = (char *)SvPV(ST(0),n_a);
1724 RETVAL = sys_is_rooted(path);
1725 ST(0) = boolSV(RETVAL);
1726 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1731 XS(XS_Cwd_sys_is_relative)
1735 croak("Usage: Cwd::sys_is_relative(path)");
1738 char * path = (char *)SvPV(ST(0),n_a);
1741 RETVAL = sys_is_relative(path);
1742 ST(0) = boolSV(RETVAL);
1743 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1752 croak("Usage: Cwd::sys_cwd()");
1756 RETVAL = _getcwd2(p, MAXPATHLEN);
1757 ST(0) = sv_newmortal();
1758 sv_setpv((SV*)ST(0), RETVAL);
1763 XS(XS_Cwd_sys_abspath)
1766 if (items < 1 || items > 2)
1767 croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1770 char * path = (char *)SvPV(ST(0),n_a);
1778 dir = (char *)SvPV(ST(1),n_a);
1780 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1784 if (_abspath(p, path, MAXPATHLEN) == 0) {
1790 /* Absolute with drive: */
1791 if ( sys_is_absolute(path) ) {
1792 if (_abspath(p, path, MAXPATHLEN) == 0) {
1797 } else if (path[0] == '/' || path[0] == '\\') {
1798 /* Rooted, but maybe on different drive. */
1799 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1800 char p1[MAXPATHLEN];
1802 /* Need to prepend the drive. */
1805 Copy(path, p1 + 2, strlen(path) + 1, char);
1807 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1812 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1818 /* Either path is relative, or starts with a drive letter. */
1819 /* If the path starts with a drive letter, then dir is
1821 a/b) it is absolute/x:relative on the same drive.
1822 c) path is on current drive, and dir is rooted
1823 In all the cases it is safe to drop the drive part
1825 if ( !sys_is_relative(path) ) {
1828 if ( ( ( sys_is_absolute(dir)
1829 || (isALPHA(dir[0]) && dir[1] == ':'
1830 && strnicmp(dir, path,1) == 0))
1831 && strnicmp(dir, path,1) == 0)
1832 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1833 && toupper(path[0]) == current_drive())) {
1835 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1836 RETVAL = p; goto done;
1838 RETVAL = NULL; goto done;
1842 /* Need to prepend the absolute path of dir. */
1843 char p1[MAXPATHLEN];
1845 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1848 if (p1[ l - 1 ] != '/') {
1852 Copy(path, p1 + l, strlen(path) + 1, char);
1853 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1865 ST(0) = sv_newmortal();
1866 sv_setpv((SV*)ST(0), RETVAL);
1870 typedef APIRET (*PELP)(PSZ path, ULONG type);
1873 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1875 loadByOrd("doscalls",ord); /* Guarantied to load or die! */
1876 return (*(PELP)ExtFCN[ord])(path, type);
1879 #define extLibpath(type) \
1880 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1881 : BEGIN_LIBPATH))) \
1884 #define extLibpath_set(p,type) \
1885 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1888 XS(XS_Cwd_extLibpath)
1891 if (items < 0 || items > 1)
1892 croak("Usage: Cwd::extLibpath(type = 0)");
1902 type = (int)SvIV(ST(0));
1905 RETVAL = extLibpath(type);
1906 ST(0) = sv_newmortal();
1907 sv_setpv((SV*)ST(0), RETVAL);
1912 XS(XS_Cwd_extLibpath_set)
1915 if (items < 1 || items > 2)
1916 croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1919 char * s = (char *)SvPV(ST(0),n_a);
1927 type = (int)SvIV(ST(1));
1930 RETVAL = extLibpath_set(s, type);
1931 ST(0) = boolSV(RETVAL);
1932 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1940 char *file = __FILE__;
1944 if (_emx_env & 0x200) { /* OS/2 */
1945 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1946 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1947 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1949 newXS("OS2::Error", XS_OS2_Error, file);
1950 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
1951 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
1952 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
1953 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
1954 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
1955 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
1956 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
1957 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1958 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1959 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1960 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1961 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1962 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1963 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1964 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1965 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1966 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1969 sv_setiv(GvSV(gv), 1);
1971 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
1973 sv_setiv(GvSV(gv), _emx_rev);
1974 sv_setpv(GvSV(gv), _emx_vprt);
1976 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
1978 sv_setiv(GvSV(gv), _emx_env);
1979 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
1981 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
1985 OS2_Perl_data_t OS2_Perl_data;
1988 Perl_OS2_init(char **env)
1994 OS2_Perl_data.xs_init = &Xs_OS2_init;
1995 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
1996 if (environ == NULL) {
1999 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2000 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2001 strcpy(PL_sh_path, SH_PATH);
2002 PL_sh_path[0] = shell[0];
2003 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2004 int l = strlen(shell), i;
2005 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2008 New(1304, PL_sh_path, l + 8, char);
2009 strncpy(PL_sh_path, shell, l);
2010 strcpy(PL_sh_path + l, "/sh.exe");
2011 for (i = 0; i < l; i++) {
2012 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2015 MUTEX_INIT(&start_thread_mutex);
2016 os2_mytype = my_type(); /* Do it before morphing. Needed? */
2023 my_tmpnam (char *str)
2025 char *p = getenv("TMP"), *tpath;
2028 if (!p) p = getenv("TEMP");
2029 tpath = tempnam(p, "pltmp");
2043 if (s.st_mode & S_IWOTH) {
2046 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2052 /* This code was contributed by Rocco Caputo. */
2054 my_flock(int handle, int o)
2056 FILELOCK rNull, rFull;
2057 ULONG timeout, handle_type, flag_word;
2059 int blocking, shared;
2060 static int use_my = -1;
2063 char *s = getenv("USE_PERL_FLOCK");
2069 if (!(_emx_env & 0x200) || !use_my)
2070 return flock(handle, o); /* Delegate to EMX. */
2073 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2074 (handle_type & 0xFF))
2079 // set lock/unlock ranges
2080 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2081 rFull.lRange = 0x7FFFFFFF;
2082 // set timeout for blocking
2083 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2084 // shared or exclusive?
2085 shared = (o & LOCK_SH) ? 1 : 0;
2086 // do not block the unlock
2087 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2088 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2093 case ERROR_INVALID_HANDLE:
2096 case ERROR_SHARING_BUFFER_EXCEEDED:
2099 case ERROR_LOCK_VIOLATION:
2100 break; // not an error
2101 case ERROR_INVALID_PARAMETER:
2102 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2103 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2106 case ERROR_INTERRUPT:
2115 if (o & (LOCK_SH | LOCK_EX)) {
2116 // for blocking operations
2130 case ERROR_INVALID_HANDLE:
2133 case ERROR_SHARING_BUFFER_EXCEEDED:
2136 case ERROR_LOCK_VIOLATION:
2138 errno = EWOULDBLOCK;
2142 case ERROR_INVALID_PARAMETER:
2143 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2144 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2147 case ERROR_INTERRUPT:
2154 // give away timeslice