#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;
+ if ((rc = DosResetEventSem(*c,&na)) && (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. */
char *pbuffer;
ULONG rc, buf_len = QSS_INI_BUFFER;
- New(1022, pbuffer, buf_len, char);
+ 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) {
#endif
}
+#define EXECF_SPAWN 0
+#define EXECF_EXEC 1
+#define EXECF_TRUEEXEC 2
+#define EXECF_SPAWN_NOWAIT 3
+
+/* Spawn/exec a program, revert to shell if needed. */
+/* global Argv[] contains arguments. */
+
+int
+do_spawn_ve(really, flag, execf)
+SV *really;
+U32 flag;
+U32 execf;
+{
+ dTHR;
+ int trueflag = flag;
+ int rc, secondtry = 0, err;
+ char *tmps;
+ char buf[256], *s = 0;
+ char *args[4];
+ static char * fargs[4]
+ = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
+ char **argsp = fargs;
+ char nargs = 4;
+
+ if (flag == P_WAIT)
+ flag = P_NOWAIT;
+
+ retry:
+ if (strEQ(Argv[0],"/bin/sh"))
+ Argv[0] = sh_path;
+
+ if (Argv[0][0] != '/' && Argv[0][0] != '\\'
+ && !(Argv[0][0] && Argv[0][1] == ':'
+ && (Argv[0][2] == '/' || Argv[0][2] != '\\'))
+ ) /* will swawnvp use PATH? */
+ TAINT_ENV(); /* testing IFS here is overkill, probably */
+ /* We should check PERL_SH* and PERLLIB_* as well? */
+ if (!really || !*(tmps = SvPV(really, na)))
+ tmps = Argv[0];
+#if 0
+ rc = result(trueflag, spawnvp(flag,tmps,Argv));
+#else
+ if (execf == EXECF_TRUEEXEC)
+ rc = execvp(tmps,Argv);
+ else if (execf == EXECF_EXEC)
+ rc = spawnvp(trueflag | P_OVERLAY,tmps,Argv);
+ else if (execf == EXECF_SPAWN_NOWAIT)
+ rc = spawnvp(trueflag | P_NOWAIT,tmps,Argv);
+ else /* EXECF_SPAWN */
+ rc = result(trueflag,
+ spawnvp(trueflag | P_NOWAIT,tmps,Argv));
+#endif
+ if (rc < 0 && secondtry == 0
+ && (tmps == Argv[0])) { /* Cannot transfer `really' via shell. */
+ err = errno;
+ if (err == ENOENT) { /* No such file. */
+ /* One reason may be that EMX added .exe. We suppose
+ that .exe-less files are automatically shellable.
+ It might have also been .cmd file without
+ extension. */
+ char *no_dir;
+ (no_dir = strrchr(Argv[0], '/'))
+ || (no_dir = strrchr(Argv[0], '\\'))
+ || (no_dir = Argv[0]);
+ if (!strchr(no_dir, '.')) {
+ struct stat buffer;
+ if (stat(Argv[0], &buffer) != -1) { /* File exists. */
+ /* Maybe we need to specify the full name here? */
+ goto doshell;
+ } else {
+ /* Try adding script extensions to the file name */
+ char *scr;
+ if ((scr = find_script(Argv[0], TRUE, NULL, 0))) {
+ FILE *file = fopen(scr, "r");
+ char *s = 0, *s1;
+
+ Argv[0] = scr;
+ if (!file)
+ goto panic_file;
+ if (!fgets(buf, sizeof buf, file)) {
+ fclose(file);
+ goto panic_file;
+ }
+ if (fclose(file) != 0) { /* Failure */
+ panic_file:
+ warn("Error reading \"%s\": %s",
+ scr, Strerror(errno));
+ goto doshell;
+ }
+ 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)
+ goto doshell;
+ s1 = s;
+ nargs = 0;
+ argsp = args;
+ while (1) {
+ 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;
+ }
+ goto doshell;
+ }
+ }
+ }
+ /* Restore errno */
+ errno = err;
+ } else if (err == ENOEXEC) { /* Need to send to shell. */
+ doshell:
+ {
+ char **a = Argv;
+
+ while (a[1]) /* Get to the end */
+ a++;
+ while (a >= Argv) {
+ *(a + nargs) = *a; /* Argv was preallocated to be
+ long enough. */
+ a--;
+ }
+ while (nargs-- >= 0)
+ Argv[nargs] = argsp[nargs];
+ secondtry = 1;
+ goto retry;
+ }
+ }
+ }
+ if (rc < 0 && dowarn)
+ warn("Can't %s \"%s\": %s\n",
+ ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
+ ? "spawn" : "exec"),
+ Argv[0], Strerror(err));
+ if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
+ && ((trueflag & 0xFF) == P_WAIT))
+ rc = 255 << 8; /* Emulate the fork(). */
+
+ return rc;
+}
+
int
do_aspawn(really,mark,sp)
SV *really;
register SV **mark;
register SV **sp;
{
+ dTHR;
register char **a;
- char *tmps;
+ char *tmps = NULL;
int rc;
- int flag = P_WAIT, trueflag;
+ int flag = P_WAIT, trueflag, err, secondtry = 0;
if (sp > mark) {
- New(401,Argv, sp - mark + 1, char*);
+ New(1301,Argv, sp - mark + 3, char*);
a = Argv;
if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
}
*a = Nullch;
- trueflag = flag;
- if (flag == P_WAIT)
- flag = P_NOWAIT;
-
- if (strEQ(Argv[0],"/bin/sh")) Argv[0] = sh_path;
-
- if (Argv[0][0] != '/' && Argv[0][0] != '\\'
- && !(Argv[0][0] && Argv[0][1] == ':'
- && (Argv[0][2] == '/' || Argv[0][2] != '\\'))
- ) /* will swawnvp use PATH? */
- TAINT_ENV(); /* testing IFS here is overkill, probably */
- /* We should check PERL_SH* and PERLLIB_* as well? */
- if (really && *(tmps = SvPV(really, na)))
- rc = result(trueflag, spawnvp(flag,tmps,Argv));
- else
- rc = result(trueflag, spawnvp(flag,Argv[0],Argv));
-
- if (rc < 0 && dowarn)
- warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
- if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
+ rc = do_spawn_ve(really, flag, EXECF_SPAWN);
} else
rc = -1;
do_execfree();
return rc;
}
-#define EXECF_SPAWN 0
-#define EXECF_EXEC 1
-#define EXECF_TRUEEXEC 2
-#define EXECF_SPAWN_NOWAIT 3
-
+/* Try converting 1-arg form to (usually shell-less) multi-arg form. */
int
do_spawn2(cmd, execf)
char *cmd;
register char *s;
char flags[10];
char *shell, *copt, *news = NULL;
- int rc;
+ int rc, added_shell = 0, err, seenspace = 0;
+ char fullcmd[MAXNAMLEN + 1];
#ifdef TRYSHELL
if ((shell = getenv("EMXSHELL")) != NULL)
if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
STRLEN l = strlen(sh_path);
- New(4545, news, strlen(cmd) - 7 + l, char);
+ New(1302, news, strlen(cmd) - 7 + l + 1, char);
strcpy(news, sh_path);
strcpy(news + l, cmd + 7);
cmd = news;
+ added_shell = 1;
}
/* save an extra exec if possible */
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)
return execl(shell,shell,copt,cmd,(char*)0);
if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
if (news) Safefree(news);
return rc;
+ } else if (*s == ' ' || *s == '\t') {
+ seenspace = 1;
}
}
- New(402,Argv, (s - cmd) / 2 + 2, char*);
+ /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
+ New(1303,Argv, (s - cmd + 11) / 2, char*);
Cmd = savepvn(cmd, s-cmd);
a = Argv;
for (s = Cmd; *s;) {
*s++ = '\0';
}
*a = Nullch;
- if (Argv[0]) {
- if (execf == EXECF_TRUEEXEC)
- rc = execvp(Argv[0],Argv);
- else if (execf == EXECF_EXEC)
- rc = spawnvp(P_OVERLAY,Argv[0],Argv);
- else if (execf == EXECF_SPAWN_NOWAIT)
- rc = spawnvp(P_NOWAIT,Argv[0],Argv);
- else
- rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
- if (rc < 0 && dowarn)
- warn("Can't %s \"%s\": %s",
- (execf == EXECF_SPAWN ? "spawn" : "exec"),
- Argv[0], Strerror(errno));
- if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
- } else
+ if (Argv[0])
+ rc = do_spawn_ve(NULL, 0, execf);
+ else
rc = -1;
if (news) Safefree(news);
do_execfree();
PerlIO *res;
SV *sv;
- if (pipe(p) < 0)
- return Nullfp;
/* `this' is what we use in the parent, `that' in the child. */
this = (*mode == 'w');
that = !this;
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(newfd, *mode == 'r'); /* Return std* back. */
close(newfd);
}
- close(p[that]);
+ if (p[that] == (*mode == 'r'))
+ close(p[that]);
if (pid == -1) {
close(p[this]);
return NULL;
}
avlen --;
}
+#ifdef USE_THREADS
+ sum++; /* Avoid conflict of DLLs in memory. */
+#endif
fname[pos] = 'A' + (sum % 26);
fname[pos + 1] = 'A' + (sum / 26 % 26);
fname[pos + 2] = '\0';
bool RETVAL;
RETVAL = sys_chdir(path);
- ST(0) = RETVAL ? &sv_yes : &sv_no;
+ ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
bool RETVAL;
RETVAL = change_drive(d);
- ST(0) = RETVAL ? &sv_yes : &sv_no;
+ ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
bool RETVAL;
RETVAL = sys_is_absolute(path);
- ST(0) = RETVAL ? &sv_yes : &sv_no;
+ ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
bool RETVAL;
RETVAL = sys_is_rooted(path);
- ST(0) = RETVAL ? &sv_yes : &sv_no;
+ ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
bool RETVAL;
RETVAL = sys_is_relative(path);
- ST(0) = RETVAL ? &sv_yes : &sv_no;
+ ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
}
RETVAL = extLibpath_set(s, type);
- ST(0) = RETVAL ? &sv_yes : &sv_no;
+ ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
OS2_Perl_data_t OS2_Perl_data;
void
-Perl_OS2_init()
+Perl_OS2_init(char **env)
{
char *shell;
+ MALLOC_INIT;
settmppath();
OS2_Perl_data.xs_init = &Xs_OS2_init;
+ if (environ == NULL) {
+ environ = env;
+ }
if ( (shell = getenv("PERL_SH_DRIVE")) ) {
- New(404, sh_path, strlen(SH_PATH) + 1, char);
+ New(1304, sh_path, strlen(SH_PATH) + 1, char);
strcpy(sh_path, SH_PATH);
sh_path[0] = shell[0];
} else if ( (shell = getenv("PERL_SH_DIR")) ) {
if (shell[l-1] == '/' || shell[l-1] == '\\') {
l--;
}
- New(404, sh_path, l + 8, char);
+ New(1304, sh_path, l + 8, char);
strncpy(sh_path, shell, l);
strcpy(sh_path + l, "/sh.exe");
for (i = 0; i < l; i++) {
if (sh_path[i] == '\\') sh_path[i] = '/';
}
}
+ MUTEX_INIT(&start_thread_mutex);
}
#undef tmpnam
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;
+}
projects / p5sagit/p5-mst-13.2.git / blobdiff