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)
165 if ((rc = DosResetEventSem(*c,&PL_na)) && (rc != ERROR_ALREADY_RESET))
166 croak("panic: COND_WAIT-reset: rc=%i", rc);
167 if (m) MUTEX_UNLOCK(m);
168 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
169 && (rc != ERROR_INTERRUPT))
170 croak("panic: COND_WAIT: rc=%i", rc);
171 if (rc == ERROR_INTERRUPT)
173 if (m) MUTEX_LOCK(m);
177 /*****************************************************************************/
178 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
179 static PFN ExtFCN[2]; /* Labeled by ord below. */
180 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
181 #define ORD_QUERY_ELP 0
182 #define ORD_SET_ELP 1
183 struct PMWIN_entries_t PMWIN_entries;
186 loadByOrd(char *modname, ULONG ord)
188 if (ExtFCN[ord] == NULL) {
189 static HMODULE hdosc = 0;
194 if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
196 || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
197 croak("This version of OS/2 does not support %s.%i",
198 modname, loadOrd[ord]);
201 if ((long)ExtFCN[ord] == -1)
202 croak("panic queryaddr");
206 init_PMWIN_entries(void)
208 static HMODULE hpmwin = 0;
209 static const int ords[] = {
210 763, /* Initialize */
211 716, /* CreateMsgQueue */
212 726, /* DestroyMsgQueue */
215 912, /* DispatchMsg */
224 if (CheckOSError(DosLoadModule(buf, sizeof buf, "pmwin", &hpmwin)))
225 croak("This version of OS/2 does not support pmwin: error in %s", buf);
227 if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
228 ((PFN*)&PMWIN_entries)+i)))
229 croak("This version of OS/2 does not support pmwin.%d", ords[i]);
236 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
238 #define QSS_INI_BUFFER 1024
241 get_sysinfo(ULONG pid, ULONG flags)
244 ULONG rc, buf_len = QSS_INI_BUFFER;
246 New(1322, pbuffer, buf_len, char);
247 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
248 rc = QuerySysState(flags, pid, pbuffer, buf_len);
249 while (rc == ERROR_BUFFER_OVERFLOW) {
250 Renew(pbuffer, buf_len *= 2, char);
251 rc = QuerySysState(flags, pid, pbuffer, buf_len);
258 return (PQTOPLEVEL)pbuffer;
261 #define PRIO_ERR 0x1111
269 psi = get_sysinfo(pid, QSS_PROCESS);
273 if (pid != psi->procdata->pid) {
275 croak("panic: wrong pid in sysinfo");
277 prio = psi->procdata->threads->priority;
283 setpriority(int which, int pid, int val)
288 prio = sys_prio(pid);
290 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
291 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
292 /* Do not change class. */
293 return CheckOSError(DosSetPriority((pid < 0)
294 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
296 (32 - val) % 32 - (prio & 0xFF),
299 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
300 /* Documentation claims one can change both class and basevalue,
301 * but I find it wrong. */
302 /* Change class, but since delta == 0 denotes absolute 0, correct. */
303 if (CheckOSError(DosSetPriority((pid < 0)
304 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
305 priors[(32 - val) >> 5] + 1,
309 if ( ((32 - val) % 32) == 0 ) return 0;
310 return CheckOSError(DosSetPriority((pid < 0)
311 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
317 /* else return CheckOSError(DosSetPriority((pid < 0) */
318 /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
319 /* priors[(32 - val) >> 5] + 1, */
320 /* (32 - val) % 32 - (prio & 0xFF), */
326 getpriority(int which /* ignored */, int pid)
332 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
333 /* DosGetInfoBlocks has old priority! */
334 /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
335 /* if (pid != pib->pib_ulpid) { */
337 if (ret == PRIO_ERR) {
341 /* ret = tib->tib_ptib2->tib2_ulpri; */
342 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
345 /*****************************************************************************/
348 /* There is no big sense to make it thread-specific, since signals
349 are delivered to thread 1 only. XXXX Maybe make it into an array? */
350 static int spawn_pid;
351 static int spawn_killed;
354 spawn_sighandler(int sig)
356 /* Some programs do not arrange for the keyboard signals to be
357 delivered to them. We need to deliver the signal manually. */
358 /* We may get a signal only if
359 a) kid does not receive keyboard signal: deliver it;
360 b) kid already died, and we get a signal. We may only hope
361 that the pid number was not reused.
365 sig = SIGKILL; /* Try harder. */
366 kill(spawn_pid, sig);
371 result(int flag, int pid)
374 Signal_t (*ihand)(); /* place to save signal during system() */
375 Signal_t (*qhand)(); /* place to save signal during system() */
381 if (pid < 0 || flag != 0)
387 ihand = rsignal(SIGINT, &spawn_sighandler);
388 qhand = rsignal(SIGQUIT, &spawn_sighandler);
390 r = wait4pid(pid, &status, 0);
391 } while (r == -1 && errno == EINTR);
392 rsignal(SIGINT, ihand);
393 rsignal(SIGQUIT, qhand);
395 PL_statusvalue = (U16)status;
398 return status & 0xFFFF;
400 ihand = rsignal(SIGINT, SIG_IGN);
401 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
402 rsignal(SIGINT, ihand);
403 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
406 return PL_statusvalue;
410 #define EXECF_SPAWN 0
412 #define EXECF_TRUEEXEC 2
413 #define EXECF_SPAWN_NOWAIT 3
415 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
424 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
425 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
428 return (pib->pib_ultype);
432 file_type(char *path)
437 if (!(_emx_env & 0x200))
438 croak("file_type not implemented on DOS"); /* not OS/2. */
439 if (CheckOSError(DosQueryAppType(path, &apptype))) {
441 case ERROR_FILE_NOT_FOUND:
442 case ERROR_PATH_NOT_FOUND:
444 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
446 default: /* Found, but not an
447 executable, or some other
455 static ULONG os2_mytype;
457 /* Spawn/exec a program, revert to shell if needed. */
458 /* global PL_Argv[] contains arguments. */
461 do_spawn_ve(really, flag, execf, inicmd)
471 char buf[256], *s = 0, scrbuf[280];
473 static char * fargs[4]
474 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
475 char **argsp = fargs;
483 if (strEQ(PL_Argv[0],"/bin/sh"))
484 PL_Argv[0] = PL_sh_path;
486 if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
487 && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
488 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
489 ) /* will spawnvp use PATH? */
490 TAINT_ENV(); /* testing IFS here is overkill, probably */
491 /* We should check PERL_SH* and PERLLIB_* as well? */
492 if (!really || !*(tmps = SvPV(really, PL_na)))
497 if (_emx_env & 0x200) { /* OS/2. */
498 int type = file_type(tmps);
500 if (type == -1) { /* Not found */
505 else if (type == -2) { /* Not an EXE */
510 else if (type == -3) { /* Is a directory? */
511 /* Special-case this */
513 int l = strlen(tmps);
515 if (l + 5 <= sizeof tbuf) {
517 strcpy(tbuf + l, ".exe");
518 type = file_type(tbuf);
528 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
529 case FAPPTYP_WINDOWAPI:
531 if (os2_mytype != 3) { /* not PM */
532 if (flag == P_NOWAIT)
534 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
535 warn("Starting PM process with flag=%d, mytype=%d",
540 case FAPPTYP_NOTWINDOWCOMPAT:
542 if (os2_mytype != 0) { /* not full screen */
543 if (flag == P_NOWAIT)
545 else if ((flag & 7) != P_SESSION)
546 warn("Starting Full Screen process with flag=%d, mytype=%d",
551 case FAPPTYP_NOTSPEC:
552 /* Let the shell handle this... */
560 rc = result(trueflag, spawnvp(flag,tmps,PL_Argv));
562 if (execf == EXECF_TRUEEXEC)
563 rc = execvp(tmps,PL_Argv);
564 else if (execf == EXECF_EXEC)
565 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
566 else if (execf == EXECF_SPAWN_NOWAIT)
567 rc = spawnvp(flag,tmps,PL_Argv);
568 else /* EXECF_SPAWN */
569 rc = result(trueflag,
570 spawnvp(flag,tmps,PL_Argv));
572 if (rc < 0 && pass == 1
573 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
578 if (err == ENOENT || err == ENOEXEC) {
579 /* No such file, or is a script. */
580 /* Try adding script extensions to the file name, and
582 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
591 if (l >= sizeof scrbuf) {
594 croak("Size of scriptname too big: %d", l);
600 file = fopen(scr, "r");
604 if (!fgets(buf, sizeof buf, file)) { /* Empty... */
608 /* Special case: maybe from -Zexe build, so
609 there is an executable around (contrary to
610 documentation, DosQueryAppType sometimes (?)
611 does not append ".exe", so we could have
612 reached this place). */
613 if (l + 5 < sizeof scrbuf) {
614 strcpy(scrbuf + l, ".exe");
615 if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
616 && !S_ISDIR(PL_statbuf.st_mode)) {
626 if (fclose(file) != 0) { /* Failure */
628 warn("Error reading \"%s\": %s",
629 scr, Strerror(errno));
630 buf[0] = 0; /* Not #! */
636 } else if (buf[0] == 'e') {
637 if (strnEQ(buf, "extproc", 7)
640 } else if (buf[0] == 'E') {
641 if (strnEQ(buf, "EXTPROC", 7)
646 buf[0] = 0; /* Not #! */
654 /* Do better than pdksh: allow a few args,
655 strip trailing whitespace. */
665 while (*s && !isSPACE(*s))
672 warn("Too many args on %.*s line of \"%s\"",
683 || (!buf[0] && file)) { /* File without magic */
684 /* In fact we tried all what pdksh would
685 try. There is no point in calling
686 pdksh, we may just emulate its logic. */
687 char *shell = getenv("EXECSHELL");
688 char *shell_opt = NULL;
694 shell = getenv("OS2_SHELL");
695 if (inicmd) { /* No spaces at start! */
697 while (*s && !isSPACE(*s)) {
699 inicmd = NULL; /* Cannot use */
707 /* Dosish shells will choke on slashes
708 in paths, fortunately, this is
709 important for zeroth arg only. */
716 /* If EXECSHELL is set, we do not set */
719 shell = ((_emx_env & 0x200)
722 nargs = shell_opt ? 2 : 1; /* shell file args */
723 exec_args[0] = shell;
724 exec_args[1] = shell_opt;
726 if (nargs == 2 && inicmd) {
727 /* Use the original cmd line */
728 /* XXXX This is good only until we refuse
729 quoted arguments... */
733 } else if (!buf[0] && inicmd) { /* No file */
734 /* Start with the original cmdline. */
735 /* XXXX This is good only until we refuse
736 quoted arguments... */
740 nargs = 2; /* shell -c */
743 while (a[1]) /* Get to the end */
745 a++; /* Copy finil NULL too */
746 while (a >= PL_Argv) {
747 *(a + nargs) = *a; /* PL_Argv was preallocated to be
752 PL_Argv[nargs] = argsp[nargs];
753 /* Enable pathless exec if #! (as pdksh). */
754 pass = (buf[0] == '#' ? 2 : 3);
758 /* Not found: restore errno */
762 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
763 char *no_dir = strrchr(PL_Argv[0], '/');
765 /* Do as pdksh port does: if not found with /, try without
768 PL_Argv[0] = no_dir + 1;
773 if (rc < 0 && PL_dowarn)
774 warn("Can't %s \"%s\": %s\n",
775 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
777 PL_Argv[0], Strerror(errno));
778 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
779 && ((trueflag & 0xFF) == P_WAIT))
780 rc = 255 << 8; /* Emulate the fork(). */
787 do_aspawn(really,mark,sp)
796 int flag = P_WAIT, trueflag, err, secondtry = 0;
799 New(1301,PL_Argv, sp - mark + 3, char*);
802 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
807 while (++mark <= sp) {
809 *a++ = SvPVx(*mark, PL_na);
815 rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL);
822 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
824 do_spawn2(cmd, execf)
831 char *shell, *copt, *news = NULL;
832 int rc, err, seenspace = 0;
833 char fullcmd[MAXNAMLEN + 1];
836 if ((shell = getenv("EMXSHELL")) != NULL)
838 else if ((shell = getenv("SHELL")) != NULL)
840 else if ((shell = getenv("COMSPEC")) != NULL)
845 /* Consensus on perl5-porters is that it is _very_ important to
846 have a shell which will not change between computers with the
847 same architecture, to avoid "action on a distance".
848 And to have simple build, this shell should be sh. */
853 while (*cmd && isSPACE(*cmd))
856 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
857 STRLEN l = strlen(PL_sh_path);
859 New(1302, news, strlen(cmd) - 7 + l + 1, char);
860 strcpy(news, PL_sh_path);
861 strcpy(news + l, cmd + 7);
865 /* save an extra exec if possible */
866 /* see if there are shell metacharacters in it */
868 if (*cmd == '.' && isSPACE(cmd[1]))
871 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
874 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
878 for (s = cmd; *s; s++) {
879 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
880 if (*s == '\n' && s[1] == '\0') {
883 } else if (*s == '\\' && !seenspace) {
884 continue; /* Allow backslashes in names */
886 /* We do not convert this to do_spawn_ve since shell
887 should be smart enough to start itself gloriously. */
889 if (execf == EXECF_TRUEEXEC)
890 rc = execl(shell,shell,copt,cmd,(char*)0);
891 else if (execf == EXECF_EXEC)
892 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
893 else if (execf == EXECF_SPAWN_NOWAIT)
894 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
896 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
898 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
899 if (rc < 0 && PL_dowarn)
900 warn("Can't %s \"%s\": %s",
901 (execf == EXECF_SPAWN ? "spawn" : "exec"),
902 shell, Strerror(errno));
903 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
908 } else if (*s == ' ' || *s == '\t') {
913 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
914 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
915 PL_Cmd = savepvn(cmd, s-cmd);
917 for (s = PL_Cmd; *s;) {
918 while (*s && isSPACE(*s)) s++;
921 while (*s && !isSPACE(*s)) s++;
927 rc = do_spawn_ve(NULL, 0, execf, cmd);
940 return do_spawn2(cmd, EXECF_SPAWN);
947 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
954 do_spawn2(cmd, EXECF_EXEC);
962 return do_spawn2(cmd, EXECF_TRUEEXEC);
966 my_syspopen(cmd,mode)
973 register I32 this, that, newfd;
974 register I32 pid, rc;
978 /* `this' is what we use in the parent, `that' in the child. */
979 this = (*mode == 'w');
983 taint_proper("Insecure %s%s", "EXEC");
987 /* Now we need to spawn the child. */
988 newfd = dup(*mode == 'r'); /* Preserve std* */
989 if (p[that] != (*mode == 'r')) {
990 dup2(p[that], *mode == 'r');
993 /* Where is `this' and newfd now? */
994 fcntl(p[this], F_SETFD, FD_CLOEXEC);
995 fcntl(newfd, F_SETFD, FD_CLOEXEC);
996 pid = do_spawn_nowait(cmd);
997 if (newfd != (*mode == 'r')) {
998 dup2(newfd, *mode == 'r'); /* Return std* back. */
1001 if (p[that] == (*mode == 'r'))
1007 if (p[that] < p[this]) {
1008 dup2(p[this], p[that]);
1012 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1013 (void)SvUPGRADE(sv,SVt_IV);
1015 PL_forkprocess = pid;
1016 return PerlIO_fdopen(p[this], mode);
1018 #else /* USE_POPEN */
1024 res = popen(cmd, mode);
1026 char *shell = getenv("EMXSHELL");
1028 my_setenv("EMXSHELL", PL_sh_path);
1029 res = popen(cmd, mode);
1030 my_setenv("EMXSHELL", shell);
1032 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1033 (void)SvUPGRADE(sv,SVt_IV);
1034 SvIVX(sv) = -1; /* A cooky. */
1037 #endif /* USE_POPEN */
1041 /******************************************************************/
1047 croak(PL_no_func, "Unsupported function fork");
1053 /*******************************************************************/
1054 /* not implemented in EMX 0.9a */
1056 void * ctermid(x) { return 0; }
1058 #ifdef MYTTYNAME /* was not in emx0.9a */
1059 void * ttyname(x) { return 0; }
1062 /******************************************************************/
1063 /* my socket forwarders - EMX lib only provides static forwarders */
1065 static HMODULE htcp = 0;
1070 static BYTE buf[20];
1073 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1075 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1076 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1077 return (void *) ((void * (*)(void)) fcn) ();
1082 tcp1(char *name, int arg)
1084 static BYTE buf[20];
1087 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1089 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1090 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1091 ((void (*)(int)) fcn) (arg);
1094 void * gethostent() { return tcp0("GETHOSTENT"); }
1095 void * getnetent() { return tcp0("GETNETENT"); }
1096 void * getprotoent() { return tcp0("GETPROTOENT"); }
1097 void * getservent() { return tcp0("GETSERVENT"); }
1098 void sethostent(x) { tcp1("SETHOSTENT", x); }
1099 void setnetent(x) { tcp1("SETNETENT", x); }
1100 void setprotoent(x) { tcp1("SETPROTOENT", x); }
1101 void setservent(x) { tcp1("SETSERVENT", x); }
1102 void endhostent() { tcp0("ENDHOSTENT"); }
1103 void endnetent() { tcp0("ENDNETENT"); }
1104 void endprotoent() { tcp0("ENDPROTOENT"); }
1105 void endservent() { tcp0("ENDSERVENT"); }
1107 /*****************************************************************************/
1108 /* not implemented in C Set++ */
1111 int setuid(x) { errno = EINVAL; return -1; }
1112 int setgid(x) { errno = EINVAL; return -1; }
1115 /*****************************************************************************/
1116 /* stat() hack for char/block device */
1120 /* First attempt used DosQueryFSAttach which crashed the system when
1121 used with 5.001. Now just look for /dev/. */
1124 os2_stat(char *name, struct stat *st)
1126 static int ino = SHRT_MAX;
1128 if (stricmp(name, "/dev/con") != 0
1129 && stricmp(name, "/dev/tty") != 0)
1130 return stat(name, st);
1132 memset(st, 0, sizeof *st);
1133 st->st_mode = S_IFCHR|0666;
1134 st->st_ino = (ino-- & 0x7FFF);
1141 #ifdef USE_PERL_SBRK
1143 /* SBRK() emulation, mostly moved to malloc.c. */
1146 sys_alloc(int size) {
1148 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1150 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1153 croak("Got an error from DosAllocMem: %li", (long)rc);
1157 #endif /* USE_PERL_SBRK */
1161 char *tmppath = TMPPATH1;
1166 char *p = getenv("TMP"), *tpath;
1169 if (!p) p = getenv("TEMP");
1172 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1175 strcpy(tpath + len + 1, TMPPATH1);
1181 XS(XS_File__Copy_syscopy)
1184 if (items < 2 || items > 3)
1185 croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
1187 char * src = (char *)SvPV(ST(0),PL_na);
1188 char * dst = (char *)SvPV(ST(1),PL_na);
1195 flag = (unsigned long)SvIV(ST(2));
1198 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1199 ST(0) = sv_newmortal();
1200 sv_setiv(ST(0), (IV)RETVAL);
1205 #include "patchlevel.h"
1211 static char fname[9];
1212 int pos = 6, len, avlen;
1213 unsigned int sum = 0;
1218 if (!SvROK(sv)) croak("Not a reference given to mod2fname");
1220 if (SvTYPE(sv) != SVt_PVAV)
1221 croak("Not array reference given to mod2fname");
1223 avlen = av_len((AV*)sv);
1225 croak("Empty array reference given to mod2fname");
1227 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1228 strncpy(fname, s, 8);
1230 if (len < 6) pos = len;
1232 sum = 33 * sum + *(s++); /* Checksumming first chars to
1233 * get the capitalization into c.s. */
1236 while (avlen >= 0) {
1237 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1239 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1244 sum++; /* Avoid conflict of DLLs in memory. */
1246 sum += PATCHLEVEL * 200 + SUBVERSION * 2; /* */
1247 fname[pos] = 'A' + (sum % 26);
1248 fname[pos + 1] = 'A' + (sum / 26 % 26);
1249 fname[pos + 2] = '\0';
1250 return (char *)fname;
1253 XS(XS_DynaLoader_mod2fname)
1257 croak("Usage: DynaLoader::mod2fname(sv)");
1262 RETVAL = mod2fname(sv);
1263 ST(0) = sv_newmortal();
1264 sv_setpv((SV*)ST(0), RETVAL);
1272 static char buf[300];
1275 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1278 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1279 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1282 if (len > 0 && buf[len - 1] == '\n')
1283 buf[len - 1] = '\0';
1284 if (len > 1 && buf[len - 2] == '\r')
1285 buf[len - 2] = '\0';
1286 if (len > 2 && buf[len - 3] == '.')
1287 buf[len - 3] = '\0';
1292 perllib_mangle(char *s, unsigned int l)
1294 static char *newp, *oldp;
1295 static int newl, oldl, notfound;
1296 static char ret[STATIC_FILE_LENGTH+1];
1298 if (!newp && !notfound) {
1299 newp = getenv("PERLLIB_PREFIX");
1304 while (*newp && !isSPACE(*newp) && *newp != ';') {
1305 newp++; oldl++; /* Skip digits. */
1307 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1308 newp++; /* Skip whitespace. */
1310 newl = strlen(newp);
1311 if (newl == 0 || oldl == 0) {
1312 croak("Malformed PERLLIB_PREFIX");
1317 if (*s == '\\') *s = '/';
1330 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1333 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1334 croak("Malformed PERLLIB_PREFIX");
1336 strcpy(ret + newl, s + oldl);
1341 Perl_hab_GET() /* Needed if perl.h cannot be included */
1343 return perl_hab_GET();
1347 Perl_Register_MQ(int serve)
1352 if (Perl_os2_initial_mode++)
1354 DosGetInfoBlocks(&tib, &pib);
1355 Perl_os2_initial_mode = pib->pib_ultype;
1356 Perl_hmq_refcnt = 1;
1357 /* Try morphing into a PM application. */
1358 if (pib->pib_ultype != 3) /* 2 is VIO */
1359 pib->pib_ultype = 3; /* 3 is PM */
1360 init_PMWIN_entries();
1361 /* 64 messages if before OS/2 3.0, ignored otherwise */
1362 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1366 _exit(188); /* Panic can try to create a window. */
1367 croak("Cannot create a message queue, or morph to a PM application");
1373 Perl_Serve_Messages(int force)
1378 if (Perl_hmq_servers && !force)
1380 if (!Perl_hmq_refcnt)
1381 croak("No message queue");
1382 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1384 if (msg.msg == WM_QUIT)
1385 croak("QUITing...");
1386 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1392 Perl_Process_Messages(int force, I32 *cntp)
1396 if (Perl_hmq_servers && !force)
1398 if (!Perl_hmq_refcnt)
1399 croak("No message queue");
1400 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1403 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1404 if (msg.msg == WM_DESTROY)
1406 if (msg.msg == WM_CREATE)
1409 croak("QUITing...");
1413 Perl_Deregister_MQ(int serve)
1418 if (--Perl_hmq_refcnt == 0) {
1419 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1421 /* Try morphing back from a PM application. */
1422 if (pib->pib_ultype == 3) /* 3 is PM */
1423 pib->pib_ultype = Perl_os2_initial_mode;
1425 warn("Unexpected program mode %d when morphing back from PM",
1430 extern void dlopen();
1431 void *fakedl = &dlopen; /* Pull in dynaloading part. */
1433 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1434 && ((path)[2] == '/' || (path)[2] == '\\'))
1435 #define sys_is_rooted _fnisabs
1436 #define sys_is_relative _fnisrel
1437 #define current_drive _getdrive
1439 #undef chdir /* Was _chdir2. */
1440 #define sys_chdir(p) (chdir(p) == 0)
1441 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1443 static int DOS_harderr_state = -1;
1449 croak("Usage: OS2::Error(harderr, exception)");
1451 int arg1 = SvIV(ST(0));
1452 int arg2 = SvIV(ST(1));
1453 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1454 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1455 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1458 if (CheckOSError(DosError(a)))
1459 croak("DosError(%d) failed", a);
1460 ST(0) = sv_newmortal();
1461 if (DOS_harderr_state >= 0)
1462 sv_setiv(ST(0), DOS_harderr_state);
1463 DOS_harderr_state = RETVAL;
1468 static signed char DOS_suppression_state = -1;
1470 XS(XS_OS2_Errors2Drive)
1474 croak("Usage: OS2::Errors2Drive(drive)");
1477 int suppress = SvOK(sv);
1478 char *s = suppress ? SvPV(sv, PL_na) : NULL;
1479 char drive = (s ? *s : 0);
1482 if (suppress && !isALPHA(drive))
1483 croak("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1484 if (CheckOSError(DosSuppressPopUps((suppress
1485 ? SPU_ENABLESUPPRESSION
1486 : SPU_DISABLESUPPRESSION),
1488 croak("DosSuppressPopUps(%c) failed", drive);
1489 ST(0) = sv_newmortal();
1490 if (DOS_suppression_state > 0)
1491 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1492 else if (DOS_suppression_state == 0)
1493 sv_setpvn(ST(0), "", 0);
1494 DOS_suppression_state = drive;
1499 static const char * const si_fields[QSV_MAX] = {
1501 "MAX_TEXT_SESSIONS",
1505 "DYN_PRI_VARIATION",
1523 "FOREGROUND_FS_SESSION",
1524 "FOREGROUND_PROCESS"
1531 croak("Usage: OS2::SysInfo()");
1533 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1534 APIRET rc = NO_ERROR; /* Return code */
1537 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1538 QSV_MAX, /* information */
1541 croak("DosQuerySysInfo() failed");
1542 EXTEND(SP,2*QSV_MAX);
1543 while (i < QSV_MAX) {
1544 ST(j) = sv_newmortal();
1545 sv_setpv(ST(j++), si_fields[i]);
1546 ST(j) = sv_newmortal();
1547 sv_setiv(ST(j++), si[i]);
1551 XSRETURN(2 * QSV_MAX);
1554 XS(XS_OS2_BootDrive)
1558 croak("Usage: OS2::BootDrive()");
1560 ULONG si[1] = {0}; /* System Information Data Buffer */
1561 APIRET rc = NO_ERROR; /* Return code */
1564 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1565 (PVOID)si, sizeof(si))))
1566 croak("DosQuerySysInfo() failed");
1567 ST(0) = sv_newmortal();
1568 c = 'a' - 1 + si[0];
1569 sv_setpvn(ST(0), &c, 1);
1578 croak("Usage: OS2::MorphPM(serve)");
1580 bool serve = SvOK(ST(0));
1581 unsigned long pmq = perl_hmq_GET(serve);
1583 ST(0) = sv_newmortal();
1584 sv_setiv(ST(0), pmq);
1589 XS(XS_OS2_UnMorphPM)
1593 croak("Usage: OS2::UnMorphPM(serve)");
1595 bool serve = SvOK(ST(0));
1597 perl_hmq_UNSET(serve);
1602 XS(XS_OS2_Serve_Messages)
1606 croak("Usage: OS2::Serve_Messages(force)");
1608 bool force = SvOK(ST(0));
1609 unsigned long cnt = Perl_Serve_Messages(force);
1611 ST(0) = sv_newmortal();
1612 sv_setiv(ST(0), cnt);
1617 XS(XS_OS2_Process_Messages)
1620 if (items < 1 || items > 2)
1621 croak("Usage: OS2::Process_Messages(force [, cnt])");
1623 bool force = SvOK(ST(0));
1629 int fake = SvIV(sv); /* Force SvIVX */
1632 croak("Can't upgrade count to IV");
1635 cnt = Perl_Process_Messages(force, cntp);
1636 ST(0) = sv_newmortal();
1637 sv_setiv(ST(0), cnt);
1642 XS(XS_Cwd_current_drive)
1646 croak("Usage: Cwd::current_drive()");
1650 RETVAL = current_drive();
1651 ST(0) = sv_newmortal();
1652 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1657 XS(XS_Cwd_sys_chdir)
1661 croak("Usage: Cwd::sys_chdir(path)");
1663 char * path = (char *)SvPV(ST(0),PL_na);
1666 RETVAL = sys_chdir(path);
1667 ST(0) = boolSV(RETVAL);
1668 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1673 XS(XS_Cwd_change_drive)
1677 croak("Usage: Cwd::change_drive(d)");
1679 char d = (char)*SvPV(ST(0),PL_na);
1682 RETVAL = change_drive(d);
1683 ST(0) = boolSV(RETVAL);
1684 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1689 XS(XS_Cwd_sys_is_absolute)
1693 croak("Usage: Cwd::sys_is_absolute(path)");
1695 char * path = (char *)SvPV(ST(0),PL_na);
1698 RETVAL = sys_is_absolute(path);
1699 ST(0) = boolSV(RETVAL);
1700 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1705 XS(XS_Cwd_sys_is_rooted)
1709 croak("Usage: Cwd::sys_is_rooted(path)");
1711 char * path = (char *)SvPV(ST(0),PL_na);
1714 RETVAL = sys_is_rooted(path);
1715 ST(0) = boolSV(RETVAL);
1716 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1721 XS(XS_Cwd_sys_is_relative)
1725 croak("Usage: Cwd::sys_is_relative(path)");
1727 char * path = (char *)SvPV(ST(0),PL_na);
1730 RETVAL = sys_is_relative(path);
1731 ST(0) = boolSV(RETVAL);
1732 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1741 croak("Usage: Cwd::sys_cwd()");
1745 RETVAL = _getcwd2(p, MAXPATHLEN);
1746 ST(0) = sv_newmortal();
1747 sv_setpv((SV*)ST(0), RETVAL);
1752 XS(XS_Cwd_sys_abspath)
1755 if (items < 1 || items > 2)
1756 croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1758 char * path = (char *)SvPV(ST(0),PL_na);
1766 dir = (char *)SvPV(ST(1),PL_na);
1768 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1772 if (_abspath(p, path, MAXPATHLEN) == 0) {
1778 /* Absolute with drive: */
1779 if ( sys_is_absolute(path) ) {
1780 if (_abspath(p, path, MAXPATHLEN) == 0) {
1785 } else if (path[0] == '/' || path[0] == '\\') {
1786 /* Rooted, but maybe on different drive. */
1787 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1788 char p1[MAXPATHLEN];
1790 /* Need to prepend the drive. */
1793 Copy(path, p1 + 2, strlen(path) + 1, char);
1795 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1800 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1806 /* Either path is relative, or starts with a drive letter. */
1807 /* If the path starts with a drive letter, then dir is
1809 a/b) it is absolute/x:relative on the same drive.
1810 c) path is on current drive, and dir is rooted
1811 In all the cases it is safe to drop the drive part
1813 if ( !sys_is_relative(path) ) {
1816 if ( ( ( sys_is_absolute(dir)
1817 || (isALPHA(dir[0]) && dir[1] == ':'
1818 && strnicmp(dir, path,1) == 0))
1819 && strnicmp(dir, path,1) == 0)
1820 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1821 && toupper(path[0]) == current_drive())) {
1823 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1824 RETVAL = p; goto done;
1826 RETVAL = NULL; goto done;
1830 /* Need to prepend the absolute path of dir. */
1831 char p1[MAXPATHLEN];
1833 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1836 if (p1[ l - 1 ] != '/') {
1840 Copy(path, p1 + l, strlen(path) + 1, char);
1841 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1853 ST(0) = sv_newmortal();
1854 sv_setpv((SV*)ST(0), RETVAL);
1858 typedef APIRET (*PELP)(PSZ path, ULONG type);
1861 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1863 loadByOrd("doscalls",ord); /* Guarantied to load or die! */
1864 return (*(PELP)ExtFCN[ord])(path, type);
1867 #define extLibpath(type) \
1868 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1869 : BEGIN_LIBPATH))) \
1872 #define extLibpath_set(p,type) \
1873 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1876 XS(XS_Cwd_extLibpath)
1879 if (items < 0 || items > 1)
1880 croak("Usage: Cwd::extLibpath(type = 0)");
1890 type = (int)SvIV(ST(0));
1893 RETVAL = extLibpath(type);
1894 ST(0) = sv_newmortal();
1895 sv_setpv((SV*)ST(0), RETVAL);
1900 XS(XS_Cwd_extLibpath_set)
1903 if (items < 1 || items > 2)
1904 croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1906 char * s = (char *)SvPV(ST(0),PL_na);
1914 type = (int)SvIV(ST(1));
1917 RETVAL = extLibpath_set(s, type);
1918 ST(0) = boolSV(RETVAL);
1919 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1927 char *file = __FILE__;
1931 if (_emx_env & 0x200) { /* OS/2 */
1932 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1933 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1934 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1936 newXS("OS2::Error", XS_OS2_Error, file);
1937 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
1938 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
1939 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
1940 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
1941 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
1942 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
1943 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
1944 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1945 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1946 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1947 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1948 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1949 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1950 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1951 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1952 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1953 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1956 sv_setiv(GvSV(gv), 1);
1958 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
1960 sv_setiv(GvSV(gv), _emx_rev);
1961 sv_setpv(GvSV(gv), _emx_vprt);
1963 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
1965 sv_setiv(GvSV(gv), _emx_env);
1966 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
1968 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
1972 OS2_Perl_data_t OS2_Perl_data;
1975 Perl_OS2_init(char **env)
1981 OS2_Perl_data.xs_init = &Xs_OS2_init;
1982 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
1983 if (environ == NULL) {
1986 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1987 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
1988 strcpy(PL_sh_path, SH_PATH);
1989 PL_sh_path[0] = shell[0];
1990 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1991 int l = strlen(shell), i;
1992 if (shell[l-1] == '/' || shell[l-1] == '\\') {
1995 New(1304, PL_sh_path, l + 8, char);
1996 strncpy(PL_sh_path, shell, l);
1997 strcpy(PL_sh_path + l, "/sh.exe");
1998 for (i = 0; i < l; i++) {
1999 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2002 MUTEX_INIT(&start_thread_mutex);
2003 os2_mytype = my_type(); /* Do it before morphing. Needed? */
2010 my_tmpnam (char *str)
2012 char *p = getenv("TMP"), *tpath;
2015 if (!p) p = getenv("TEMP");
2016 tpath = tempnam(p, "pltmp");
2030 if (s.st_mode & S_IWOTH) {
2033 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2039 /* This code was contributed by Rocco Caputo. */
2041 my_flock(int handle, int o)
2043 FILELOCK rNull, rFull;
2044 ULONG timeout, handle_type, flag_word;
2046 int blocking, shared;
2047 static int use_my = -1;
2050 char *s = getenv("USE_PERL_FLOCK");
2056 if (!(_emx_env & 0x200) || !use_my)
2057 return flock(handle, o); /* Delegate to EMX. */
2060 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2061 (handle_type & 0xFF))
2066 // set lock/unlock ranges
2067 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2068 rFull.lRange = 0x7FFFFFFF;
2069 // set timeout for blocking
2070 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2071 // shared or exclusive?
2072 shared = (o & LOCK_SH) ? 1 : 0;
2073 // do not block the unlock
2074 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2075 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2080 case ERROR_INVALID_HANDLE:
2083 case ERROR_SHARING_BUFFER_EXCEEDED:
2086 case ERROR_LOCK_VIOLATION:
2087 break; // not an error
2088 case ERROR_INVALID_PARAMETER:
2089 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2090 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2093 case ERROR_INTERRUPT:
2102 if (o & (LOCK_SH | LOCK_EX)) {
2103 // for blocking operations
2117 case ERROR_INVALID_HANDLE:
2120 case ERROR_SHARING_BUFFER_EXCEEDED:
2123 case ERROR_LOCK_VIOLATION:
2125 errno = EWOULDBLOCK;
2129 case ERROR_INVALID_PARAMETER:
2130 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2131 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2134 case ERROR_INTERRUPT:
2141 // give away timeslice