summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGurusamy Sarathy <gsar@cpan.org>2000-05-28 20:35:16 +0000
committerGurusamy Sarathy <gsar@cpan.org>2000-05-28 20:35:16 +0000
commit23da6c43783f76b0a8ab328bffdf5056143cc812 (patch)
treeaab69d00196c72f2c7da5c1767b49997f4308b0f
parent985777a996e880e5c56185272852a3da184fcdd4 (diff)
downloadperl-23da6c43783f76b0a8ab328bffdf5056143cc812.tar.gz
OS/2 tweaks for usethreads build (from Rocco Caputo
<troc@netrus.net>) p4raw-id: //depot/perl@6149
-rwxr-xr-xConfigure1
-rw-r--r--hints/os2.sh2
-rw-r--r--makedef.pl2
-rw-r--r--os2/Makefile.SHs2
-rw-r--r--os2/OS2/REXX/t/rx_dllld.t6
-rw-r--r--os2/OS2/REXX/t/rx_objcall.t11
-rw-r--r--os2/OS2/REXX/t/rx_tievar.t4
-rw-r--r--os2/OS2/REXX/t/rx_tieydb.t4
-rw-r--r--os2/os2.c188
-rw-r--r--os2/os2ish.h64
-rw-r--r--perl.c2
-rw-r--r--util.c2
-rw-r--r--x2p/a2p.h1
13 files changed, 153 insertions, 136 deletions
diff --git a/Configure b/Configure
index 83a685d303..9493fbc54c 100755
--- a/Configure
+++ b/Configure
@@ -3277,6 +3277,7 @@ while test "$type"; do
true)
case "$ansexp" in
/*) value="$ansexp" ;;
+ [a-zA-Z]:/*) value="$ansexp" ;;
*)
redo=true
case "$already" in
diff --git a/hints/os2.sh b/hints/os2.sh
index 1d9df3683f..0e9f786d25 100644
--- a/hints/os2.sh
+++ b/hints/os2.sh
@@ -93,7 +93,7 @@ if test "$libemx" = "X"; then echo "Cannot find C library!" >&2; fi
libpth="`echo \"$LIBRARY_PATH\" | tr ';\\\' ' /'`"
libpth="$libpth $libemx/mt $libemx"
-set `emxrev -f emxlibcm`
+set `cmd /c emxrev -f emxlibcm`
emxcrtrev=$5
# indented to not put it into config.sh
_defemxcrtrev=-D_EMX_CRT_REV_=$emxcrtrev
diff --git a/makedef.pl b/makedef.pl
index 6fae88be9e..ae68674aa7 100644
--- a/makedef.pl
+++ b/makedef.pl
@@ -157,7 +157,7 @@ elsif ($PLATFORM eq 'os2') {
# print STDERR "'$dll' <= '$define{PERL_DLL}'\n";
print <<"---EOP---";
LIBRARY '$dll' INITINSTANCE TERMINSTANCE
-DESCRIPTION '\@#perl5-porters\@perl.org:$v#\@ Perl interpreter, configured as $CONFIG_ARGS'
+DESCRIPTION '\@#perl5-porters\@perl.org:$v#\@ Perl interpreter'
STACKSIZE 32768
CODE LOADONCALL
DATA LOADONCALL NONSHARED MULTIPLE
diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs
index 3a50dc737c..f5a0c15634 100644
--- a/os2/Makefile.SHs
+++ b/os2/Makefile.SHs
@@ -66,7 +66,7 @@ $(PERL_DLL): $(obj) perl5.def perl$(OBJ_EXT)
perl5.olddef: perl.linkexp
echo "LIBRARY '$(PERL_DLL_BASE)' INITINSTANCE TERMINSTANCE" > $@
- echo DESCRIPTION "'Perl interpreter v$(PERL_FULLVERSION), export autogenerated, built with $(CONFIG_ARGS)'" >>$@
+ echo DESCRIPTION "'Perl interpreter v$(PERL_FULLVERSION), export autogenerated'" >>$@
echo STACKSIZE 32768 >>$@
echo CODE LOADONCALL >>$@
echo DATA LOADONCALL NONSHARED MULTIPLE >>$@
diff --git a/os2/OS2/REXX/t/rx_dllld.t b/os2/OS2/REXX/t/rx_dllld.t
index 15362d78e9..406bd63a33 100644
--- a/os2/OS2/REXX/t/rx_dllld.t
+++ b/os2/OS2/REXX/t/rx_dllld.t
@@ -12,11 +12,11 @@ use OS2::REXX;
$path = $ENV{LIBPATH} || $ENV{PATH} or die;
foreach $dir (split(';', $path)) {
- next unless -f "$dir/YDBAUTIL.DLL";
- $found = "$dir/YDBAUTIL.DLL";
+ next unless -f "$dir/RXU.DLL";
+ $found = "$dir/RXU.DLL";
last;
}
-$found or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit;
+$found or print "1..0 # skipped: cannot find RXU.DLL\n" and exit;
print "1..5\n";
diff --git a/os2/OS2/REXX/t/rx_objcall.t b/os2/OS2/REXX/t/rx_objcall.t
index 8bdf90564d..b1154757d4 100644
--- a/os2/OS2/REXX/t/rx_objcall.t
+++ b/os2/OS2/REXX/t/rx_objcall.t
@@ -13,22 +13,21 @@ use OS2::REXX;
#
# DLL
#
-$ydba = load OS2::REXX "ydbautil"
- or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit;
+$rxu = load OS2::REXX "rxu"
+ or print "1..0 # skipped: cannot find RXU.DLL\n" and exit;
print "1..5\n", "ok 1\n";
#
# function
#
-@pid = $ydba->RxProcId();
+@pid = $rxu->RxProcId();
@pid == 1 ? print "ok 2\n" : print "not ok 2\n";
@res = split " ", $pid[0];
print "ok 3\n" if $res[0] == $$;
-@pid = $ydba->RxProcId();
+@pid = $rxu->RxProcId();
@res = split " ", $pid[0];
print "ok 4\n" if $res[0] == $$;
print "# @pid\n";
-eval { $ydba->nixda(); };
+eval { $rxu->nixda(); };
print "ok 5\n" if $@ =~ /^Can't find entry 'nixda\'/;
-
diff --git a/os2/OS2/REXX/t/rx_tievar.t b/os2/OS2/REXX/t/rx_tievar.t
index 5f43f4e5fc..9c9ea7d466 100644
--- a/os2/OS2/REXX/t/rx_tievar.t
+++ b/os2/OS2/REXX/t/rx_tievar.t
@@ -13,8 +13,8 @@ use OS2::REXX;
#
# DLL
#
-load OS2::REXX "ydbautil"
- or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit;
+load OS2::REXX "rxu"
+ or print "1..0 # skipped: cannot find RXU.DLL\n" and exit;
print "1..19\n";
diff --git a/os2/OS2/REXX/t/rx_tieydb.t b/os2/OS2/REXX/t/rx_tieydb.t
index 1653a2081c..ec6bfca20e 100644
--- a/os2/OS2/REXX/t/rx_tieydb.t
+++ b/os2/OS2/REXX/t/rx_tieydb.t
@@ -9,8 +9,8 @@ BEGIN {
}
use OS2::REXX;
-$rx = load OS2::REXX "ydbautil" # from RXU17.ZIP
- or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit;
+$rx = load OS2::REXX "RXU" # from RXU1a.ZIP
+ or print "1..0 # skipped: cannot find RXU.DLL\n" and exit;
print "1..7\n", "ok 1\n";
diff --git a/os2/os2.c b/os2/os2.c
index 97e8899c35..45e1d2fb65 100644
--- a/os2/os2.c
+++ b/os2/os2.c
@@ -66,7 +66,7 @@ pthread_join(perl_os_thread tid, void **status)
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;
@@ -79,7 +79,7 @@ pthread_join(perl_os_thread tid, void **status)
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;
}
@@ -107,7 +107,7 @@ pthread_startit(void *arg)
}
}
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);
@@ -146,7 +146,7 @@ pthread_detach(perl_os_thread tid)
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;
@@ -154,7 +154,7 @@ pthread_detach(perl_os_thread tid)
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;
}
@@ -168,11 +168,11 @@ os2_cond_wait(perl_cond *c, perl_mutex *m)
int rc;
STRLEN n_a;
if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
- croak("panic: COND_WAIT-reset: rc=%i", rc);
+ 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);
@@ -199,12 +199,12 @@ loadByOrd(char *modname, ULONG ord)
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
@@ -227,11 +227,11 @@ init_PMWIN_entries(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++;
}
}
@@ -277,7 +277,7 @@ sys_prio(pid)
}
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);
@@ -373,8 +373,9 @@ spawn_sighandler(int sig)
}
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() */
@@ -441,7 +442,7 @@ file_type(char *path)
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:
@@ -464,12 +465,7 @@ static ULONG os2_mytype;
/* global PL_Argv[] contains arguments. */
int
-do_spawn_ve(really, flag, execf, inicmd, addflag)
-SV *really;
-U32 flag;
-U32 execf;
-char *inicmd;
-U32 addflag;
+do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
{
dTHR;
int trueflag = flag;
@@ -541,7 +537,7 @@ U32 addflag;
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);
}
}
@@ -552,7 +548,7 @@ U32 addflag;
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);
}
}
@@ -584,7 +580,7 @@ U32 addflag;
}
#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);
@@ -593,7 +589,7 @@ U32 addflag;
else if (execf == EXECF_SPAWN_NOWAIT)
rc = spawnvp(flag,tmps,PL_Argv);
else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
- rc = result(trueflag,
+ rc = result(aTHX_ trueflag,
spawnvp(flag,tmps,PL_Argv));
#endif
if (rc < 0 && pass == 1
@@ -618,7 +614,7 @@ U32 addflag;
if (l >= sizeof scrbuf) {
Safefree(scr);
longbuf:
- warn("Size of scriptname too big: %d", l);
+ Perl_warner(aTHX_ WARN_EXEC, "Size of scriptname too big: %d", l);
rc = -1;
goto finish;
}
@@ -654,7 +650,7 @@ U32 addflag;
}
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;
@@ -698,7 +694,7 @@ U32 addflag;
*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;
@@ -820,8 +816,9 @@ U32 addflag;
/* Try converting 1-arg form to (usually shell-less) multi-arg form. */
int
-do_spawn3(char *cmd, int execf, int flag)
+do_spawn3(pTHX_ char *cmd, int execf, int flag)
{
+ dTHR;
register char **a;
register char *s;
char flags[10];
@@ -905,7 +902,7 @@ do_spawn3(char *cmd, int execf, int flag)
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 && ckWARN(WARN_EXEC))
Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
@@ -936,7 +933,7 @@ do_spawn3(char *cmd, int execf, int flag)
}
*a = Nullch;
if (PL_Argv[0])
- rc = do_spawn_ve(NULL, flag, execf, cmd, mergestderr);
+ rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
else
rc = -1;
if (news)
@@ -947,10 +944,7 @@ do_spawn3(char *cmd, int execf, int flag)
/* Array spawn. */
int
-do_aspawn(really,mark,sp)
-SV *really;
-register SV **mark;
-register SV **sp;
+os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp)
{
dTHR;
register char **a;
@@ -978,9 +972,9 @@ register SV **sp;
*a = Nullch;
if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
- rc = do_spawn3(a[-1], EXECF_SPAWN_BYFLAG, flag);
+ rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
} else
- rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL, 0);
+ rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0);
} else
rc = -1;
do_execfree();
@@ -988,38 +982,36 @@ register SV **sp;
}
int
-do_spawn(cmd)
-char *cmd;
+os2_do_spawn(pTHX_ char *cmd)
{
- return do_spawn3(cmd, EXECF_SPAWN, 0);
+ dTHR;
+ return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
}
int
-do_spawn_nowait(cmd)
-char *cmd;
+do_spawn_nowait(pTHX_ char *cmd)
{
- return do_spawn3(cmd, EXECF_SPAWN_NOWAIT,0);
+ dTHR;
+ return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
}
bool
-do_exec(cmd)
-char *cmd;
+Perl_do_exec(pTHX_ char *cmd)
{
- do_spawn3(cmd, EXECF_EXEC, 0);
+ dTHR;
+ do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
return FALSE;
}
bool
-os2exec(cmd)
-char *cmd;
+os2exec(pTHX_ char *cmd)
{
- return do_spawn3(cmd, EXECF_TRUEEXEC, 0);
+ 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
@@ -1069,7 +1061,7 @@ char *mode;
fcntl(p[this], F_SETFD, FD_CLOEXEC);
if (newfd != -1)
fcntl(newfd, F_SETFD, FD_CLOEXEC);
- pid = do_spawn_nowait(cmd);
+ 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 */
@@ -1124,7 +1116,7 @@ char *mode;
int
fork(void)
{
- croak(PL_no_func, "Unsupported function fork");
+ Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
errno = EINVAL;
return -1;
}
@@ -1150,7 +1142,7 @@ 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);
if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
@@ -1164,7 +1156,7 @@ 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 (!(_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)
@@ -1230,7 +1222,7 @@ sys_alloc(int size) {
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;
}
@@ -1264,7 +1256,7 @@ XS(XS_File__Copy_syscopy)
{
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)");
{
STRLEN n_a;
char * src = (char *)SvPV(ST(0),n_a);
@@ -1288,8 +1280,7 @@ XS(XS_File__Copy_syscopy)
#include "patchlevel.h"
char *
-mod2fname(sv)
- SV *sv;
+mod2fname(pTHX_ SV *sv)
{
static char fname[9];
int pos = 6, len, avlen;
@@ -1299,14 +1290,14 @@ mod2fname(sv)
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), n_a);
strncpy(fname, s, 8);
@@ -1338,12 +1329,12 @@ XS(XS_DynaLoader_mod2fname)
{
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);
}
@@ -1374,8 +1365,9 @@ os2error(int rc)
}
char *
-os2_execname(void)
+os2_execname(pTHX)
{
+ dTHR;
char buf[300], *p;
if (_execname(buf, sizeof buf) != 0)
@@ -1412,7 +1404,7 @@ perllib_mangle(char *s, unsigned int l)
}
newl = strlen(newp);
if (newl == 0 || oldl == 0) {
- croak("Malformed PERLLIB_PREFIX");
+ Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
}
strcpy(ret, newp);
s = ret;
@@ -1434,7 +1426,7 @@ perllib_mangle(char *s, unsigned int l)
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;
@@ -1467,7 +1459,7 @@ Perl_Register_MQ(int serve)
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;
}
@@ -1481,11 +1473,11 @@ Perl_Serve_Messages(int force)
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;
@@ -1499,7 +1491,7 @@ Perl_Process_Messages(int force, I32 *cntp)
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)++;
@@ -1509,7 +1501,7 @@ Perl_Process_Messages(int force, I32 *cntp)
if (msg.msg == WM_CREATE)
return +1;
}
- croak("QUITing...");
+ Perl_croak_nocontext("QUITing...");
}
void
@@ -1525,7 +1517,7 @@ Perl_Deregister_MQ(int serve)
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);
}
}
@@ -1549,7 +1541,7 @@ XS(XS_OS2_Error)
{
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));
@@ -1559,7 +1551,7 @@ XS(XS_OS2_Error)
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);
@@ -1574,7 +1566,7 @@ XS(XS_OS2_Errors2Drive)
{
dXSARGS;
if (items != 1)
- croak("Usage: OS2::Errors2Drive(drive)");
+ Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
{
STRLEN n_a;
SV *sv = ST(0);
@@ -1584,12 +1576,12 @@ XS(XS_OS2_Errors2Drive)
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);
@@ -1632,7 +1624,7 @@ XS(XS_OS2_SysInfo)
{
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 */
@@ -1642,7 +1634,7 @@ XS(XS_OS2_SysInfo)
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();
@@ -1659,7 +1651,7 @@ XS(XS_OS2_BootDrive)
{
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 */
@@ -1667,7 +1659,7 @@ XS(XS_OS2_BootDrive)
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);
@@ -1679,7 +1671,7 @@ XS(XS_OS2_MorphPM)
{
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);
@@ -1694,7 +1686,7 @@ XS(XS_OS2_UnMorphPM)
{
dXSARGS;
if (items != 1)
- croak("Usage: OS2::UnMorphPM(serve)");
+ Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
{
bool serve = SvOK(ST(0));
@@ -1707,7 +1699,7 @@ XS(XS_OS2_Serve_Messages)
{
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);
@@ -1722,7 +1714,7 @@ XS(XS_OS2_Process_Messages)
{
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;
@@ -1733,7 +1725,7 @@ XS(XS_OS2_Process_Messages)
int fake = SvIV(sv); /* Force SvIVX */
if (!SvIOK(sv))
- croak("Can't upgrade count to IV");
+ Perl_croak_nocontext("Can't upgrade count to IV");
cntp = &SvIVX(sv);
}
cnt = Perl_Process_Messages(force, cntp);
@@ -1747,7 +1739,7 @@ XS(XS_Cwd_current_drive)
{
dXSARGS;
if (items != 0)
- croak("Usage: Cwd::current_drive()");
+ Perl_croak_nocontext("Usage: Cwd::current_drive()");
{
char RETVAL;
@@ -1762,7 +1754,7 @@ XS(XS_Cwd_sys_chdir)
{
dXSARGS;
if (items != 1)
- croak("Usage: Cwd::sys_chdir(path)");
+ Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
@@ -1779,7 +1771,7 @@ XS(XS_Cwd_change_drive)
{
dXSARGS;
if (items != 1)
- croak("Usage: Cwd::change_drive(d)");
+ Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
{
STRLEN n_a;
char d = (char)*SvPV(ST(0),n_a);
@@ -1796,7 +1788,7 @@ XS(XS_Cwd_sys_is_absolute)
{
dXSARGS;
if (items != 1)
- croak("Usage: Cwd::sys_is_absolute(path)");
+ Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
@@ -1813,7 +1805,7 @@ XS(XS_Cwd_sys_is_rooted)
{
dXSARGS;
if (items != 1)
- croak("Usage: Cwd::sys_is_rooted(path)");
+ Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
@@ -1830,7 +1822,7 @@ XS(XS_Cwd_sys_is_relative)
{
dXSARGS;
if (items != 1)
- croak("Usage: Cwd::sys_is_relative(path)");
+ Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
@@ -1847,7 +1839,7 @@ XS(XS_Cwd_sys_cwd)
{
dXSARGS;
if (items != 0)
- croak("Usage: Cwd::sys_cwd()");
+ Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
{
char p[MAXPATHLEN];
char * RETVAL;
@@ -1862,7 +1854,7 @@ XS(XS_Cwd_sys_abspath)
{
dXSARGS;
if (items < 1 || items > 2)
- croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
+ Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
@@ -1987,7 +1979,7 @@ 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;
char to[1024];
@@ -2011,7 +2003,7 @@ XS(XS_Cwd_extLibpath_set)
{
dXSARGS;
if (items < 1 || items > 2)
- croak("Usage: Cwd::extLibpath_set(s, type = 0)");
+ Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
{
STRLEN n_a;
char * s = (char *)SvPV(ST(0),n_a);
@@ -2033,7 +2025,7 @@ XS(XS_Cwd_extLibpath_set)
}
int
-Xs_OS2_init()
+Xs_OS2_init(pTHX)
{
char *file = __FILE__;
{
diff --git a/os2/os2ish.h b/os2/os2ish.h
index 76d1b8c4f3..23857ac532 100644
--- a/os2/os2ish.h
+++ b/os2/os2ish.h
@@ -82,6 +82,9 @@
#ifdef USE_THREADS
+#define do_spawn(a) os2_do_spawn(aTHX_ (a))
+#define do_aspawn(a,b,c) os2_do_aspawn(aTHX_ (a),(b),(c))
+
#define OS2_ERROR_ALREADY_POSTED 299 /* Avoid os2.h */
extern int rc;
@@ -90,49 +93,49 @@ extern int rc;
STMT_START { \
int rc; \
if ((rc = _rmutex_create(m,0))) \
- croak("panic: MUTEX_INIT: rc=%i", rc); \
+ Perl_croak_nocontext("panic: MUTEX_INIT: rc=%i", rc); \
} STMT_END
#define MUTEX_LOCK(m) \
STMT_START { \
int rc; \
if ((rc = _rmutex_request(m,_FMR_IGNINT))) \
- croak("panic: MUTEX_LOCK: rc=%i", rc); \
+ Perl_croak_nocontext("panic: MUTEX_LOCK: rc=%i", rc); \
} STMT_END
#define MUTEX_UNLOCK(m) \
STMT_START { \
int rc; \
if ((rc = _rmutex_release(m))) \
- croak("panic: MUTEX_UNLOCK: rc=%i", rc); \
+ Perl_croak_nocontext("panic: MUTEX_UNLOCK: rc=%i", rc); \
} STMT_END
#define MUTEX_DESTROY(m) \
STMT_START { \
int rc; \
if ((rc = _rmutex_close(m))) \
- croak("panic: MUTEX_DESTROY: rc=%i", rc); \
+ Perl_croak_nocontext("panic: MUTEX_DESTROY: rc=%i", rc); \
} STMT_END
#define COND_INIT(c) \
STMT_START { \
int rc; \
if ((rc = DosCreateEventSem(NULL,c,0,0))) \
- croak("panic: COND_INIT: rc=%i", rc); \
+ Perl_croak_nocontext("panic: COND_INIT: rc=%i", rc); \
} STMT_END
#define COND_SIGNAL(c) \
STMT_START { \
int rc; \
- if ((rc = DosPostEventSem(*(c))) && rc != OS2_ERROR_ALREADY_POSTED) \
- croak("panic: COND_SIGNAL, rc=%ld", rc); \
+ if ((rc = DosPostEventSem(*(c))) && rc != OS2_ERROR_ALREADY_POSTED)\
+ Perl_croak_nocontext("panic: COND_SIGNAL, rc=%ld", rc); \
} STMT_END
#define COND_BROADCAST(c) \
STMT_START { \
int rc; \
if ((rc = DosPostEventSem(*(c))) && rc != OS2_ERROR_ALREADY_POSTED)\
- croak("panic: COND_BROADCAST, rc=%i", rc); \
+ Perl_croak_nocontext("panic: COND_BROADCAST, rc=%i", rc); \
} STMT_END
/* #define COND_WAIT(c, m) \
STMT_START { \
if (WaitForSingleObject(*(c),INFINITE) == WAIT_FAILED) \
- croak("panic: COND_WAIT"); \
+ Perl_croak_nocontext("panic: COND_WAIT"); \
} STMT_END
*/
#define COND_WAIT(c, m) os2_cond_wait(c,m)
@@ -140,8 +143,8 @@ extern int rc;
#define COND_WAIT_win32(c, m) \
STMT_START { \
int rc; \
- if ((rc = SignalObjectAndWait(*(m),*(c),INFINITE,FALSE)))\
- croak("panic: COND_WAIT"); \
+ if ((rc = SignalObjectAndWait(*(m),*(c),INFINITE,FALSE))) \
+ Perl_croak_nocontext("panic: COND_WAIT"); \
else \
MUTEX_LOCK(m); \
} STMT_END
@@ -149,7 +152,7 @@ extern int rc;
STMT_START { \
int rc; \
if ((rc = DosCloseEventSem(*(c)))) \
- croak("panic: COND_DESTROY, rc=%i", rc); \
+ Perl_croak_nocontext("panic: COND_DESTROY, rc=%i", rc); \
} STMT_END
/*#define THR ((struct thread *) TlsGetValue(PL_thr_key))
#define dTHR struct thread *thr = THR
@@ -159,11 +162,15 @@ extern int rc;
# define pthread_getspecific(k) (*_threadstore())
# define pthread_setspecific(k,v) (*_threadstore()=v,0)
# define pthread_key_create(keyp,flag) (*keyp=_gettid(),0)
-#else
+#else /* USE_SLOW_THREAD_SPECIFIC */
# define pthread_getspecific(k) (*(k))
# define pthread_setspecific(k,v) (*(k)=(v),0)
-# define pthread_key_create(keyp,flag) (DosAllocThreadLocalMemory(1,(U32*)keyp) ? croak("LocalMemory"),1 : 0)
-#endif
+# define pthread_key_create(keyp,flag) \
+ ( DosAllocThreadLocalMemory(1,(U32*)keyp) \
+ ? Perl_croak_nocontext("LocalMemory"),1 \
+ : 0 \
+ )
+#endif /* USE_SLOW_THREAD_SPECIFIC */
#define pthread_key_delete(keyp)
#define pthread_self() _gettid()
#define YIELD DosSleep(0)
@@ -173,11 +180,16 @@ int pthread_join(pthread_t tid, void **status);
int pthread_detach(pthread_t tid);
int pthread_create(pthread_t *tid, const pthread_attr_t *attr,
void *(*start_routine)(void*), void *arg);
-#endif
+#endif /* PTHREAD_INCLUDED */
#define THREADS_ELSEWHERE
-#endif
+#else /* USE_THREADS */
+
+#define do_spawn(a) os2_do_spawn(a)
+#define do_aspawn(a,b,c) os2_do_aspawn((a),(b),(c))
+
+#endif /* USE_THREADS */
void Perl_OS2_init(char **);
@@ -231,9 +243,21 @@ void *sys_alloc(int size);
# define PerlIO FILE
#endif
+/* os2ish is used from a2p/a2p.h without pTHX/pTHX_ first being
+ * defined. Hack around this to get us to compile.
+*/
+#ifdef PTHX_UNUSED
+# ifndef pTHX
+# define pTHX
+# endif
+# ifndef pTHX_
+# define pTHX_
+# endif
+#endif
+
#define TMPPATH1 "plXXXXXX"
extern char *tmppath;
-PerlIO *my_syspopen(char *cmd, char *mode);
+PerlIO *my_syspopen(pTHX_ char *cmd, char *mode);
/* Cannot prototype with I32 at this point. */
int my_syspclose(PerlIO *f);
FILE *my_tmpfile (void);
@@ -352,7 +376,7 @@ void Perl_Deregister_MQ(int serve);
int Perl_Serve_Messages(int force);
/* Cannot prototype with I32 at this point. */
int Perl_Process_Messages(int force, long *cntp);
-char *os2_execname(void);
+char *os2_execname(pTHX);
struct _QMSG;
struct PMWIN_entries_t {
@@ -373,7 +397,7 @@ void init_PMWIN_entries(void);
#define perl_hmq_GET(serve) Perl_Register_MQ(serve)
#define perl_hmq_UNSET(serve) Perl_Deregister_MQ(serve)
-#define OS2_XS_init() (*OS2_Perl_data.xs_init)()
+#define OS2_XS_init() (*OS2_Perl_data.xs_init)(aTHX)
#if _EMX_CRT_REV_ >= 60
# define os2_setsyserrno(rc) (Perl_rc = rc, errno = errno_isOS2_set, \
diff --git a/perl.c b/perl.c
index 81287331c0..ff730d7733 100644
--- a/perl.c
+++ b/perl.c
@@ -3264,7 +3264,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
}
if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)))
#ifdef OS2
- sv_setpv(GvSV(tmpgv), os2_execname());
+ sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
#else
sv_setpv(GvSV(tmpgv),PL_origargv[0]);
#endif
diff --git a/util.c b/util.c
index ef9387d5fb..a5cd95419d 100644
--- a/util.c
+++ b/util.c
@@ -2319,7 +2319,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
PERL_FLUSHALL_FOR_CHILD;
#ifdef OS2
if (doexec) {
- return my_syspopen(cmd,mode);
+ return my_syspopen(aTHX_ cmd,mode);
}
#endif
This = (*mode == 'w');
diff --git a/x2p/a2p.h b/x2p/a2p.h
index 3b0338ca02..51a69dd11d 100644
--- a/x2p/a2p.h
+++ b/x2p/a2p.h
@@ -121,6 +121,7 @@
#ifdef DOSISH
# if defined(OS2)
+# define PTHX_UNUSED
# include "../os2ish.h"
# else
# include "../dosish.h"