#define INCL_DOSFILEMGR
#define INCL_DOSMEMMGR
#define INCL_DOSERRORS
+/* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */
+#define INCL_DOSPROCESS
+#define SPU_DISABLESUPPRESSION 0
+#define SPU_ENABLESUPPRESSION 1
#include <os2.h>
+#include "dlfcn.h"
+
+#include <sys/uflags.h>
/*
* Various Unix compatibility functions for OS/2
#include <process.h>
#include <fcntl.h>
+#define PERLIO_NOT_STDIO 0
+
#include "EXTERN.h"
#include "perl.h"
break;
case pthreads_st_waited:
MUTEX_UNLOCK(&start_thread_mutex);
- croak("join with a thread with a waiter");
+ Perl_croak_nocontext("join with a thread with a waiter");
break;
case pthreads_st_run:
thread_join_data[tid].state = pthreads_st_waited;
break;
default:
MUTEX_UNLOCK(&start_thread_mutex);
- croak("join: unknown thread state: '%s'",
+ Perl_croak_nocontext("join: unknown thread state: '%s'",
pthreads_states[thread_join_data[tid].state]);
break;
}
}
}
if (thread_join_data[tid].state != pthreads_st_none)
- croak("attempt to reuse thread id %i", tid);
+ Perl_croak_nocontext("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);
switch (thread_join_data[tid].state) {
case pthreads_st_waited:
MUTEX_UNLOCK(&start_thread_mutex);
- croak("detach on a thread with a waiter");
+ Perl_croak_nocontext("detach on a thread with a waiter");
break;
case pthreads_st_run:
thread_join_data[tid].state = pthreads_st_detached;
break;
default:
MUTEX_UNLOCK(&start_thread_mutex);
- croak("detach: unknown thread state: '%s'",
+ Perl_croak_nocontext("detach: unknown thread state: '%s'",
pthreads_states[thread_join_data[tid].state]);
break;
}
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);
+ STRLEN n_a;
+ if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
+ Perl_croak_nocontext("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);
+ Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc);
if (rc == ERROR_INTERRUPT)
errno = EINTR;
if (m) MUTEX_LOCK(m);
static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
#define ORD_QUERY_ELP 0
#define ORD_SET_ELP 1
+struct PMWIN_entries_t PMWIN_entries;
+
+HMODULE
+loadModule(char *modname)
+{
+ HMODULE h = (HMODULE)dlopen(modname, 0);
+ if (!h)
+ Perl_croak_nocontext("Error loading module '%s': %s",
+ modname, dlerror());
+ return h;
+}
APIRET
-loadByOrd(ULONG ord)
+loadByOrd(char *modname, ULONG ord)
{
if (ExtFCN[ord] == NULL) {
static HMODULE hdosc = 0;
- BYTE buf[20];
- PFN fcn;
+ PFN fcn = (PFN)-1;
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]);
+ if (!hdosc)
+ hdosc = loadModule(modname);
+ if (CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
+ Perl_croak_nocontext(
+ "This version of OS/2 does not support %s.%i",
+ modname, loadOrd[ord]);
ExtFCN[ord] = fcn;
}
- if ((long)ExtFCN[ord] == -1) die("panic queryaddr");
+ if ((long)ExtFCN[ord] == -1)
+ Perl_croak_nocontext("panic queryaddr");
+}
+
+void
+init_PMWIN_entries(void)
+{
+ static HMODULE hpmwin = 0;
+ static const int ords[] = {
+ 763, /* Initialize */
+ 716, /* CreateMsgQueue */
+ 726, /* DestroyMsgQueue */
+ 918, /* PeekMsg */
+ 915, /* GetMsg */
+ 912, /* DispatchMsg */
+ 753, /* GetLastError */
+ 705, /* CancelShutdown */
+ };
+ BYTE buf[20];
+ int i = 0;
+ unsigned long rc;
+
+ if (hpmwin)
+ return;
+
+ hpmwin = loadModule("pmwin");
+ while (i < sizeof(ords)/sizeof(int)) {
+ if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
+ ((PFN*)&PMWIN_entries)+i)))
+ Perl_croak_nocontext("This version of OS/2 does not support pmwin.%d", ords[i]);
+ i++;
+ }
}
+
/* priorities */
static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
self inverse. */
}
if (pid != psi->procdata->pid) {
Safefree(psi);
- croak("panic: wrong pid in sysinfo");
+ Perl_croak_nocontext("panic: wrong pid in sysinfo");
}
prio = psi->procdata->threads->priority;
Safefree(psi);
}
static int
-result(int flag, int pid)
+result(pTHX_ int flag, int pid)
{
int r, status;
Signal_t (*ihand)(); /* place to save signal during system() */
#define EXECF_EXEC 1
#define EXECF_TRUEEXEC 2
#define EXECF_SPAWN_NOWAIT 3
+#define EXECF_SPAWN_BYFLAG 4
/* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
ULONG apptype;
if (!(_emx_env & 0x200))
- croak("file_type not implemented on DOS"); /* not OS/2. */
+ Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
if (CheckOSError(DosQueryAppType(path, &apptype))) {
switch (rc) {
case ERROR_FILE_NOT_FOUND:
/* global PL_Argv[] contains arguments. */
int
-do_spawn_ve(really, flag, execf, inicmd)
-SV *really;
-U32 flag;
-U32 execf;
-char *inicmd;
+do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
{
- dTHR;
int trueflag = flag;
int rc, pass = 1;
char *tmps;
- char buf[256], *s = 0;
+ 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;
+ int new_stderr = -1, nostderr = 0, fl_stderr;
+ STRLEN n_a;
if (flag == P_WAIT)
flag = P_NOWAIT;
) /* 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)))
+ if (!really || !*(tmps = SvPV(really, n_a)))
tmps = PL_Argv[0];
reread:
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",
+ Perl_warner(aTHX_ WARN_EXEC, "Starting PM process with flag=%d, mytype=%d",
flag, os2_mytype);
}
}
if (flag == P_NOWAIT)
flag = P_SESSION;
else if ((flag & 7) != P_SESSION)
- warn("Starting Full Screen process with flag=%d, mytype=%d",
+ Perl_warner(aTHX_ WARN_EXEC, "Starting Full Screen process with flag=%d, mytype=%d",
flag, os2_mytype);
}
}
}
}
+ if (addflag) {
+ addflag = 0;
+ new_stderr = dup(2); /* Preserve stderr */
+ if (new_stderr == -1) {
+ if (errno == EBADF)
+ nostderr = 1;
+ else {
+ rc = -1;
+ goto finish;
+ }
+ } else
+ fl_stderr = fcntl(2, F_GETFD);
+ rc = dup2(1,2);
+ if (rc == -1)
+ goto finish;
+ fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
+ }
+
#if 0
- rc = result(trueflag, spawnvp(flag,tmps,PL_Argv));
+ rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv));
#else
if (execf == EXECF_TRUEEXEC)
rc = execvp(tmps,PL_Argv);
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,
+ else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
+ rc = result(aTHX_ trueflag,
spawnvp(flag,tmps,PL_Argv));
#endif
if (rc < 0 && pass == 1
char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
if (scr) {
- FILE *file = fopen(scr, "r");
- char *s = 0, *s1;
+ PerlIO *file;
+ SSize_t rd;
+ char *s = 0, *s1, *s2;
+ int l;
+ l = strlen(scr);
+
+ if (l >= sizeof scrbuf) {
+ Safefree(scr);
+ longbuf:
+ Perl_warner(aTHX_ WARN_EXEC, "Size of scriptname too big: %d", l);
+ rc = -1;
+ goto finish;
+ }
+ strcpy(scrbuf, scr);
+ Safefree(scr);
+ scr = scrbuf;
+
+ file = PerlIO_open(scr, "r");
PL_Argv[0] = scr;
if (!file)
goto panic_file;
- if (!fgets(buf, sizeof buf, file)) { /* Empty... */
- int l = strlen(scr);
+ rd = PerlIO_read(file, buf, sizeof buf-1);
+ buf[rd]='\0';
+ if ((s2 = strchr(buf, '\n')) != NULL) *++s2 = '\0';
+
+ if (!rd) { /* Empty... */
buf[0] = 0;
- fclose(file);
+ PerlIO_close(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 < 512) { /* size of buffer in find_script */
- strcpy(scr + l, ".exe");
- if (PerlLIO_stat(scr,&PL_statbuf) >= 0
+ 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 {
- scr[l] = 0;
- }
- }
+ } else
+ scrbuf[l] = 0;
+ } else
+ goto longbuf;
}
- if (fclose(file) != 0) { /* Failure */
+ if (PerlIO_close(file) != 0) { /* Failure */
panic_file:
- warn("Error reading \"%s\": %s",
+ Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s",
scr, Strerror(errno));
buf[0] = 0; /* Not #! */
goto doshell_args;
*s++ = 0;
}
if (nargs == -1) {
- warn("Too many args on %.*s line of \"%s\"",
+ Perl_warner(aTHX_ WARN_EXEC, "Too many args on %.*s line of \"%s\"",
s1 - buf, buf, scr);
nargs = 4;
argsp = fargs;
long enough. */
a--;
}
- while (nargs-- >= 0)
+ while (--nargs >= 0)
PL_Argv[nargs] = argsp[nargs];
/* Enable pathless exec if #! (as pdksh). */
pass = (buf[0] == '#' ? 2 : 3);
goto retry;
}
}
- if (rc < 0 && PL_dowarn)
- warn("Can't %s \"%s\": %s\n",
+ if (rc < 0 && ckWARN(WARN_EXEC))
+ Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n",
((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
? "spawn" : "exec"),
PL_Argv[0], Strerror(errno));
if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
&& ((trueflag & 0xFF) == P_WAIT))
- rc = 255 << 8; /* Emulate the fork(). */
-
- return rc;
-}
-
-/* Array spawn. */
-int
-do_aspawn(really,mark,sp)
-SV *really;
-register SV **mark;
-register SV **sp;
-{
- dTHR;
- register char **a;
- char *tmps = NULL;
- int rc;
- int flag = P_WAIT, trueflag, err, secondtry = 0;
-
- if (sp > mark) {
- New(1301,PL_Argv, sp - mark + 3, char*);
- a = PL_Argv;
-
- if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
- ++mark;
- flag = SvIVx(*mark);
- }
-
- while (++mark <= sp) {
- if (*mark)
- *a++ = SvPVx(*mark, PL_na);
- else
- *a++ = "";
- }
- *a = Nullch;
-
- rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL);
- } else
- rc = -1;
- do_execfree();
+ rc = -1;
+
+ finish:
+ if (new_stderr != -1) { /* How can we use error codes? */
+ dup2(new_stderr, 2);
+ close(new_stderr);
+ fcntl(2, F_SETFD, fl_stderr);
+ } else if (nostderr)
+ close(2);
return rc;
}
/* Try converting 1-arg form to (usually shell-less) multi-arg form. */
int
-do_spawn2(cmd, execf)
-char *cmd;
-int execf;
+do_spawn3(pTHX_ char *cmd, int execf, int flag)
{
register char **a;
register char *s;
char flags[10];
char *shell, *copt, *news = NULL;
- int rc, err, seenspace = 0;
+ int rc, err, seenspace = 0, mergestderr = 0;
char fullcmd[MAXNAMLEN + 1];
#ifdef TRYSHELL
break;
} else if (*s == '\\' && !seenspace) {
continue; /* Allow backslashes in names */
+ } else if (*s == '>' && s >= cmd + 3
+ && s[-1] == '2' && s[1] == '&' && s[2] == '1'
+ && isSPACE(s[-2]) ) {
+ char *t = s + 3;
+
+ while (*t && isSPACE(*t))
+ t++;
+ if (!*t) {
+ s[-2] = '\0';
+ mergestderr = 1;
+ break; /* Allow 2>&1 as the last thing */
+ }
}
/* We do not convert this to do_spawn_ve since shell
should be smart enough to start itself gloriously. */
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 if (execf == EXECF_SPAWN_BYFLAG)
+ rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
else {
/* In the ak code internal P_NOWAIT is P_WAIT ??? */
- rc = result(P_WAIT,
+ rc = result(aTHX_ P_WAIT,
spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
- if (rc < 0 && PL_dowarn)
- warn("Can't %s \"%s\": %s",
+ if (rc < 0 && ckWARN(WARN_EXEC))
+ Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
(execf == EXECF_SPAWN ? "spawn" : "exec"),
shell, Strerror(errno));
- if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
+ if (rc < 0)
+ rc = -1;
}
if (news)
Safefree(news);
}
*a = Nullch;
if (PL_Argv[0])
- rc = do_spawn_ve(NULL, 0, execf, cmd);
+ rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
else
rc = -1;
if (news)
return rc;
}
+/* Array spawn. */
+int
+os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp)
+{
+ register char **a;
+ int rc;
+ int flag = P_WAIT, flag_set = 0;
+ STRLEN n_a;
+
+ if (sp > mark) {
+ New(1301,PL_Argv, sp - mark + 3, char*);
+ a = PL_Argv;
+
+ if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
+ ++mark;
+ flag = SvIVx(*mark);
+ flag_set = 1;
+
+ }
+
+ while (++mark <= sp) {
+ if (*mark)
+ *a++ = SvPVx(*mark, n_a);
+ else
+ *a++ = "";
+ }
+ *a = Nullch;
+
+ if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
+ rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
+ } else
+ rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0);
+ } else
+ rc = -1;
+ do_execfree();
+ return rc;
+}
+
int
-do_spawn(cmd)
-char *cmd;
+os2_do_spawn(pTHX_ char *cmd)
{
- return do_spawn2(cmd, EXECF_SPAWN);
+ return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
}
int
-do_spawn_nowait(cmd)
-char *cmd;
+do_spawn_nowait(pTHX_ char *cmd)
{
- return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
+ return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
}
bool
-do_exec(cmd)
-char *cmd;
+Perl_do_exec(pTHX_ char *cmd)
{
- do_spawn2(cmd, EXECF_EXEC);
+ do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
return FALSE;
}
bool
-os2exec(cmd)
-char *cmd;
+os2exec(pTHX_ char *cmd)
{
- return do_spawn2(cmd, EXECF_TRUEEXEC);
+ return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
}
PerlIO *
-my_syspopen(cmd,mode)
-char *cmd;
-char *mode;
+my_syspopen(pTHX_ char *cmd, char *mode)
{
#ifndef USE_POPEN
register I32 pid, rc;
PerlIO *res;
SV *sv;
+ int fh_fl;
/* `this' is what we use in the parent, `that' in the child. */
this = (*mode == 'w');
if (pipe(p) < 0)
return Nullfp;
/* Now we need to spawn the child. */
+ if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
+ int new = dup(p[this]);
+
+ if (new == -1)
+ goto closepipes;
+ close(p[this]);
+ p[this] = new;
+ }
newfd = dup(*mode == 'r'); /* Preserve std* */
- if (p[that] != (*mode == 'r')) {
+ if (newfd == -1) {
+ /* This cannot happen due to fh being bad after pipe(), since
+ pipe() should have created fh 0 and 1 even if they were
+ initially closed. But we closed p[this] before. */
+ if (errno != EBADF) {
+ closepipes:
+ close(p[0]);
+ close(p[1]);
+ return Nullfp;
+ }
+ } else
+ fh_fl = fcntl(*mode == 'r', F_GETFD);
+ if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
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')) {
+ if (newfd != -1)
+ fcntl(newfd, F_SETFD, FD_CLOEXEC);
+ pid = do_spawn_nowait(aTHX_ cmd);
+ if (newfd == -1)
+ close(*mode == 'r'); /* It was closed initially */
+ else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
dup2(newfd, *mode == 'r'); /* Return std* back. */
close(newfd);
- }
+ fcntl(*mode == 'r', F_SETFD, fh_fl);
+ } else
+ fcntl(*mode == 'r', F_SETFD, fh_fl);
if (p[that] == (*mode == 'r'))
close(p[that]);
if (pid == -1) {
close(p[this]);
- return NULL;
+ return Nullfp;
}
- if (p[that] < p[this]) {
+ if (p[that] < p[this]) { /* Make fh as small as possible */
dup2(p[this], p[that]);
close(p[this]);
p[this] = p[that];
int
fork(void)
{
- die(no_func, "Unsupported function fork");
+ Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
errno = EINVAL;
return -1;
}
#endif
/*******************************************************************/
-/* not implemented in EMX 0.9a */
+/* not implemented in EMX 0.9d */
-void * ctermid(x) { return 0; }
+char * ctermid(char *s) { return 0; }
#ifdef MYTTYNAME /* was not in emx0.9a */
void * ttyname(x) { return 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 (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
if (!htcp)
- DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
+ htcp = loadModule("tcp32dll");
if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
return (void *) ((void * (*)(void)) fcn) ();
return 0;
static BYTE buf[20];
PFN fcn;
- if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
+ if (!(_emx_env & 0x200)) Perl_croak_nocontext("%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"); }
+struct hostent * gethostent() { return tcp0("GETHOSTENT"); }
+struct netent * getnetent() { return tcp0("GETNETENT"); }
+struct protoent * getprotoent() { return tcp0("GETPROTOENT"); }
+struct servent * getservent() { return tcp0("GETSERVENT"); }
+
void sethostent(x) { tcp1("SETHOSTENT", x); }
void setnetent(x) { tcp1("SETNETENT", x); }
void setprotoent(x) { tcp1("SETPROTOENT", x); }
if (rc == ERROR_NOT_ENOUGH_MEMORY) {
return (void *) -1;
- } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
+ } else if ( rc )
+ Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
return got;
}
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;
+ if (tpath) {
+ strcpy(tpath, p);
+ tpath[len] = '/';
+ strcpy(tpath + len + 1, TMPPATH1);
+ tmppath = tpath;
+ }
}
#include "XSUB.h"
{
dXSARGS;
if (items < 2 || items > 3)
- croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
+ Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
{
- char * src = (char *)SvPV(ST(0),PL_na);
- char * dst = (char *)SvPV(ST(1),PL_na);
+ STRLEN n_a;
+ char * src = (char *)SvPV(ST(0),n_a);
+ char * dst = (char *)SvPV(ST(1),n_a);
U32 flag;
int RETVAL, rc;
#include "patchlevel.h"
char *
-mod2fname(sv)
- SV *sv;
+mod2fname(pTHX_ SV *sv)
{
static char fname[9];
int pos = 6, len, avlen;
AV *av;
SV *svp;
char *s;
+ STRLEN n_a;
- if (!SvROK(sv)) croak("Not a reference given to mod2fname");
+ if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
sv = SvRV(sv);
if (SvTYPE(sv) != SVt_PVAV)
- croak("Not array reference given to mod2fname");
+ Perl_croak_nocontext("Not array reference given to mod2fname");
avlen = av_len((AV*)sv);
if (avlen < 0)
- croak("Empty array reference given to mod2fname");
+ Perl_croak_nocontext("Empty array reference given to mod2fname");
- s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
+ s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
strncpy(fname, s, 8);
len = strlen(s);
if (len < 6) pos = len;
}
avlen --;
while (avlen >= 0) {
- s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
+ s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
while (*s) {
sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
}
#ifdef USE_THREADS
sum++; /* Avoid conflict of DLLs in memory. */
#endif
- sum += PATCHLEVEL * 200 + SUBVERSION * 2; /* */
+ /* We always load modules as *specific* DLLs, and with the full name.
+ When loading a specific DLL by its full name, one cannot get a
+ different DLL, even if a DLL with the same basename is loaded already.
+ Thus there is no need to include the version into the mangling scheme. */
+#if 0
+ sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
+#else
+# ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
+# define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
+# endif
+ sum += COMPATIBLE_VERSION_SUM;
+#endif
fname[pos] = 'A' + (sum % 26);
fname[pos + 1] = 'A' + (sum / 26 % 26);
fname[pos + 2] = '\0';
{
dXSARGS;
if (items != 1)
- croak("Usage: DynaLoader::mod2fname(sv)");
+ Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
{
SV * sv = ST(0);
char * RETVAL;
- RETVAL = mod2fname(sv);
+ RETVAL = mod2fname(aTHX_ sv);
ST(0) = sv_newmortal();
sv_setpv((SV*)ST(0), RETVAL);
}
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
+ 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';
+ if (len && buf[len - 1] == '\n')
+ buf[--len] = 0;
+ if (len && buf[len - 1] == '\r')
+ buf[--len] = 0;
+ if (len && buf[len - 1] == '.')
+ buf[--len] = 0;
+ }
return buf;
}
char *
+os2_execname(pTHX)
+{
+ char buf[300], *p, *o = PL_origargv[0], ok = 1;
+
+ if (_execname(buf, sizeof buf) != 0)
+ return o;
+ p = buf;
+ while (*p) {
+ if (*p == '\\')
+ *p = '/';
+ if (*p == '/') {
+ if (ok && *o != '/' && *o != '\\')
+ ok = 0;
+ } else if (ok && tolower(*o) != tolower(*p))
+ ok = 0;
+ p++;
+ o++;
+ }
+ if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */
+ strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */
+ p = buf;
+ while (*p) {
+ if (*p == '\\')
+ *p = '/';
+ p++;
+ }
+ }
+ p = savepv(buf);
+ SAVEFREEPV(p);
+ return p;
+}
+
+char *
perllib_mangle(char *s, unsigned int l)
{
static char *newp, *oldp;
}
newl = strlen(newp);
if (newl == 0 || oldl == 0) {
- die("Malformed PERLLIB_PREFIX");
+ Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
}
strcpy(ret, newp);
s = ret;
return s;
}
if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
- die("Malformed PERLLIB_PREFIX");
+ Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
}
strcpy(ret + newl, s + oldl);
return ret;
}
-extern void dlopen();
-void *fakedl = &dlopen; /* Pull in dynaloading part. */
+unsigned long
+Perl_hab_GET() /* Needed if perl.h cannot be included */
+{
+ return perl_hab_GET();
+}
+
+HMQ
+Perl_Register_MQ(int serve)
+{
+ PPIB pib;
+ PTIB tib;
+
+ if (Perl_os2_initial_mode++)
+ return Perl_hmq;
+ DosGetInfoBlocks(&tib, &pib);
+ Perl_os2_initial_mode = pib->pib_ultype;
+ /* Try morphing into a PM application. */
+ if (pib->pib_ultype != 3) /* 2 is VIO */
+ pib->pib_ultype = 3; /* 3 is PM */
+ init_PMWIN_entries();
+ /* 64 messages if before OS/2 3.0, ignored otherwise */
+ Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
+ if (!Perl_hmq) {
+ static int cnt;
+
+ SAVEINT(cnt); /* Allow catch()ing. */
+ if (cnt++)
+ _exit(188); /* Panic can try to create a window. */
+ Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
+ }
+ if (serve) {
+ if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
+ && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
+ (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
+ Perl_hmq_servers++;
+ } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
+ (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
+ Perl_hmq_refcnt++;
+ return Perl_hmq;
+}
+
+int
+Perl_Serve_Messages(int force)
+{
+ int cnt = 0;
+ QMSG msg;
+
+ if (Perl_hmq_servers > 0 && !force)
+ return 0;
+ if (Perl_hmq_refcnt <= 0)
+ Perl_croak_nocontext("No message queue");
+ while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
+ cnt++;
+ if (msg.msg == WM_QUIT)
+ Perl_croak_nocontext("QUITing...");
+ (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
+ }
+ return cnt;
+}
+
+int
+Perl_Process_Messages(int force, I32 *cntp)
+{
+ QMSG msg;
+
+ if (Perl_hmq_servers > 0 && !force)
+ return 0;
+ if (Perl_hmq_refcnt <= 0)
+ Perl_croak_nocontext("No message queue");
+ while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
+ if (cntp)
+ (*cntp)++;
+ (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
+ if (msg.msg == WM_DESTROY)
+ return -1;
+ if (msg.msg == WM_CREATE)
+ return +1;
+ }
+ Perl_croak_nocontext("QUITing...");
+}
+
+void
+Perl_Deregister_MQ(int serve)
+{
+ PPIB pib;
+ PTIB tib;
+
+ if (serve)
+ Perl_hmq_servers--;
+ if (--Perl_hmq_refcnt <= 0) {
+ init_PMWIN_entries(); /* To be extra safe */
+ (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
+ Perl_hmq = 0;
+ /* Try morphing back from a PM application. */
+ DosGetInfoBlocks(&tib, &pib);
+ if (pib->pib_ultype == 3) /* 3 is PM */
+ pib->pib_ultype = Perl_os2_initial_mode;
+ else
+ Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
+ pib->pib_ultype);
+ } else if (serve && Perl_hmq_servers <= 0) /* Last server exited */
+ (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
+}
#define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
&& ((path)[2] == '/' || (path)[2] == '\\'))
#define sys_chdir(p) (chdir(p) == 0)
#define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
+static int DOS_harderr_state = -1;
+
+XS(XS_OS2_Error)
+{
+ dXSARGS;
+ if (items != 2)
+ Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
+ {
+ int arg1 = SvIV(ST(0));
+ int arg2 = SvIV(ST(1));
+ int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
+ | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
+ int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
+ unsigned long rc;
+
+ if (CheckOSError(DosError(a)))
+ Perl_croak_nocontext("DosError(%d) failed", a);
+ ST(0) = sv_newmortal();
+ if (DOS_harderr_state >= 0)
+ sv_setiv(ST(0), DOS_harderr_state);
+ DOS_harderr_state = RETVAL;
+ }
+ XSRETURN(1);
+}
+
+static signed char DOS_suppression_state = -1;
+
+XS(XS_OS2_Errors2Drive)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
+ {
+ STRLEN n_a;
+ SV *sv = ST(0);
+ int suppress = SvOK(sv);
+ char *s = suppress ? SvPV(sv, n_a) : NULL;
+ char drive = (s ? *s : 0);
+ unsigned long rc;
+
+ if (suppress && !isALPHA(drive))
+ Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
+ if (CheckOSError(DosSuppressPopUps((suppress
+ ? SPU_ENABLESUPPRESSION
+ : SPU_DISABLESUPPRESSION),
+ drive)))
+ Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
+ ST(0) = sv_newmortal();
+ if (DOS_suppression_state > 0)
+ sv_setpvn(ST(0), &DOS_suppression_state, 1);
+ else if (DOS_suppression_state == 0)
+ sv_setpvn(ST(0), "", 0);
+ DOS_suppression_state = drive;
+ }
+ XSRETURN(1);
+}
+
+static const char * const si_fields[QSV_MAX] = {
+ "MAX_PATH_LENGTH",
+ "MAX_TEXT_SESSIONS",
+ "MAX_PM_SESSIONS",
+ "MAX_VDM_SESSIONS",
+ "BOOT_DRIVE",
+ "DYN_PRI_VARIATION",
+ "MAX_WAIT",
+ "MIN_SLICE",
+ "MAX_SLICE",
+ "PAGE_SIZE",
+ "VERSION_MAJOR",
+ "VERSION_MINOR",
+ "VERSION_REVISION",
+ "MS_COUNT",
+ "TIME_LOW",
+ "TIME_HIGH",
+ "TOTPHYSMEM",
+ "TOTRESMEM",
+ "TOTAVAILMEM",
+ "MAXPRMEM",
+ "MAXSHMEM",
+ "TIMER_INTERVAL",
+ "MAX_COMP_LENGTH",
+ "FOREGROUND_FS_SESSION",
+ "FOREGROUND_PROCESS"
+};
+
+XS(XS_OS2_SysInfo)
+{
+ dXSARGS;
+ if (items != 0)
+ Perl_croak_nocontext("Usage: OS2::SysInfo()");
+ {
+ ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
+ APIRET rc = NO_ERROR; /* Return code */
+ int i = 0, j = 0;
+
+ if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
+ QSV_MAX, /* information */
+ (PVOID)si,
+ sizeof(si))))
+ Perl_croak_nocontext("DosQuerySysInfo() failed");
+ EXTEND(SP,2*QSV_MAX);
+ while (i < QSV_MAX) {
+ ST(j) = sv_newmortal();
+ sv_setpv(ST(j++), si_fields[i]);
+ ST(j) = sv_newmortal();
+ sv_setiv(ST(j++), si[i]);
+ i++;
+ }
+ }
+ XSRETURN(2 * QSV_MAX);
+}
+
+XS(XS_OS2_BootDrive)
+{
+ dXSARGS;
+ if (items != 0)
+ Perl_croak_nocontext("Usage: OS2::BootDrive()");
+ {
+ ULONG si[1] = {0}; /* System Information Data Buffer */
+ APIRET rc = NO_ERROR; /* Return code */
+ char c;
+
+ if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
+ (PVOID)si, sizeof(si))))
+ Perl_croak_nocontext("DosQuerySysInfo() failed");
+ ST(0) = sv_newmortal();
+ c = 'a' - 1 + si[0];
+ sv_setpvn(ST(0), &c, 1);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_MorphPM)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
+ {
+ bool serve = SvOK(ST(0));
+ unsigned long pmq = perl_hmq_GET(serve);
+
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), pmq);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_UnMorphPM)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
+ {
+ bool serve = SvOK(ST(0));
+
+ perl_hmq_UNSET(serve);
+ }
+ XSRETURN(0);
+}
+
+XS(XS_OS2_Serve_Messages)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
+ {
+ bool force = SvOK(ST(0));
+ unsigned long cnt = Perl_Serve_Messages(force);
+
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), cnt);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_Process_Messages)
+{
+ dXSARGS;
+ if (items < 1 || items > 2)
+ Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
+ {
+ bool force = SvOK(ST(0));
+ unsigned long cnt;
+
+ if (items == 2) {
+ I32 cntr;
+ SV *sv = ST(1);
+ int fake = SvIV(sv); /* Force SvIVX */
+
+ if (!SvIOK(sv))
+ Perl_croak_nocontext("Can't upgrade count to IV");
+ cntr = SvIVX(sv);
+ cnt = Perl_Process_Messages(force, &cntr);
+ SvIVX(sv) = cntr;
+ } else {
+ cnt = Perl_Process_Messages(force, NULL);
+ }
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), cnt);
+ }
+ XSRETURN(1);
+}
+
XS(XS_Cwd_current_drive)
{
dXSARGS;
if (items != 0)
- croak("Usage: Cwd::current_drive()");
+ Perl_croak_nocontext("Usage: Cwd::current_drive()");
{
char RETVAL;
{
dXSARGS;
if (items != 1)
- croak("Usage: Cwd::sys_chdir(path)");
+ Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
{
- char * path = (char *)SvPV(ST(0),PL_na);
+ STRLEN n_a;
+ char * path = (char *)SvPV(ST(0),n_a);
bool RETVAL;
RETVAL = sys_chdir(path);
{
dXSARGS;
if (items != 1)
- croak("Usage: Cwd::change_drive(d)");
+ Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
{
- char d = (char)*SvPV(ST(0),PL_na);
+ STRLEN n_a;
+ char d = (char)*SvPV(ST(0),n_a);
bool RETVAL;
RETVAL = change_drive(d);
{
dXSARGS;
if (items != 1)
- croak("Usage: Cwd::sys_is_absolute(path)");
+ Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
{
- char * path = (char *)SvPV(ST(0),PL_na);
+ STRLEN n_a;
+ char * path = (char *)SvPV(ST(0),n_a);
bool RETVAL;
RETVAL = sys_is_absolute(path);
{
dXSARGS;
if (items != 1)
- croak("Usage: Cwd::sys_is_rooted(path)");
+ Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
{
- char * path = (char *)SvPV(ST(0),PL_na);
+ STRLEN n_a;
+ char * path = (char *)SvPV(ST(0),n_a);
bool RETVAL;
RETVAL = sys_is_rooted(path);
{
dXSARGS;
if (items != 1)
- croak("Usage: Cwd::sys_is_relative(path)");
+ Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
{
- char * path = (char *)SvPV(ST(0),PL_na);
+ STRLEN n_a;
+ char * path = (char *)SvPV(ST(0),n_a);
bool RETVAL;
RETVAL = sys_is_relative(path);
{
dXSARGS;
if (items != 0)
- croak("Usage: Cwd::sys_cwd()");
+ Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
{
char p[MAXPATHLEN];
char * RETVAL;
{
dXSARGS;
if (items < 1 || items > 2)
- croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
+ Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
{
- char * path = (char *)SvPV(ST(0),PL_na);
+ STRLEN n_a;
+ char * path = (char *)SvPV(ST(0),n_a);
char * dir;
char p[MAXPATHLEN];
char * RETVAL;
if (items < 2)
dir = NULL;
else {
- dir = (char *)SvPV(ST(1),PL_na);
+ dir = (char *)SvPV(ST(1),n_a);
}
if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
path += 2;
}
typedef APIRET (*PELP)(PSZ path, ULONG type);
+/* Kernels after 2000/09/15 understand this too: */
+#ifndef LIBPATHSTRICT
+# define LIBPATHSTRICT 3
+#endif
+
APIRET
-ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
+ExtLIBPATH(ULONG ord, PSZ path, IV type)
{
- loadByOrd(ord); /* Guarantied to load or die! */
- return (*(PELP)ExtFCN[ord])(path, type);
+ ULONG what;
+
+ loadByOrd("doscalls",ord); /* Guarantied to load or die! */
+ if (type > 0)
+ what = END_LIBPATH;
+ else if (type == 0)
+ what = BEGIN_LIBPATH;
+ else
+ what = LIBPATHSTRICT;
+ return (*(PELP)ExtFCN[ord])(path, what);
}
-#define extLibpath(type) \
- (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
- : BEGIN_LIBPATH))) \
- ? NULL : to )
+#define extLibpath(to,type) \
+ (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, (to), (type))) ? NULL : (to) )
#define extLibpath_set(p,type) \
- (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
- : BEGIN_LIBPATH))))
+ (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), (type))))
XS(XS_Cwd_extLibpath)
{
dXSARGS;
if (items < 0 || items > 1)
- croak("Usage: Cwd::extLibpath(type = 0)");
+ Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
{
- bool type;
+ IV type;
char to[1024];
U32 rc;
char * RETVAL;
if (items < 1)
type = 0;
else {
- type = (int)SvIV(ST(0));
+ type = SvIV(ST(0));
}
- RETVAL = extLibpath(type);
+ to[0] = 1; to[1] = 0; /* Sometimes no error reported */
+ RETVAL = extLibpath(to, type);
+ if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
+ Perl_croak_nocontext("panic Cwd::extLibpath parameter");
ST(0) = sv_newmortal();
sv_setpv((SV*)ST(0), RETVAL);
}
{
dXSARGS;
if (items < 1 || items > 2)
- croak("Usage: Cwd::extLibpath_set(s, type = 0)");
+ Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
{
- char * s = (char *)SvPV(ST(0),PL_na);
- bool type;
+ STRLEN n_a;
+ char * s = (char *)SvPV(ST(0),n_a);
+ IV type;
U32 rc;
bool RETVAL;
if (items < 2)
type = 0;
else {
- type = (int)SvIV(ST(1));
+ type = SvIV(ST(1));
}
RETVAL = extLibpath_set(s, type);
XSRETURN(1);
}
+#define get_control87() _control87(0,0)
+#define set_control87 _control87
+
+XS(XS_OS2__control87)
+{
+ dXSARGS;
+ if (items != 2)
+ croak("Usage: OS2::_control87(new,mask)");
+ {
+ unsigned new = (unsigned)SvIV(ST(0));
+ unsigned mask = (unsigned)SvIV(ST(1));
+ unsigned RETVAL;
+
+ RETVAL = _control87(new, mask);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (IV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_get_control87)
+{
+ dXSARGS;
+ if (items != 0)
+ croak("Usage: OS2::get_control87()");
+ {
+ unsigned RETVAL;
+
+ RETVAL = get_control87();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (IV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
+
+XS(XS_OS2_set_control87)
+{
+ dXSARGS;
+ if (items < 0 || items > 2)
+ croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
+ {
+ unsigned new;
+ unsigned mask;
+ unsigned RETVAL;
+
+ if (items < 1)
+ new = MCW_EM;
+ else {
+ new = (unsigned)SvIV(ST(0));
+ }
+
+ if (items < 2)
+ mask = MCW_EM;
+ else {
+ mask = (unsigned)SvIV(ST(1));
+ }
+
+ RETVAL = set_control87(new, mask);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (IV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
int
-Xs_OS2_init()
+Xs_OS2_init(pTHX)
{
char *file = __FILE__;
{
newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
}
+ newXS("OS2::Error", XS_OS2_Error, file);
+ newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
+ newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
+ newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
+ newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
+ newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
+ newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
+ newXS("OS2::Process_Messages", XS_OS2_Process_Messages, 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);
+ newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
+ newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
+ newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
GvMULTI_on(gv);
#ifdef PERL_IS_AOUT
sv_setiv(GvSV(gv), 1);
#endif
+ gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setiv(GvSV(gv), _emx_rev);
+ sv_setpv(GvSV(gv), _emx_vprt);
+ SvIOK_on(GvSV(gv));
+ gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setiv(GvSV(gv), _emx_env);
+ gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
}
}
MALLOC_INIT;
settmppath();
OS2_Perl_data.xs_init = &Xs_OS2_init;
- if (environ == NULL) {
+ _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
+ if (environ == NULL && env) {
environ = env;
}
if ( (shell = getenv("PERL_SH_DRIVE")) ) {
}
MUTEX_INIT(&start_thread_mutex);
os2_mytype = my_type(); /* Do it before morphing. Needed? */
+ /* Some DLLs reset FP flags on load. We may have been linked with them */
+ _control87(MCW_EM, MCW_EM);
}
#undef tmpnam
grants TMP. */
}
+#undef rmdir
+
+int
+my_rmdir (__const__ char *s)
+{
+ char buf[MAXPATHLEN];
+ STRLEN l = strlen(s);
+
+ if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX rmdir fails... */
+ strcpy(buf,s);
+ buf[l - 1] = 0;
+ s = buf;
+ }
+ return rmdir(s);
+}
+
+#undef mkdir
+
+int
+my_mkdir (__const__ char *s, long perm)
+{
+ char buf[MAXPATHLEN];
+ STRLEN l = strlen(s);
+
+ if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
+ strcpy(buf,s);
+ buf[l - 1] = 0;
+ s = buf;
+ }
+ return mkdir(s, perm);
+}
+
#undef flock
/* This code was contributed by Rocco Caputo. */
projects / p5sagit/p5-mst-13.2.git / blobdiff