#define INCL_DOS
#define INCL_NOPM
+#define INCL_DOSFILEMGR
+#define INCL_DOSMEMMGR
+#define INCL_DOSERRORS
#include <os2.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;
+ if ((rc = DosResetEventSem(*c,&PL_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. */
+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;
+}
-int setpriority(int which, int pid, int val)
+#define PRIO_ERR 0x1111
+
+static ULONG
+sys_prio(pid)
{
- return DosSetPriority((pid < 0) ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
- val >> 8, val & 0xFF, abs(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 getpriority(int which /* ignored */, int pid)
+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;
- DosGetInfoBlocks(&tib, &pib);
- return tib->tib_ptib2->tib2_ulpri;
+ 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;
- ihand = signal(SIGINT, SIG_IGN);
- qhand = signal(SIGQUIT, SIG_IGN);
- r = waitpid(pid, &status, 0);
- signal(SIGINT, ihand);
- signal(SIGQUIT, qhand);
+#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);
- statusvalue = (U16)status;
+ 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;
+
+ 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, PL_na)))
+ 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);
+ int 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;
+
+ if (scr) {
+ FILE *file = fopen(scr, "r");
+ char *s = 0, *s1;
+
+ 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;
+ 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*);
- a = Argv;
+ New(1301,PL_Argv, sp - mark + 3, char*);
+ a = PL_Argv;
- if (mark < sp && SvIOKp(*(mark+1))) {
+ if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
++mark;
flag = SvIVx(*mark);
}
while (++mark <= sp) {
if (*mark)
- *a++ = SvPVx(*mark, na);
+ *a++ = SvPVx(*mark, PL_na);
else
*a++ = "";
}
*a = Nullch;
- trueflag = flag;
- if (flag == P_WAIT)
- flag = P_NOWAIT;
-
- 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));
+ 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_spawn(cmd)
+do_spawn2(cmd, execf)
char *cmd;
+int execf;
{
register char **a;
register char *s;
char flags[10];
- char *shell, *copt;
- int rc;
+ char *shell, *copt, *news = NULL;
+ int rc, err, seenspace = 0;
+ char fullcmd[MAXNAMLEN + 1];
- if ((shell = getenv("SHELL")) != NULL)
+#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 */
- /*SUPPRESS 530*/
- if (*cmd == '@') {
- ++cmd;
- goto shell_cmd;
- }
+ 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]) {
+ 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 */
}
-shell_cmd: return result(P_WAIT, spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
+ /* 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;
}
}
- New(402,Argv, (s - cmd) / 2 + 2, char*);
- Cmd = savepvn(cmd, s-cmd);
- a = Argv;
- for (s = Cmd; *s;) {
+
+ /* 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;
*s++ = '\0';
}
*a = Nullch;
- if (Argv[0]) {
- rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
- if (rc < 0 && dowarn)
- warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
- } else
+ 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
}
#endif
-/*****************************************************************************/
+/*******************************************************************/
/* not implemented in EMX 0.9a */
void * ctermid(x) { return 0; }
void * ttyname(x) { return 0; }
#endif
-void * gethostent() { return 0; }
-void * getnetent() { return 0; }
-void * getprotoent() { return 0; }
-void * getservent() { return 0; }
-void sethostent(x) {}
-void setnetent(x) {}
-void setprotoent(x) {}
-void setservent(x) {}
-void endhostent(x) {}
-void endnetent(x) {}
-void endprotoent(x) {}
-void endservent(x) {}
+/******************************************************************/
+/* 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 */
}
#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)");
+ {
+ char * src = (char *)SvPV(ST(0),PL_na);
+ char * dst = (char *)SvPV(ST(1),PL_na);
+ 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;
+
+ 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), PL_na);
+ 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), PL_na);
+ 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)");
+ {
+ char * path = (char *)SvPV(ST(0),PL_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),PL_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),PL_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),PL_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),PL_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),PL_na);
+ char * dir;
+ char p[MAXPATHLEN];
+ char * RETVAL;
+
+ if (items < 2)
+ dir = NULL;
+ else {
+ dir = (char *)SvPV(ST(1),PL_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),PL_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, 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;
+}
https://perl5.git.perl.org / perl5.git / blobdiff