#define INCL_DOS
#define INCL_NOPM
#define INCL_DOSFILEMGR
#define INCL_DOSMEMMGR
#define INCL_DOSERRORS
#include <os2.h>
#include <sys/uflags.h>
/*
* Various Unix compatibility functions for OS/2
*/
#include <stdio.h>
#include <errno.h>
#include <limits.h>
#include <process.h>
#include <fcntl.h>
#include "EXTERN.h"
#include "perl.h"
#ifdef USE_THREADS
typedef void (*emx_startroutine)(void *);
typedef void* (*pthreads_startroutine)(void *);
enum pthreads_state {
pthreads_st_none = 0,
pthreads_st_run,
pthreads_st_exited,
pthreads_st_detached,
pthreads_st_waited,
};
const char *pthreads_states[] = {
"uninit",
"running",
"exited",
"detached",
"waited for",
};
typedef struct {
void *status;
perl_cond cond;
enum pthreads_state state;
} thread_join_t;
thread_join_t *thread_join_data;
int thread_join_count;
perl_mutex start_thread_mutex;
int
pthread_join(perl_os_thread tid, void **status)
{
MUTEX_LOCK(&start_thread_mutex);
switch (thread_join_data[tid].state) {
case pthreads_st_exited:
thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
MUTEX_UNLOCK(&start_thread_mutex);
*status = thread_join_data[tid].status;
break;
case pthreads_st_waited:
MUTEX_UNLOCK(&start_thread_mutex);
croak("join with a thread with a waiter");
break;
case pthreads_st_run:
thread_join_data[tid].state = pthreads_st_waited;
COND_INIT(&thread_join_data[tid].cond);
MUTEX_UNLOCK(&start_thread_mutex);
COND_WAIT(&thread_join_data[tid].cond, NULL);
COND_DESTROY(&thread_join_data[tid].cond);
thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
*status = thread_join_data[tid].status;
break;
default:
MUTEX_UNLOCK(&start_thread_mutex);
croak("join: unknown thread state: '%s'",
pthreads_states[thread_join_data[tid].state]);
break;
}
return 0;
}
void
pthread_startit(void *arg)
{
/* Thread is already started, we need to transfer control only */
pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
int tid = pthread_self();
void *retval;
arg = ((void**)arg)[1];
if (tid >= thread_join_count) {
int oc = thread_join_count;
thread_join_count = tid + 5 + tid/5;
if (thread_join_data) {
Renew(thread_join_data, thread_join_count, thread_join_t);
Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
} else {
Newz(1323, thread_join_data, thread_join_count, thread_join_t);
}
}
if (thread_join_data[tid].state != pthreads_st_none)
croak("attempt to reuse thread id %i", tid);
thread_join_data[tid].state = pthreads_st_run;
/* Now that we copied/updated the guys, we may release the caller... */
MUTEX_UNLOCK(&start_thread_mutex);
thread_join_data[tid].status = (*start_routine)(arg);
switch (thread_join_data[tid].state) {
case pthreads_st_waited:
COND_SIGNAL(&thread_join_data[tid].cond);
break;
default:
thread_join_data[tid].state = pthreads_st_exited;
break;
}
}
int
pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
void *(*start_routine)(void*), void *arg)
{
void *args[2];
args[0] = (void*)start_routine;
args[1] = arg;
MUTEX_LOCK(&start_thread_mutex);
*tid = _beginthread(pthread_startit, /*stack*/ NULL,
/*stacksize*/ 10*1024*1024, (void*)args);
MUTEX_LOCK(&start_thread_mutex);
MUTEX_UNLOCK(&start_thread_mutex);
return *tid ? 0 : EINVAL;
}
int
pthread_detach(perl_os_thread tid)
{
MUTEX_LOCK(&start_thread_mutex);
switch (thread_join_data[tid].state) {
case pthreads_st_waited:
MUTEX_UNLOCK(&start_thread_mutex);
croak("detach on a thread with a waiter");
break;
case pthreads_st_run:
thread_join_data[tid].state = pthreads_st_detached;
MUTEX_UNLOCK(&start_thread_mutex);
break;
default:
MUTEX_UNLOCK(&start_thread_mutex);
croak("detach: unknown thread state: '%s'",
pthreads_states[thread_join_data[tid].state]);
break;
}
return 0;
}
/* This is a very bastardized version: */
int
os2_cond_wait(perl_cond *c, perl_mutex *m)
{
int rc;
STRLEN n_a;
if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
croak("panic: COND_WAIT-reset: rc=%i", rc);
if (m) MUTEX_UNLOCK(m);
if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
&& (rc != ERROR_INTERRUPT))
croak("panic: COND_WAIT: rc=%i", rc);
if (rc == ERROR_INTERRUPT)
errno = EINTR;
if (m) MUTEX_LOCK(m);
}
#endif
/*****************************************************************************/
/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
static PFN ExtFCN[2]; /* Labeled by ord below. */
static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
#define ORD_QUERY_ELP 0
#define ORD_SET_ELP 1
APIRET
loadByOrd(ULONG ord)
{
if (ExtFCN[ord] == NULL) {
static HMODULE hdosc = 0;
BYTE buf[20];
PFN fcn;
APIRET rc;
if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
"doscalls", &hdosc)))
|| CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
die("This version of OS/2 does not support doscalls.%i",
loadOrd[ord]);
ExtFCN[ord] = fcn;
}
if ((long)ExtFCN[ord] == -1) die("panic queryaddr");
}
/* priorities */
static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
self inverse. */
#define QSS_INI_BUFFER 1024
PQTOPLEVEL
get_sysinfo(ULONG pid, ULONG flags)
{
char *pbuffer;
ULONG rc, buf_len = QSS_INI_BUFFER;
New(1322, pbuffer, buf_len, char);
/* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
rc = QuerySysState(flags, pid, pbuffer, buf_len);
while (rc == ERROR_BUFFER_OVERFLOW) {
Renew(pbuffer, buf_len *= 2, char);
rc = QuerySysState(flags, pid, pbuffer, buf_len);
}
if (rc) {
FillOSError(rc);
Safefree(pbuffer);
return 0;
}
return (PQTOPLEVEL)pbuffer;
}
#define PRIO_ERR 0x1111
static ULONG
sys_prio(pid)
{
ULONG prio;
PQTOPLEVEL psi;
psi = get_sysinfo(pid, QSS_PROCESS);
if (!psi) {
return PRIO_ERR;
}
if (pid != psi->procdata->pid) {
Safefree(psi);
croak("panic: wrong pid in sysinfo");
}
prio = psi->procdata->threads->priority;
Safefree(psi);
return prio;
}
int
setpriority(int which, int pid, int val)
{
ULONG rc, prio;
PQTOPLEVEL psi;
prio = sys_prio(pid);
if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
/* Do not change class. */
return CheckOSError(DosSetPriority((pid < 0)
? PRTYS_PROCESSTREE : PRTYS_PROCESS,
0,
(32 - val) % 32 - (prio & 0xFF),
abs(pid)))
? -1 : 0;
} else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
/* Documentation claims one can change both class and basevalue,
* but I find it wrong. */
/* Change class, but since delta == 0 denotes absolute 0, correct. */
if (CheckOSError(DosSetPriority((pid < 0)
? PRTYS_PROCESSTREE : PRTYS_PROCESS,
priors[(32 - val) >> 5] + 1,
0,
abs(pid))))
return -1;
if ( ((32 - val) % 32) == 0 ) return 0;
return CheckOSError(DosSetPriority((pid < 0)
? PRTYS_PROCESSTREE : PRTYS_PROCESS,
0,
(32 - val) % 32,
abs(pid)))
? -1 : 0;
}
/* else return CheckOSError(DosSetPriority((pid < 0) */
/* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
/* priors[(32 - val) >> 5] + 1, */
/* (32 - val) % 32 - (prio & 0xFF), */
/* abs(pid))) */
/* ? -1 : 0; */
}
int
getpriority(int which /* ignored */, int pid)
{
TIB *tib;
PIB *pib;
ULONG rc, ret;
if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
/* DosGetInfoBlocks has old priority! */
/* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
/* if (pid != pib->pib_ulpid) { */
ret = sys_prio(pid);
if (ret == PRIO_ERR) {
return -1;
}
/* } else */
/* ret = tib->tib_ptib2->tib2_ulpri; */
return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
}
/*****************************************************************************/
/* spawn */
/* There is no big sense to make it thread-specific, since signals
are delivered to thread 1 only. XXXX Maybe make it into an array? */
static int spawn_pid;
static int spawn_killed;
static Signal_t
spawn_sighandler(int sig)
{
/* Some programs do not arrange for the keyboard signals to be
delivered to them. We need to deliver the signal manually. */
/* We may get a signal only if
a) kid does not receive keyboard signal: deliver it;
b) kid already died, and we get a signal. We may only hope
that the pid number was not reused.
*/
if (spawn_killed)
sig = SIGKILL; /* Try harder. */
kill(spawn_pid, sig);
spawn_killed = 1;
}
static int
result(int flag, int pid)
{
int r, status;
Signal_t (*ihand)(); /* place to save signal during system() */
Signal_t (*qhand)(); /* place to save signal during system() */
#ifndef __EMX__
RESULTCODES res;
int rpid;
#endif
if (pid < 0 || flag != 0)
return pid;
#ifdef __EMX__
spawn_pid = pid;
spawn_killed = 0;
ihand = rsignal(SIGINT, &spawn_sighandler);
qhand = rsignal(SIGQUIT, &spawn_sighandler);
do {
r = wait4pid(pid, &status, 0);
} while (r == -1 && errno == EINTR);
rsignal(SIGINT, ihand);
rsignal(SIGQUIT, qhand);
PL_statusvalue = (U16)status;
if (r < 0)
return -1;
return status & 0xFFFF;
#else
ihand = rsignal(SIGINT, SIG_IGN);
r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
rsignal(SIGINT, ihand);
PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
if (r)
return -1;
return PL_statusvalue;
#endif
}
#define EXECF_SPAWN 0
#define EXECF_EXEC 1
#define EXECF_TRUEEXEC 2
#define EXECF_SPAWN_NOWAIT 3
/* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
static int
my_type()
{
int rc;
TIB *tib;
PIB *pib;
if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
return -1;
return (pib->pib_ultype);
}
static ULONG
file_type(char *path)
{
int rc;
ULONG apptype;
if (!(_emx_env & 0x200))
croak("file_type not implemented on DOS"); /* not OS/2. */
if (CheckOSError(DosQueryAppType(path, &apptype))) {
switch (rc) {
case ERROR_FILE_NOT_FOUND:
case ERROR_PATH_NOT_FOUND:
return -1;
case ERROR_ACCESS_DENIED: /* Directory with this name found? */
return -3;
default: /* Found, but not an
executable, or some other
read error. */
return -2;
}
}
return apptype;
}
static ULONG os2_mytype;
/* Spawn/exec a program, revert to shell if needed. */
/* global PL_Argv[] contains arguments. */
int
do_spawn_ve(really, flag, execf, inicmd)
SV *really;
U32 flag;
U32 execf;
char *inicmd;
{
dTHR;
int trueflag = flag;
int rc, pass = 1;
char *tmps;
char buf[256], *s = 0, scrbuf[280];
char *args[4];
static char * fargs[4]
= { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
char **argsp = fargs;
char nargs = 4;
int force_shell;
STRLEN n_a;
if (flag == P_WAIT)
flag = P_NOWAIT;
retry:
if (strEQ(PL_Argv[0],"/bin/sh"))
PL_Argv[0] = PL_sh_path;
if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
&& !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
&& (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
) /* will spawnvp use PATH? */
TAINT_ENV(); /* testing IFS here is overkill, probably */
/* We should check PERL_SH* and PERLLIB_* as well? */
if (!really || !*(tmps = SvPV(really, n_a)))
tmps = PL_Argv[0];
reread:
force_shell = 0;
if (_emx_env & 0x200) { /* OS/2. */
int type = file_type(tmps);
type_again:
if (type == -1) { /* Not found */
errno = ENOENT;
rc = -1;
goto do_script;
}
else if (type == -2) { /* Not an EXE */
errno = ENOEXEC;
rc = -1;
goto do_script;
}
else if (type == -3) { /* Is a directory? */
/* Special-case this */
char tbuf[512];
int l = strlen(tmps);
if (l + 5 <= sizeof tbuf) {
strcpy(tbuf, tmps);
strcpy(tbuf + l, ".exe");
type = file_type(tbuf);
if (type >= -3)
goto type_again;
}
errno = ENOEXEC;
rc = -1;
goto do_script;
}
switch (type & 7) {
/* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
case FAPPTYP_WINDOWAPI:
{
if (os2_mytype != 3) { /* not PM */
if (flag == P_NOWAIT)
flag = P_PM;
else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
warn("Starting PM process with flag=%d, mytype=%d",
flag, os2_mytype);
}
}
break;
case FAPPTYP_NOTWINDOWCOMPAT:
{
if (os2_mytype != 0) { /* not full screen */
if (flag == P_NOWAIT)
flag = P_SESSION;
else if ((flag & 7) != P_SESSION)
warn("Starting Full Screen process with flag=%d, mytype=%d",
flag, os2_mytype);
}
}
break;
case FAPPTYP_NOTSPEC:
/* Let the shell handle this... */
force_shell = 1;
goto doshell_args;
break;
}
}
#if 0
rc = result(trueflag, spawnvp(flag,tmps,PL_Argv));
#else
if (execf == EXECF_TRUEEXEC)
rc = execvp(tmps,PL_Argv);
else if (execf == EXECF_EXEC)
rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
else if (execf == EXECF_SPAWN_NOWAIT)
rc = spawnvp(flag,tmps,PL_Argv);
else /* EXECF_SPAWN */
rc = result(trueflag,
spawnvp(flag,tmps,PL_Argv));
#endif
if (rc < 0 && pass == 1
&& (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
do_script:
{
int err = errno;
if (err == ENOENT || err == ENOEXEC) {
/* No such file, or is a script. */
/* Try adding script extensions to the file name, and
search on PATH. */
char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
if (scr) {
FILE *file;
char *s = 0, *s1;
int l;
l = strlen(scr);
if (l >= sizeof scrbuf) {
Safefree(scr);
longbuf:
croak("Size of scriptname too big: %d", l);
}
strcpy(scrbuf, scr);
Safefree(scr);
scr = scrbuf;
file = fopen(scr, "r");
PL_Argv[0] = scr;
if (!file)
goto panic_file;
if (!fgets(buf, sizeof buf, file)) { /* Empty... */
buf[0] = 0;
fclose(file);
/* Special case: maybe from -Zexe build, so
there is an executable around (contrary to
documentation, DosQueryAppType sometimes (?)
does not append ".exe", so we could have
reached this place). */
if (l + 5 < sizeof scrbuf) {
strcpy(scrbuf + l, ".exe");
if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
&& !S_ISDIR(PL_statbuf.st_mode)) {
/* Found */
tmps = scr;
pass++;
goto reread;
} else
scrbuf[l] = 0;
} else
goto longbuf;
}
if (fclose(file) != 0) { /* Failure */
panic_file:
warn("Error reading \"%s\": %s",
scr, Strerror(errno));
buf[0] = 0; /* Not #! */
goto doshell_args;
}
if (buf[0] == '#') {
if (buf[1] == '!')
s = buf + 2;
} else if (buf[0] == 'e') {
if (strnEQ(buf, "extproc", 7)
&& isSPACE(buf[7]))
s = buf + 8;
} else if (buf[0] == 'E') {
if (strnEQ(buf, "EXTPROC", 7)
&& isSPACE(buf[7]))
s = buf + 8;
}
if (!s) {
buf[0] = 0; /* Not #! */
goto doshell_args;
}
s1 = s;
nargs = 0;
argsp = args;
while (1) {
/* Do better than pdksh: allow a few args,
strip trailing whitespace. */
while (isSPACE(*s))
s++;
if (*s == 0)
break;
if (nargs == 4) {
nargs = -1;
break;
}
args[nargs++] = s;
while (*s && !isSPACE(*s))
s++;
if (*s == 0)
break;
*s++ = 0;
}
if (nargs == -1) {
warn("Too many args on %.*s line of \"%s\"",
s1 - buf, buf, scr);
nargs = 4;
argsp = fargs;
}
doshell_args:
{
char **a = PL_Argv;
char *exec_args[2];
if (force_shell
|| (!buf[0] && file)) { /* File without magic */
/* In fact we tried all what pdksh would
try. There is no point in calling
pdksh, we may just emulate its logic. */
char *shell = getenv("EXECSHELL");
char *shell_opt = NULL;
if (!shell) {
char *s;
shell_opt = "/c";
shell = getenv("OS2_SHELL");
if (inicmd) { /* No spaces at start! */
s = inicmd;
while (*s && !isSPACE(*s)) {
if (*s++ = '/') {
inicmd = NULL; /* Cannot use */
break;
}
}
}
if (!inicmd) {
s = PL_Argv[0];
while (*s) {
/* Dosish shells will choke on slashes
in paths, fortunately, this is
important for zeroth arg only. */
if (*s == '/')
*s = '\\';
s++;
}
}
}
/* If EXECSHELL is set, we do not set */
if (!shell)
shell = ((_emx_env & 0x200)
? "c:/os2/cmd.exe"
: "c:/command.com");
nargs = shell_opt ? 2 : 1; /* shell file args */
exec_args[0] = shell;
exec_args[1] = shell_opt;
argsp = exec_args;
if (nargs == 2 && inicmd) {
/* Use the original cmd line */
/* XXXX This is good only until we refuse
quoted arguments... */
PL_Argv[0] = inicmd;
PL_Argv[1] = Nullch;
}
} else if (!buf[0] && inicmd) { /* No file */
/* Start with the original cmdline. */
/* XXXX This is good only until we refuse
quoted arguments... */
PL_Argv[0] = inicmd;
PL_Argv[1] = Nullch;
nargs = 2; /* shell -c */
}
while (a[1]) /* Get to the end */
a++;
a++; /* Copy finil NULL too */
while (a >= PL_Argv) {
*(a + nargs) = *a; /* PL_Argv was preallocated to be
long enough. */
a--;
}
while (nargs-- >= 0)
PL_Argv[nargs] = argsp[nargs];
/* Enable pathless exec if #! (as pdksh). */
pass = (buf[0] == '#' ? 2 : 3);
goto retry;
}
}
/* Not found: restore errno */
errno = err;
}
}
} else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
char *no_dir = strrchr(PL_Argv[0], '/');
/* Do as pdksh port does: if not found with /, try without
path. */
if (no_dir) {
PL_Argv[0] = no_dir + 1;
pass++;
goto retry;
}
}
if (rc < 0 && PL_dowarn)
warn("Can't %s \"%s\": %s\n",
((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
? "spawn" : "exec"),
PL_Argv[0], Strerror(errno));
if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
&& ((trueflag & 0xFF) == P_WAIT))
rc = 255 << 8; /* Emulate the fork(). */
return rc;
}
/* Array spawn. */
int
do_aspawn(really,mark,sp)
SV *really;
register SV **mark;
register SV **sp;
{
dTHR;
register char **a;
char *tmps = NULL;
int rc;
int flag = P_WAIT, trueflag, err, secondtry = 0;
STRLEN n_a;
if (sp > mark) {
New(1301,PL_Argv, sp - mark + 3, char*);
a = PL_Argv;
if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
++mark;
flag = SvIVx(*mark);
}
while (++mark <= sp) {
if (*mark)
*a++ = SvPVx(*mark, n_a);
else
*a++ = "";
}
*a = Nullch;
rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL);
} else
rc = -1;
do_execfree();
return rc;
}
/* Try converting 1-arg form to (usually shell-less) multi-arg form. */
int
do_spawn2(cmd, execf)
char *cmd;
int execf;
{
register char **a;
register char *s;
char flags[10];
char *shell, *copt, *news = NULL;
int rc, err, seenspace = 0;
char fullcmd[MAXNAMLEN + 1];
#ifdef TRYSHELL
if ((shell = getenv("EMXSHELL")) != NULL)
copt = "-c";
else if ((shell = getenv("SHELL")) != NULL)
copt = "-c";
else if ((shell = getenv("COMSPEC")) != NULL)
copt = "/C";
else
shell = "cmd.exe";
#else
/* Consensus on perl5-porters is that it is _very_ important to
have a shell which will not change between computers with the
same architecture, to avoid "action on a distance".
And to have simple build, this shell should be sh. */
shell = PL_sh_path;
copt = "-c";
#endif
while (*cmd && isSPACE(*cmd))
cmd++;
if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
STRLEN l = strlen(PL_sh_path);
New(1302, news, strlen(cmd) - 7 + l + 1, char);
strcpy(news, PL_sh_path);
strcpy(news + l, cmd + 7);
cmd = news;
}
/* save an extra exec if possible */
/* see if there are shell metacharacters in it */
if (*cmd == '.' && isSPACE(cmd[1]))
goto doshell;
if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
goto doshell;
for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
if (*s == '=')
goto doshell;
for (s = cmd; *s; s++) {
if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
if (*s == '\n' && s[1] == '\0') {
*s = '\0';
break;
} else if (*s == '\\' && !seenspace) {
continue; /* Allow backslashes in names */
}
/* We do not convert this to do_spawn_ve since shell
should be smart enough to start itself gloriously. */
doshell:
if (execf == EXECF_TRUEEXEC)
rc = execl(shell,shell,copt,cmd,(char*)0);
else if (execf == EXECF_EXEC)
rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
else if (execf == EXECF_SPAWN_NOWAIT)
rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
else {
/* In the ak code internal P_NOWAIT is P_WAIT ??? */
rc = result(P_WAIT,
spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
if (rc < 0 && PL_dowarn)
warn("Can't %s \"%s\": %s",
(execf == EXECF_SPAWN ? "spawn" : "exec"),
shell, Strerror(errno));
if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
}
if (news)
Safefree(news);
return rc;
} else if (*s == ' ' || *s == '\t') {
seenspace = 1;
}
}
/* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
PL_Cmd = savepvn(cmd, s-cmd);
a = PL_Argv;
for (s = PL_Cmd; *s;) {
while (*s && isSPACE(*s)) s++;
if (*s)
*(a++) = s;
while (*s && !isSPACE(*s)) s++;
if (*s)
*s++ = '\0';
}
*a = Nullch;
if (PL_Argv[0])
rc = do_spawn_ve(NULL, 0, execf, cmd);
else
rc = -1;
if (news)
Safefree(news);
do_execfree();
return rc;
}
int
do_spawn(cmd)
char *cmd;
{
return do_spawn2(cmd, EXECF_SPAWN);
}
int
do_spawn_nowait(cmd)
char *cmd;
{
return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
}
bool
do_exec(cmd)
char *cmd;
{
do_spawn2(cmd, EXECF_EXEC);
return FALSE;
}
bool
os2exec(cmd)
char *cmd;
{
return do_spawn2(cmd, EXECF_TRUEEXEC);
}
PerlIO *
my_syspopen(cmd,mode)
char *cmd;
char *mode;
{
#ifndef USE_POPEN
int p[2];
register I32 this, that, newfd;
register I32 pid, rc;
PerlIO *res;
SV *sv;
/* `this' is what we use in the parent, `that' in the child. */
this = (*mode == 'w');
that = !this;
if (PL_tainting) {
taint_env();
taint_proper("Insecure %s%s", "EXEC");
}
if (pipe(p) < 0)
return Nullfp;
/* Now we need to spawn the child. */
newfd = dup(*mode == 'r'); /* Preserve std* */
if (p[that] != (*mode == 'r')) {
dup2(p[that], *mode == 'r');
close(p[that]);
}
/* Where is `this' and newfd now? */
fcntl(p[this], F_SETFD, FD_CLOEXEC);
fcntl(newfd, F_SETFD, FD_CLOEXEC);
pid = do_spawn_nowait(cmd);
if (newfd != (*mode == 'r')) {
dup2(newfd, *mode == 'r'); /* Return std* back. */
close(newfd);
}
if (p[that] == (*mode == 'r'))
close(p[that]);
if (pid == -1) {
close(p[this]);
return NULL;
}
if (p[that] < p[this]) {
dup2(p[this], p[that]);
close(p[this]);
p[this] = p[that];
}
sv = *av_fetch(PL_fdpid,p[this],TRUE);
(void)SvUPGRADE(sv,SVt_IV);
SvIVX(sv) = pid;
PL_forkprocess = pid;
return PerlIO_fdopen(p[this], mode);
#else /* USE_POPEN */
PerlIO *res;
SV *sv;
# ifdef TRYSHELL
res = popen(cmd, mode);
# else
char *shell = getenv("EMXSHELL");
my_setenv("EMXSHELL", PL_sh_path);
res = popen(cmd, mode);
my_setenv("EMXSHELL", shell);
# endif
sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
(void)SvUPGRADE(sv,SVt_IV);
SvIVX(sv) = -1; /* A cooky. */
return res;
#endif /* USE_POPEN */
}
/******************************************************************/
#ifndef HAS_FORK
int
fork(void)
{
die(PL_no_func, "Unsupported function fork");
errno = EINVAL;
return -1;
}
#endif
/*******************************************************************/
/* not implemented in EMX 0.9a */
void * ctermid(x) { return 0; }
#ifdef MYTTYNAME /* was not in emx0.9a */
void * ttyname(x) { return 0; }
#endif
/******************************************************************/
/* my socket forwarders - EMX lib only provides static forwarders */
static HMODULE htcp = 0;
static void *
tcp0(char *name)
{
static BYTE buf[20];
PFN fcn;
if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
if (!htcp)
DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
return (void *) ((void * (*)(void)) fcn) ();
return 0;
}
static void
tcp1(char *name, int arg)
{
static BYTE buf[20];
PFN fcn;
if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
if (!htcp)
DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
((void (*)(int)) fcn) (arg);
}
void * gethostent() { return tcp0("GETHOSTENT"); }
void * getnetent() { return tcp0("GETNETENT"); }
void * getprotoent() { return tcp0("GETPROTOENT"); }
void * getservent() { return tcp0("GETSERVENT"); }
void sethostent(x) { tcp1("SETHOSTENT", x); }
void setnetent(x) { tcp1("SETNETENT", x); }
void setprotoent(x) { tcp1("SETPROTOENT", x); }
void setservent(x) { tcp1("SETSERVENT", x); }
void endhostent() { tcp0("ENDHOSTENT"); }
void endnetent() { tcp0("ENDNETENT"); }
void endprotoent() { tcp0("ENDPROTOENT"); }
void endservent() { tcp0("ENDSERVENT"); }
/*****************************************************************************/
/* not implemented in C Set++ */
#ifndef __EMX__
int setuid(x) { errno = EINVAL; return -1; }
int setgid(x) { errno = EINVAL; return -1; }
#endif
/*****************************************************************************/
/* stat() hack for char/block device */
#if OS2_STAT_HACK
/* First attempt used DosQueryFSAttach which crashed the system when
used with 5.001. Now just look for /dev/. */
int
os2_stat(char *name, struct stat *st)
{
static int ino = SHRT_MAX;
if (stricmp(name, "/dev/con") != 0
&& stricmp(name, "/dev/tty") != 0)
return stat(name, st);
memset(st, 0, sizeof *st);
st->st_mode = S_IFCHR|0666;
st->st_ino = (ino-- & 0x7FFF);
st->st_nlink = 1;
return 0;
}
#endif
#ifdef USE_PERL_SBRK
/* SBRK() emulation, mostly moved to malloc.c. */
void *
sys_alloc(int size) {
void *got;
APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
if (rc == ERROR_NOT_ENOUGH_MEMORY) {
return (void *) -1;
} else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
return got;
}
#endif /* USE_PERL_SBRK */
/* tmp path */
char *tmppath = TMPPATH1;
void
settmppath()
{
char *p = getenv("TMP"), *tpath;
int len;
if (!p) p = getenv("TEMP");
if (!p) return;
len = strlen(p);
tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
strcpy(tpath, p);
tpath[len] = '/';
strcpy(tpath + len + 1, TMPPATH1);
tmppath = tpath;
}
#include "XSUB.h"
XS(XS_File__Copy_syscopy)
{
dXSARGS;
if (items < 2 || items > 3)
croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
{
STRLEN n_a;
char * src = (char *)SvPV(ST(0),n_a);
char * dst = (char *)SvPV(ST(1),n_a);
U32 flag;
int RETVAL, rc;
if (items < 3)
flag = 0;
else {
flag = (unsigned long)SvIV(ST(2));
}
RETVAL = !CheckOSError(DosCopy(src, dst, flag));
ST(0) = sv_newmortal();
sv_setiv(ST(0), (IV)RETVAL);
}
XSRETURN(1);
}
#include "patchlevel.h"
char *
mod2fname(sv)
SV *sv;
{
static char fname[9];
int pos = 6, len, avlen;
unsigned int sum = 0;
AV *av;
SV *svp;
char *s;
STRLEN n_a;
if (!SvROK(sv)) croak("Not a reference given to mod2fname");
sv = SvRV(sv);
if (SvTYPE(sv) != SVt_PVAV)
croak("Not array reference given to mod2fname");
avlen = av_len((AV*)sv);
if (avlen < 0)
croak("Empty array reference given to mod2fname");
s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
strncpy(fname, s, 8);
len = strlen(s);
if (len < 6) pos = len;
while (*s) {
sum = 33 * sum + *(s++); /* Checksumming first chars to
* get the capitalization into c.s. */
}
avlen --;
while (avlen >= 0) {
s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
while (*s) {
sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
}
avlen --;
}
#ifdef USE_THREADS
sum++; /* Avoid conflict of DLLs in memory. */
#endif
sum += PATCHLEVEL * 200 + SUBVERSION * 2; /* */
fname[pos] = 'A' + (sum % 26);
fname[pos + 1] = 'A' + (sum / 26 % 26);
fname[pos + 2] = '\0';
return (char *)fname;
}
XS(XS_DynaLoader_mod2fname)
{
dXSARGS;
if (items != 1)
croak("Usage: DynaLoader::mod2fname(sv)");
{
SV * sv = ST(0);
char * RETVAL;
RETVAL = mod2fname(sv);
ST(0) = sv_newmortal();
sv_setpv((SV*)ST(0), RETVAL);
}
XSRETURN(1);
}
char *
os2error(int rc)
{
static char buf[300];
ULONG len;
if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
if (rc == 0)
return NULL;
if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
else
buf[len] = '\0';
if (len > 0 && buf[len - 1] == '\n')
buf[len - 1] = '\0';
if (len > 1 && buf[len - 2] == '\r')
buf[len - 2] = '\0';
if (len > 2 && buf[len - 3] == '.')
buf[len - 3] = '\0';
return buf;
}
char *
perllib_mangle(char *s, unsigned int l)
{
static char *newp, *oldp;
static int newl, oldl, notfound;
static char ret[STATIC_FILE_LENGTH+1];
if (!newp && !notfound) {
newp = getenv("PERLLIB_PREFIX");
if (newp) {
char *s;
oldp = newp;
while (*newp && !isSPACE(*newp) && *newp != ';') {
newp++; oldl++; /* Skip digits. */
}
while (*newp && (isSPACE(*newp) || *newp == ';')) {
newp++; /* Skip whitespace. */
}
newl = strlen(newp);
if (newl == 0 || oldl == 0) {
die("Malformed PERLLIB_PREFIX");
}
strcpy(ret, newp);
s = ret;
while (*s) {
if (*s == '\\') *s = '/';
s++;
}
} else {
notfound = 1;
}
}
if (!newp) {
return s;
}
if (l == 0) {
l = strlen(s);
}
if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
return s;
}
if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
die("Malformed PERLLIB_PREFIX");
}
strcpy(ret + newl, s + oldl);
return ret;
}
extern void dlopen();
void *fakedl = &dlopen; /* Pull in dynaloading part. */
#define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
&& ((path)[2] == '/' || (path)[2] == '\\'))
#define sys_is_rooted _fnisabs
#define sys_is_relative _fnisrel
#define current_drive _getdrive
#undef chdir /* Was _chdir2. */
#define sys_chdir(p) (chdir(p) == 0)
#define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
XS(XS_Cwd_current_drive)
{
dXSARGS;
if (items != 0)
croak("Usage: Cwd::current_drive()");
{
char RETVAL;
RETVAL = current_drive();
ST(0) = sv_newmortal();
sv_setpvn(ST(0), (char *)&RETVAL, 1);
}
XSRETURN(1);
}
XS(XS_Cwd_sys_chdir)
{
dXSARGS;
if (items != 1)
croak("Usage: Cwd::sys_chdir(path)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
bool RETVAL;
RETVAL = sys_chdir(path);
ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
}
XS(XS_Cwd_change_drive)
{
dXSARGS;
if (items != 1)
croak("Usage: Cwd::change_drive(d)");
{
STRLEN n_a;
char d = (char)*SvPV(ST(0),n_a);
bool RETVAL;
RETVAL = change_drive(d);
ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
}
XS(XS_Cwd_sys_is_absolute)
{
dXSARGS;
if (items != 1)
croak("Usage: Cwd::sys_is_absolute(path)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
bool RETVAL;
RETVAL = sys_is_absolute(path);
ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
}
XS(XS_Cwd_sys_is_rooted)
{
dXSARGS;
if (items != 1)
croak("Usage: Cwd::sys_is_rooted(path)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
bool RETVAL;
RETVAL = sys_is_rooted(path);
ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
}
XS(XS_Cwd_sys_is_relative)
{
dXSARGS;
if (items != 1)
croak("Usage: Cwd::sys_is_relative(path)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
bool RETVAL;
RETVAL = sys_is_relative(path);
ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
}
XS(XS_Cwd_sys_cwd)
{
dXSARGS;
if (items != 0)
croak("Usage: Cwd::sys_cwd()");
{
char p[MAXPATHLEN];
char * RETVAL;
RETVAL = _getcwd2(p, MAXPATHLEN);
ST(0) = sv_newmortal();
sv_setpv((SV*)ST(0), RETVAL);
}
XSRETURN(1);
}
XS(XS_Cwd_sys_abspath)
{
dXSARGS;
if (items < 1 || items > 2)
croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
char * dir;
char p[MAXPATHLEN];
char * RETVAL;
if (items < 2)
dir = NULL;
else {
dir = (char *)SvPV(ST(1),n_a);
}
if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
path += 2;
}
if (dir == NULL) {
if (_abspath(p, path, MAXPATHLEN) == 0) {
RETVAL = p;
} else {
RETVAL = NULL;
}
} else {
/* Absolute with drive: */
if ( sys_is_absolute(path) ) {
if (_abspath(p, path, MAXPATHLEN) == 0) {
RETVAL = p;
} else {
RETVAL = NULL;
}
} else if (path[0] == '/' || path[0] == '\\') {
/* Rooted, but maybe on different drive. */
if (isALPHA(dir[0]) && dir[1] == ':' ) {
char p1[MAXPATHLEN];
/* Need to prepend the drive. */
p1[0] = dir[0];
p1[1] = dir[1];
Copy(path, p1 + 2, strlen(path) + 1, char);
RETVAL = p;
if (_abspath(p, p1, MAXPATHLEN) == 0) {
RETVAL = p;
} else {
RETVAL = NULL;
}
} else if (_abspath(p, path, MAXPATHLEN) == 0) {
RETVAL = p;
} else {
RETVAL = NULL;
}
} else {
/* Either path is relative, or starts with a drive letter. */
/* If the path starts with a drive letter, then dir is
relevant only if
a/b) it is absolute/x:relative on the same drive.
c) path is on current drive, and dir is rooted
In all the cases it is safe to drop the drive part
of the path. */
if ( !sys_is_relative(path) ) {
int is_drived;
if ( ( ( sys_is_absolute(dir)
|| (isALPHA(dir[0]) && dir[1] == ':'
&& strnicmp(dir, path,1) == 0))
&& strnicmp(dir, path,1) == 0)
|| ( !(isALPHA(dir[0]) && dir[1] == ':')
&& toupper(path[0]) == current_drive())) {
path += 2;
} else if (_abspath(p, path, MAXPATHLEN) == 0) {
RETVAL = p; goto done;
} else {
RETVAL = NULL; goto done;
}
}
{
/* Need to prepend the absolute path of dir. */
char p1[MAXPATHLEN];
if (_abspath(p1, dir, MAXPATHLEN) == 0) {
int l = strlen(p1);
if (p1[ l - 1 ] != '/') {
p1[ l ] = '/';
l++;
}
Copy(path, p1 + l, strlen(path) + 1, char);
if (_abspath(p, p1, MAXPATHLEN) == 0) {
RETVAL = p;
} else {
RETVAL = NULL;
}
} else {
RETVAL = NULL;
}
}
done:
}
}
ST(0) = sv_newmortal();
sv_setpv((SV*)ST(0), RETVAL);
}
XSRETURN(1);
}
typedef APIRET (*PELP)(PSZ path, ULONG type);
APIRET
ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
{
loadByOrd(ord); /* Guarantied to load or die! */
return (*(PELP)ExtFCN[ord])(path, type);
}
#define extLibpath(type) \
(CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
: BEGIN_LIBPATH))) \
? NULL : to )
#define extLibpath_set(p,type) \
(!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
: BEGIN_LIBPATH))))
XS(XS_Cwd_extLibpath)
{
dXSARGS;
if (items < 0 || items > 1)
croak("Usage: Cwd::extLibpath(type = 0)");
{
bool type;
char to[1024];
U32 rc;
char * RETVAL;
if (items < 1)
type = 0;
else {
type = (int)SvIV(ST(0));
}
RETVAL = extLibpath(type);
ST(0) = sv_newmortal();
sv_setpv((SV*)ST(0), RETVAL);
}
XSRETURN(1);
}
XS(XS_Cwd_extLibpath_set)
{
dXSARGS;
if (items < 1 || items > 2)
croak("Usage: Cwd::extLibpath_set(s, type = 0)");
{
STRLEN n_a;
char * s = (char *)SvPV(ST(0),n_a);
bool type;
U32 rc;
bool RETVAL;
if (items < 2)
type = 0;
else {
type = (int)SvIV(ST(1));
}
RETVAL = extLibpath_set(s, type);
ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
}
int
Xs_OS2_init()
{
char *file = __FILE__;
{
GV *gv;
if (_emx_env & 0x200) { /* OS/2 */
newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
}
newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
GvMULTI_on(gv);
#ifdef PERL_IS_AOUT
sv_setiv(GvSV(gv), 1);
#endif
}
}
OS2_Perl_data_t OS2_Perl_data;
void
Perl_OS2_init(char **env)
{
char *shell;
MALLOC_INIT;
settmppath();
OS2_Perl_data.xs_init = &Xs_OS2_init;
_uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
if (environ == NULL) {
environ = env;
}
if ( (shell = getenv("PERL_SH_DRIVE")) ) {
New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
strcpy(PL_sh_path, SH_PATH);
PL_sh_path[0] = shell[0];
} else if ( (shell = getenv("PERL_SH_DIR")) ) {
int l = strlen(shell), i;
if (shell[l-1] == '/' || shell[l-1] == '\\') {
l--;
}
New(1304, PL_sh_path, l + 8, char);
strncpy(PL_sh_path, shell, l);
strcpy(PL_sh_path + l, "/sh.exe");
for (i = 0; i < l; i++) {
if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
}
}
MUTEX_INIT(&start_thread_mutex);
os2_mytype = my_type(); /* Do it before morphing. Needed? */
}
#undef tmpnam
#undef tmpfile
char *
my_tmpnam (char *str)
{
char *p = getenv("TMP"), *tpath;
int len;
if (!p) p = getenv("TEMP");
tpath = tempnam(p, "pltmp");
if (str && tpath) {
strcpy(str, tpath);
return str;
}
return tpath;
}
FILE *
my_tmpfile ()
{
struct stat s;
stat(".", &s);
if (s.st_mode & S_IWOTH) {
return tmpfile();
}
return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
grants TMP. */
}
#undef flock
/* This code was contributed by Rocco Caputo. */
int
my_flock(int handle, int o)
{
FILELOCK rNull, rFull;
ULONG timeout, handle_type, flag_word;
APIRET rc;
int blocking, shared;
static int use_my = -1;
if (use_my == -1) {
char *s = getenv("USE_PERL_FLOCK");
if (s)
use_my = atoi(s);
else
use_my = 1;
}
if (!(_emx_env & 0x200) || !use_my)
return flock(handle, o); /* Delegate to EMX. */
// is this a file?
if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
(handle_type & 0xFF))
{
errno = EBADF;
return -1;
}
// set lock/unlock ranges
rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
rFull.lRange = 0x7FFFFFFF;
// set timeout for blocking
timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
// shared or exclusive?
shared = (o & LOCK_SH) ? 1 : 0;
// do not block the unlock
if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
switch (rc) {
case 0:
errno = 0;
return 0;
case ERROR_INVALID_HANDLE:
errno = EBADF;
return -1;
case ERROR_SHARING_BUFFER_EXCEEDED:
errno = ENOLCK;
return -1;
case ERROR_LOCK_VIOLATION:
break; // not an error
case ERROR_INVALID_PARAMETER:
case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
case ERROR_READ_LOCKS_NOT_SUPPORTED:
errno = EINVAL;
return -1;
case ERROR_INTERRUPT:
errno = EINTR;
return -1;
default:
errno = EINVAL;
return -1;
}
}
// lock may block
if (o & (LOCK_SH | LOCK_EX)) {
// for blocking operations
for (;;) {
rc =
DosSetFileLocks(
handle,
&rNull,
&rFull,
timeout,
shared
);
switch (rc) {
case 0:
errno = 0;
return 0;
case ERROR_INVALID_HANDLE:
errno = EBADF;
return -1;
case ERROR_SHARING_BUFFER_EXCEEDED:
errno = ENOLCK;
return -1;
case ERROR_LOCK_VIOLATION:
if (!blocking) {
errno = EWOULDBLOCK;
return -1;
}
break;
case ERROR_INVALID_PARAMETER:
case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
case ERROR_READ_LOCKS_NOT_SUPPORTED:
errno = EINVAL;
return -1;
case ERROR_INTERRUPT:
errno = EINTR;
return -1;
default:
errno = EINVAL;
return -1;
}
// give away timeslice
DosSleep(1);
}
}
errno = 0;
return 0;
}