#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 <sys/uflags.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);
if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
modname, &hdosc)))
|| CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
- croak("This version of OS/2 does not support %s.%i",
+ Perl_croak_nocontext("This version of OS/2 does not support %s.%i",
modname, loadOrd[ord]);
ExtFCN[ord] = fcn;
}
if ((long)ExtFCN[ord] == -1)
- croak("panic queryaddr");
+ Perl_croak_nocontext("panic queryaddr");
}
void
return;
if (CheckOSError(DosLoadModule(buf, sizeof buf, "pmwin", &hpmwin)))
- croak("This version of OS/2 does not support pmwin: error in %s", buf);
+ Perl_croak_nocontext("This version of OS/2 does not support pmwin: error in %s", buf);
while (i <= 5) {
if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
((PFN*)&PMWIN_entries)+i)))
- croak("This version of OS/2 does not support pmwin.%d", ords[i]);
+ Perl_croak_nocontext("This version of OS/2 does not support pmwin.%d", ords[i]);
i++;
}
}
}
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)
{
+ dTHR;
int r, status;
Signal_t (*ihand)(); /* place to save signal during system() */
Signal_t (*qhand)(); /* 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;
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
/* 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");
+ FILE *file;
char *s = 0, *s1;
+ 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 = fopen(scr, "r");
PL_Argv[0] = scr;
if (!file)
goto panic_file;
}
if (fclose(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)
{
+ dTHR;
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
-do_spawn(cmd)
-char *cmd;
+os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp)
{
- return do_spawn2(cmd, EXECF_SPAWN);
+ dTHR;
+ 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_nowait(cmd)
-char *cmd;
+os2_do_spawn(pTHX_ char *cmd)
{
- return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
+ dTHR;
+ return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
+}
+
+int
+do_spawn_nowait(pTHX_ char *cmd)
+{
+ dTHR;
+ 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);
+ dTHR;
+ do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
return FALSE;
}
bool
-os2exec(cmd)
-char *cmd;
+os2exec(pTHX_ char *cmd)
{
- return do_spawn2(cmd, EXECF_TRUEEXEC);
+ dTHR;
+ 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)
{
- croak(PL_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 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)
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)
if (rc == ERROR_NOT_ENOUGH_MEMORY) {
return (void *) -1;
} else if ( rc )
- croak("Got an error from DosAllocMem: %li", (long)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; /* */
+ sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* */
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)
+{
+ dTHR;
+ char buf[300], *p;
+
+ if (_execname(buf, sizeof buf) != 0)
+ return PL_origargv[0];
+ 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) {
- croak("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) {
- croak("Malformed PERLLIB_PREFIX");
+ Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
}
strcpy(ret + newl, s + oldl);
return ret;
static int cnt;
if (cnt++)
_exit(188); /* Panic can try to create a window. */
- croak("Cannot create a message queue, or morph to a PM application");
+ Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
}
return Perl_hmq;
}
if (Perl_hmq_servers && !force)
return 0;
if (!Perl_hmq_refcnt)
- croak("No message queue");
+ Perl_croak_nocontext("No message queue");
while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
cnt++;
if (msg.msg == WM_QUIT)
- croak("QUITing...");
+ Perl_croak_nocontext("QUITing...");
(*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
}
return cnt;
if (Perl_hmq_servers && !force)
return 0;
if (!Perl_hmq_refcnt)
- croak("No message queue");
+ Perl_croak_nocontext("No message queue");
while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
if (cntp)
(*cntp)++;
if (msg.msg == WM_CREATE)
return +1;
}
- croak("QUITing...");
+ Perl_croak_nocontext("QUITing...");
}
void
if (pib->pib_ultype == 3) /* 3 is PM */
pib->pib_ultype = Perl_os2_initial_mode;
else
- warn("Unexpected program mode %d when morphing back from PM",
+ Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
pib->pib_ultype);
}
}
{
dXSARGS;
if (items != 2)
- croak("Usage: OS2::Error(harderr, exception)");
+ Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
{
int arg1 = SvIV(ST(0));
int arg2 = SvIV(ST(1));
unsigned long rc;
if (CheckOSError(DosError(a)))
- croak("DosError(%d) failed", a);
+ Perl_croak_nocontext("DosError(%d) failed", a);
ST(0) = sv_newmortal();
if (DOS_harderr_state >= 0)
sv_setiv(ST(0), DOS_harderr_state);
{
dXSARGS;
if (items != 1)
- croak("Usage: OS2::Errors2Drive(drive)");
+ Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
{
+ STRLEN n_a;
SV *sv = ST(0);
int suppress = SvOK(sv);
- char *s = suppress ? SvPV(sv, PL_na) : NULL;
+ char *s = suppress ? SvPV(sv, n_a) : NULL;
char drive = (s ? *s : 0);
unsigned long rc;
if (suppress && !isALPHA(drive))
- croak("Non-char argument '%c' to OS2::Errors2Drive()", drive);
+ Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
if (CheckOSError(DosSuppressPopUps((suppress
? SPU_ENABLESUPPRESSION
: SPU_DISABLESUPPRESSION),
drive)))
- croak("DosSuppressPopUps(%c) failed", 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);
{
dXSARGS;
if (items != 0)
- croak("Usage: OS2::SysInfo()");
+ Perl_croak_nocontext("Usage: OS2::SysInfo()");
{
ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
APIRET rc = NO_ERROR; /* Return code */
QSV_MAX, /* information */
(PVOID)si,
sizeof(si))))
- croak("DosQuerySysInfo() failed");
+ Perl_croak_nocontext("DosQuerySysInfo() failed");
EXTEND(SP,2*QSV_MAX);
while (i < QSV_MAX) {
ST(j) = sv_newmortal();
{
dXSARGS;
if (items != 0)
- croak("Usage: OS2::BootDrive()");
+ Perl_croak_nocontext("Usage: OS2::BootDrive()");
{
ULONG si[1] = {0}; /* System Information Data Buffer */
APIRET rc = NO_ERROR; /* Return code */
if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
(PVOID)si, sizeof(si))))
- croak("DosQuerySysInfo() failed");
+ Perl_croak_nocontext("DosQuerySysInfo() failed");
ST(0) = sv_newmortal();
c = 'a' - 1 + si[0];
sv_setpvn(ST(0), &c, 1);
{
dXSARGS;
if (items != 1)
- croak("Usage: OS2::MorphPM(serve)");
+ Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
{
bool serve = SvOK(ST(0));
unsigned long pmq = perl_hmq_GET(serve);
{
dXSARGS;
if (items != 1)
- croak("Usage: OS2::UnMorphPM(serve)");
+ Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
{
bool serve = SvOK(ST(0));
{
dXSARGS;
if (items != 1)
- croak("Usage: OS2::Serve_Messages(force)");
+ Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
{
bool force = SvOK(ST(0));
unsigned long cnt = Perl_Serve_Messages(force);
{
dXSARGS;
if (items < 1 || items > 2)
- croak("Usage: OS2::Process_Messages(force [, cnt])");
+ Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
{
bool force = SvOK(ST(0));
unsigned long cnt;
- I32 *cntp = NULL;
if (items == 2) {
+ I32 cntr;
SV *sv = ST(1);
int fake = SvIV(sv); /* Force SvIVX */
if (!SvIOK(sv))
- croak("Can't upgrade count to IV");
- cntp = &SvIVX(sv);
- }
- cnt = Perl_Process_Messages(force, cntp);
+ 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);
}
{
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;
{
dXSARGS;
if (items < 0 || items > 1)
- croak("Usage: Cwd::extLibpath(type = 0)");
+ Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
{
bool type;
char to[1024];
{
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);
+ STRLEN n_a;
+ char * s = (char *)SvPV(ST(0),n_a);
bool type;
U32 rc;
bool RETVAL;
}
int
-Xs_OS2_init()
+Xs_OS2_init(pTHX)
{
char *file = __FILE__;
{
settmppath();
OS2_Perl_data.xs_init = &Xs_OS2_init;
_uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
- if (environ == NULL) {
+ if (environ == NULL && env) {
environ = env;
}
if ( (shell = getenv("PERL_SH_DRIVE")) ) {