#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;
+ pthread_cond_t cond;
+ enum pthreads_state state;
+} thread_join_t;
+
+thread_join_t *thread_join_data;
+int thread_join_count;
+pthread_mutex_t start_thread_mutex;
+
+int
+pthread_join(pthread_t 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(pthread_t *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(pthread_t 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(pthread_cond_t *c, pthread_mutex_t *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)))
+ croak("panic: COND_WAIT: rc=%i", rc);
+ 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. */
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) {
Renew(pbuffer, buf_len *= 2, char);
- rc = QuerySysState(QSS_PROCESS, pid, pbuffer, buf_len);
+ rc = QuerySysState(flags, pid, pbuffer, buf_len);
}
if (rc) {
FillOSError(rc);
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)
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) { */
/*****************************************************************************/
/* spawn */
+typedef void (*Sigfunc) _((int));
static int
result(int flag, int pid)
return pid;
#ifdef __EMX__
- ihand = signal(SIGINT, SIG_IGN);
- qhand = signal(SIGQUIT, SIG_IGN);
+ ihand = rsignal(SIGINT, SIG_IGN);
+ qhand = rsignal(SIGQUIT, SIG_IGN);
do {
r = wait4pid(pid, &status, 0);
} while (r == -1 && errno == EINTR);
- signal(SIGINT, ihand);
- signal(SIGQUIT, qhand);
+ rsignal(SIGINT, ihand);
+ rsignal(SIGQUIT, qhand);
statusvalue = (U16)status;
if (r < 0)
return -1;
return status & 0xFFFF;
#else
- ihand = signal(SIGINT, SIG_IGN);
+ ihand = rsignal(SIGINT, SIG_IGN);
r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
- signal(SIGINT, ihand);
+ rsignal(SIGINT, ihand);
statusvalue = res.codeResult << 8 | res.codeTerminate;
if (r)
return -1;
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))) {
if (flag == P_WAIT)
flag = P_NOWAIT;
- if (*Argv[0] != '/' && *Argv[0] != '\\'
- && !(*Argv[0] && *Argv[1] == ':'
- && (*Argv[2] == '/' || *Argv[2] != '\\'))
+ 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? */
+ retry:
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 && secondtry == 0
+ && (!tmps || !*tmps)) { /* 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. */
+ 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 if (err == ENOEXEC) { /* Need to send to shell. */
+ doshell:
+ while (a >= Argv) {
+ *(a + 2) = *a;
+ a--;
+ }
+ *Argv = sh_path;
+ *(Argv + 1) = "-c";
+ secondtry = 1;
+ goto retry;
+ }
+ }
if (rc < 0 && dowarn)
warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
#define EXECF_SPAWN 0
#define EXECF_EXEC 1
#define EXECF_TRUEEXEC 2
+#define EXECF_SPAWN_NOWAIT 3
int
do_spawn2(cmd, execf)
register char **a;
register char *s;
char flags[10];
- char *shell, *copt;
- int rc;
+ char *shell, *copt, *news = NULL;
+ int rc, added_shell = 0, err, seenspace = 0;
+ char fullcmd[MAXNAMLEN + 1];
#ifdef TRYSHELL
if ((shell = getenv("EMXSHELL")) != NULL)
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 = SH_PATH;
+ shell = sh_path;
copt = "-c";
#endif
while (*cmd && isSPACE(*cmd))
cmd++;
+ if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
+ STRLEN l = strlen(sh_path);
+
+ 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 */
/* see if there are shell metacharacters in it */
for (s = cmd; *s; s++) {
if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
- if (*s == '\n' && !s[1]) {
+ if (*s == '\n' && s[1] == '\0') {
*s = '\0';
break;
+ } else if (*s == '\\' && !seenspace) {
+ continue; /* Allow backslashes in names */
}
doshell:
if (execf == EXECF_TRUEEXEC)
return execl(shell,shell,copt,cmd,(char*)0);
else if (execf == EXECF_EXEC)
return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
+ else if (execf == EXECF_SPAWN_NOWAIT)
+ return spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
/* In the ak code internal P_NOWAIT is P_WAIT ??? */
rc = result(P_WAIT,
spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
(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;
}
}
- New(402,Argv, (s - cmd) / 2 + 2, char*);
+ New(1303,Argv, (s - cmd) / 2 + 2, char*);
Cmd = savepvn(cmd, s-cmd);
a = Argv;
for (s = Cmd; *s;) {
}
*a = Nullch;
if (Argv[0]) {
+ int err;
+
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) {
+ 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. */
+ 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 if (err == ENOEXEC) { /* Need to send to shell. */
+ goto doshell;
+ }
+ }
if (rc < 0 && dowarn)
warn("Can't %s \"%s\": %s",
- (execf == EXECF_SPAWN ? "spawn" : "exec"),
- Argv[0], Strerror(errno));
+ ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
+ ? "spawn" : "exec"),
+ Argv[0], Strerror(err));
if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
} else
rc = -1;
+ if (news) Safefree(news);
do_execfree();
return rc;
}
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;
return do_spawn2(cmd, EXECF_TRUEEXEC);
}
-#ifndef HAS_FORK
-FILE *
-my_popen(cmd,mode)
+PerlIO *
+my_syspopen(cmd,mode)
char *cmd;
char *mode;
{
-#ifdef TRYSHELL
- return popen(cmd, mode);
-#else
- char *shell = getenv("EMXSHELL");
- FILE *res;
+#ifndef USE_POPEN
+
+ int p[2];
+ register I32 this, that, newfd;
+ register I32 pid, rc;
+ PerlIO *res;
+ SV *sv;
- my_setenv("EMXSHELL", SH_PATH);
+ /* `this' is what we use in the parent, `that' in the child. */
+ this = (*mode == 'w');
+ that = !this;
+ if (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);
+ }
+ 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(fdpid,p[this],TRUE);
+ (void)SvUPGRADE(sv,SVt_IV);
+ SvIVX(sv) = pid;
+ 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", sh_path);
res = popen(cmd, mode);
my_setenv("EMXSHELL", shell);
+# endif
+ sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE);
+ (void)SvUPGRADE(sv,SVt_IV);
+ SvIVX(sv) = -1; /* A cooky. */
return res;
-#endif
+
+#endif /* USE_POPEN */
+
}
-#endif
-/*****************************************************************************/
+/******************************************************************/
#ifndef HAS_FORK
int
}
#endif
-/*****************************************************************************/
+/*******************************************************************/
/* not implemented in EMX 0.9a */
void * ctermid(x) { return 0; }
void * ttyname(x) { return 0; }
#endif
-/*****************************************************************************/
+/******************************************************************/
/* my socket forwarders - EMX lib only provides static forwarders */
static HMODULE htcp = 0;
{
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)
{
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)
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))
return buf;
}
-OS2_Perl_data_t OS2_Perl_data;
-
-int
-Xs_OS2_init()
-{
- char *file = __FILE__;
- {
- GV *gv;
-
- newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
- newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
- gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
- GvMULTI_on(gv);
-#ifdef PERL_IS_AOUT
- sv_setiv(GvSV(gv), 1);
-#endif
- }
-}
-
-void
-Perl_OS2_init()
-{
- char *shell;
-
- settmppath();
- OS2_Perl_data.xs_init = &Xs_OS2_init;
- if ( (shell = getenv("PERL_SH_DRIVE")) ) {
- sh_path[0] = shell[0];
- } else if ( (shell = getenv("PERL_SH_DIR")) ) {
- int l = strlen(shell);
- if (shell[l-1] == '/' || shell[l-1] == '\\') {
- l--;
- }
- if (l > STATIC_FILE_LENGTH - 7) {
- die("PERL_SH_DIR too long");
- }
- strncpy(sh_path, shell, l);
- strcpy(sh_path + l, "/sh.exe");
- }
-}
-
-char sh_path[STATIC_FILE_LENGTH+1] = SH_PATH_INI;
-
char *
perllib_mangle(char *s, unsigned int l)
{
if (!newp && !notfound) {
newp = getenv("PERLLIB_PREFIX");
if (newp) {
+ char *s;
+
oldp = newp;
while (*newp && !isSPACE(*newp) && *newp != ';') {
newp++; oldl++; /* Skip digits. */
if (newl == 0 || oldl == 0) {
die("Malformed PERLLIB_PREFIX");
}
+ strcpy(ret, newp);
+ s = ret;
+ while (*s) {
+ if (*s == '\\') *s = '/';
+ s++;
+ }
} else {
notfound = 1;
}
if (l == 0) {
l = strlen(s);
}
- if (l <= oldl || strnicmp(oldp, s, oldl) != 0) {
+ 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");
}
- strncpy(ret, newp, newl);
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)");
+ {
+ char * path = (char *)SvPV(ST(0),na);
+ 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)");
+ {
+ char d = (char)*SvPV(ST(0),na);
+ 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)");
+ {
+ char * path = (char *)SvPV(ST(0),na);
+ 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)");
+ {
+ char * path = (char *)SvPV(ST(0),na);
+ 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)");
+ {
+ char * path = (char *)SvPV(ST(0),na);
+ 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)");
+ {
+ char * path = (char *)SvPV(ST(0),na);
+ char * dir;
+ char p[MAXPATHLEN];
+ char * RETVAL;
+
+ if (items < 2)
+ dir = NULL;
+ else {
+ dir = (char *)SvPV(ST(1),na);
+ }
+ 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)");
+ {
+ char * s = (char *)SvPV(ST(0),na);
+ 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;
+ if (environ == NULL) {
+ environ = env;
+ }
+ if ( (shell = getenv("PERL_SH_DRIVE")) ) {
+ 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")) ) {
+ int l = strlen(shell), i;
+ if (shell[l-1] == '/' || shell[l-1] == '\\') {
+ l--;
+ }
+ 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
+#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;
+}
projects / p5sagit/p5-mst-13.2.git / blobdiff