#include <errno.h>
#include <limits.h>
#include <process.h>
+#include <fcntl.h>
#include "EXTERN.h"
#include "perl.h"
/*****************************************************************************/
+/* 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. */
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;
if (flag == P_WAIT)
flag = P_NOWAIT;
- if (strEQ(Argv[0],"/bin/sh")) Argv[0] = SH_PATH;
+ if (strEQ(Argv[0],"/bin/sh")) Argv[0] = sh_path;
if (Argv[0][0] != '/' && Argv[0][0] != '\\'
&& !(Argv[0][0] && Argv[0][1] == ':'
#define EXECF_SPAWN 0
#define EXECF_EXEC 1
#define EXECF_TRUEEXEC 2
+#define EXECF_SPAWN_NOWAIT 3
int
do_spawn2(cmd, execf)
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
cmd++;
if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
- STRLEN l = strlen(SH_PATH);
+ STRLEN l = strlen(sh_path);
New(4545, news, strlen(cmd) - 7 + l, char);
- strcpy(news, SH_PATH);
+ strcpy(news, sh_path);
strcpy(news + l, cmd + 7);
cmd = news;
}
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));
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)
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;
char *cmd;
char *mode;
{
+#ifndef USE_POPEN
+
+ int p[2];
+ register I32 this, that, newfd;
+ register I32 pid, rc;
+ 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;
+ if (tainting) {
+ taint_env();
+ taint_proper("Insecure %s%s", "EXEC");
+ }
+ /* 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
+# ifdef TRYSHELL
res = popen(cmd, mode);
-#else
+# else
char *shell = getenv("EMXSHELL");
- my_setenv("EMXSHELL", SH_PATH);
+ my_setenv("EMXSHELL", sh_path);
res = popen(cmd, mode);
my_setenv("EMXSHELL", shell);
-#endif
+# endif
sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE);
(void)SvUPGRADE(sv,SVt_IV);
SvIVX(sv) = -1; /* A cooky. */
return res;
+
+#endif /* USE_POPEN */
+
}
/******************************************************************/
{
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;
}
-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 + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
die("Malformed PERLLIB_PREFIX");
}
- strncpy(ret, newp, newl);
strcpy(ret + newl, s + oldl);
return ret;
}
}
XSRETURN(1);
}
+typedef APIRET (*PELP)(PSZ path, ULONG type);
-#define extLibpath(type) \
- (CheckOSError(DosQueryExtLIBPATH(to, ((type) ? END_LIBPATH \
- : BEGIN_LIBPATH))) \
+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(DosSetExtLIBPATH((p), ((type) ? END_LIBPATH \
- : BEGIN_LIBPATH))))
+ (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
+ : BEGIN_LIBPATH))))
XS(XS_Cwd_extLibpath)
{
char *file = __FILE__;
{
GV *gv;
-
- newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
+
+ 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::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);
- newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
- newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
GvMULTI_on(gv);
#ifdef PERL_IS_AOUT
settmppath();
OS2_Perl_data.xs_init = &Xs_OS2_init;
if ( (shell = getenv("PERL_SH_DRIVE")) ) {
+ New(404, 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);
+ int l = strlen(shell), i;
if (shell[l-1] == '/' || shell[l-1] == '\\') {
l--;
}
- if (l > STATIC_FILE_LENGTH - 7) {
- die("PERL_SH_DIR too long");
- }
+ New(404, 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] = '/';
+ }
}
}
+#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. */
+}
projects / p5sagit/p5-mst-13.2.git / blobdiff