diff options
Diffstat (limited to 'os2')
| -rw-r--r-- | os2/Makefile.SHs | 2 | ||||
| -rw-r--r-- | os2/OS2/REXX/t/rx_dllld.t | 6 | ||||
| -rw-r--r-- | os2/OS2/REXX/t/rx_objcall.t | 11 | ||||
| -rw-r--r-- | os2/OS2/REXX/t/rx_tievar.t | 4 | ||||
| -rw-r--r-- | os2/OS2/REXX/t/rx_tieydb.t | 4 | ||||
| -rw-r--r-- | os2/os2.c | 188 | ||||
| -rw-r--r-- | os2/os2ish.h | 64 |
7 files changed, 147 insertions, 132 deletions
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"; @@ -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, \ |