#define SPU_ENABLESUPPRESSION 1
#include <os2.h>
#include "dlfcn.h"
+#include <emx/syscalls.h>
#include <sys/uflags.h>
#include "EXTERN.h"
#include "perl.h"
-#ifdef USE_5005THREADS
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
typedef void (*emx_startroutine)(void *);
typedef void* (*pthreads_startroutine)(void *);
pthreads_st_exited,
pthreads_st_detached,
pthreads_st_waited,
+ pthreads_st_norun,
+ pthreads_st_exited_waited,
};
const char *pthreads_states[] = {
"uninit",
"exited",
"detached",
"waited for",
+ "could not start",
+ "exited, then waited on",
};
+enum pthread_exists { pthread_not_existant = -0xff };
+
+static const char*
+pthreads_state_string(enum pthreads_state state)
+{
+ if (state < 0 || state >= sizeof(pthreads_states)/sizeof(*pthreads_states)) {
+ static char buf[80];
+
+ snprintf(buf, sizeof(buf), "unknown thread state %d", (int)state);
+ return buf;
+ }
+ return pthreads_states[state];
+}
+
typedef struct {
void *status;
perl_cond cond;
pthread_join(perl_os_thread tid, void **status)
{
MUTEX_LOCK(&start_thread_mutex);
+ if (tid < 1 || tid >= thread_join_count) {
+ MUTEX_UNLOCK(&start_thread_mutex);
+ if (tid != pthread_not_existant)
+ Perl_croak_nocontext("panic: join with a thread with strange ordinal %d", (int)tid);
+ Perl_warn_nocontext("panic: join with a thread which could not start");
+ *status = 0;
+ return 0;
+ }
switch (thread_join_data[tid].state) {
case pthreads_st_exited:
- thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
- MUTEX_UNLOCK(&start_thread_mutex);
+ thread_join_data[tid].state = pthreads_st_exited_waited;
*status = thread_join_data[tid].status;
+ MUTEX_UNLOCK(&start_thread_mutex);
+ COND_SIGNAL(&thread_join_data[tid].cond);
break;
case pthreads_st_waited:
MUTEX_UNLOCK(&start_thread_mutex);
Perl_croak_nocontext("join with a thread with a waiter");
break;
+ case pthreads_st_norun:
+ {
+ int state = (int)thread_join_data[tid].status;
+
+ thread_join_data[tid].state = pthreads_st_none;
+ MUTEX_UNLOCK(&start_thread_mutex);
+ Perl_croak_nocontext("panic: join with a thread which could not run"
+ " due to attempt of tid reuse (state='%s')",
+ pthreads_state_string(state));
+ break;
+ }
case pthreads_st_run:
+ {
+ perl_cond cond;
+
thread_join_data[tid].state = pthreads_st_waited;
+ thread_join_data[tid].status = (void *)status;
COND_INIT(&thread_join_data[tid].cond);
+ cond = thread_join_data[tid].cond;
+ COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
+ COND_DESTROY(&cond);
MUTEX_UNLOCK(&start_thread_mutex);
- COND_WAIT(&thread_join_data[tid].cond, NULL);
- COND_DESTROY(&thread_join_data[tid].cond);
- thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
- *status = thread_join_data[tid].status;
break;
+ }
default:
MUTEX_UNLOCK(&start_thread_mutex);
- Perl_croak_nocontext("join: unknown thread state: '%s'",
- pthreads_states[thread_join_data[tid].state]);
+ Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'",
+ pthreads_state_string(thread_join_data[tid].state));
break;
}
return 0;
}
+typedef struct {
+ pthreads_startroutine sub;
+ void *arg;
+ void *ctx;
+} pthr_startit;
+
+/* The lock is used:
+ a) Since we temporarily usurp the caller interp, so malloc() may
+ use it to decide on debugging the call;
+ b) Since *args is on the caller's stack.
+ */
void
-pthread_startit(void *arg)
+pthread_startit(void *arg1)
{
/* Thread is already started, we need to transfer control only */
- pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
+ pthr_startit args = *(pthr_startit *)arg1;
int tid = pthread_self();
- void *retval;
-
- arg = ((void**)arg)[1];
+ void *rc;
+ int state;
+
+ if (tid <= 1) {
+ /* Can't croak, the setjmp() is not in scope... */
+ char buf[80];
+
+ snprintf(buf, sizeof(buf),
+ "panic: thread with strange ordinal %d created\n\r", tid);
+ write(2,buf,strlen(buf));
+ MUTEX_UNLOCK(&start_thread_mutex);
+ return;
+ }
+ /* Until args.sub resets it, makes debugging Perl_malloc() work: */
+ PERL_SET_CONTEXT(0);
if (tid >= thread_join_count) {
int oc = thread_join_count;
Newz(1323, thread_join_data, thread_join_count, thread_join_t);
}
}
- if (thread_join_data[tid].state != pthreads_st_none)
- Perl_croak_nocontext("attempt to reuse thread id %i", tid);
+ if (thread_join_data[tid].state != pthreads_st_none) {
+ /* Can't croak, the setjmp() is not in scope... */
+ char buf[80];
+
+ snprintf(buf, sizeof(buf),
+ "panic: attempt to reuse thread id %d (state='%s')\n\r",
+ tid, pthreads_state_string(thread_join_data[tid].state));
+ write(2,buf,strlen(buf));
+ thread_join_data[tid].status = (void*)thread_join_data[tid].state;
+ thread_join_data[tid].state = pthreads_st_norun;
+ MUTEX_UNLOCK(&start_thread_mutex);
+ return;
+ }
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);
- thread_join_data[tid].status = (*start_routine)(arg);
+ rc = (*args.sub)(args.arg);
+ MUTEX_LOCK(&start_thread_mutex);
switch (thread_join_data[tid].state) {
case pthreads_st_waited:
- COND_SIGNAL(&thread_join_data[tid].cond);
+ COND_SIGNAL(&thread_join_data[tid].cond);
+ thread_join_data[tid].state = pthreads_st_none;
+ *((void**)thread_join_data[tid].status) = rc;
break;
- default:
+ case pthreads_st_detached:
+ thread_join_data[tid].state = pthreads_st_none;
+ break;
+ case pthreads_st_run:
+ /* Somebody can wait on us; cannot exit, since OS can reuse the tid
+ and our waiter will get somebody else's status. */
thread_join_data[tid].state = pthreads_st_exited;
+ thread_join_data[tid].status = rc;
+ COND_INIT(&thread_join_data[tid].cond);
+ COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
+ COND_DESTROY(&thread_join_data[tid].cond);
+ thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
break;
+ default:
+ state = thread_join_data[tid].state;
+ MUTEX_UNLOCK(&start_thread_mutex);
+ Perl_croak_nocontext("panic: unexpected thread state on exit: '%s'",
+ pthreads_state_string(state));
}
+ MUTEX_UNLOCK(&start_thread_mutex);
}
int
-pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
+pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr,
void *(*start_routine)(void*), void *arg)
{
- void *args[2];
+ dTHX;
+ pthr_startit args;
- args[0] = (void*)start_routine;
- args[1] = arg;
+ args.sub = (void*)start_routine;
+ args.arg = arg;
+ args.ctx = PERL_GET_CONTEXT;
MUTEX_LOCK(&start_thread_mutex);
- *tid = _beginthread(pthread_startit, /*stack*/ NULL,
- /*stacksize*/ 10*1024*1024, (void*)args);
- MUTEX_LOCK(&start_thread_mutex);
+ /* Test suite creates 31 extra threads;
+ on machine without shared-memory-hogs this stack sizeis OK with 31: */
+ *tidp = _beginthread(pthread_startit, /*stack*/ NULL,
+ /*stacksize*/ 4*1024*1024, (void*)&args);
+ if (*tidp == -1) {
+ *tidp = pthread_not_existant;
+ MUTEX_UNLOCK(&start_thread_mutex);
+ return EINVAL;
+ }
+ MUTEX_LOCK(&start_thread_mutex); /* Wait for init to proceed */
MUTEX_UNLOCK(&start_thread_mutex);
- return *tid ? 0 : EINVAL;
+ return 0;
}
int
pthread_detach(perl_os_thread tid)
{
MUTEX_LOCK(&start_thread_mutex);
+ if (tid < 1 || tid >= thread_join_count) {
+ MUTEX_UNLOCK(&start_thread_mutex);
+ if (tid != pthread_not_existant)
+ Perl_croak_nocontext("panic: detach of a thread with strange ordinal %d", (int)tid);
+ Perl_warn_nocontext("detach of a thread which could not start");
+ return 0;
+ }
switch (thread_join_data[tid].state) {
case pthreads_st_waited:
MUTEX_UNLOCK(&start_thread_mutex);
thread_join_data[tid].state = pthreads_st_detached;
MUTEX_UNLOCK(&start_thread_mutex);
break;
+ case pthreads_st_exited:
+ MUTEX_UNLOCK(&start_thread_mutex);
+ COND_SIGNAL(&thread_join_data[tid].cond);
+ break;
+ case pthreads_st_detached:
+ MUTEX_UNLOCK(&start_thread_mutex);
+ Perl_warn_nocontext("detach on an already detached thread");
+ break;
+ case pthreads_st_norun:
+ {
+ int state = (int)thread_join_data[tid].status;
+
+ thread_join_data[tid].state = pthreads_st_none;
+ MUTEX_UNLOCK(&start_thread_mutex);
+ Perl_croak_nocontext("panic: detaching thread which could not run"
+ " due to attempt of tid reuse (state='%s')",
+ pthreads_state_string(state));
+ break;
+ }
default:
MUTEX_UNLOCK(&start_thread_mutex);
- Perl_croak_nocontext("detach: unknown thread state: '%s'",
- pthreads_states[thread_join_data[tid].state]);
+ Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'",
+ pthreads_state_string(thread_join_data[tid].state));
break;
}
return 0;
}
-/* This is a very bastardized version: */
+/* This is a very bastardized version; may be OK due to edge trigger of Wait */
int
os2_cond_wait(perl_cond *c, perl_mutex *m)
{
Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc);
if (rc == ERROR_INTERRUPT)
errno = EINTR;
- if (m) MUTEX_LOCK(m);
+ if (m) MUTEX_LOCK(m);
+ return 0;
}
-#endif
+#endif
static int exe_is_aout(void);
{&pmwin_handle, NULL, 875}, /* WinSetWindowPos */
{&pmwin_handle, NULL, 877}, /* WinSetWindowText */
{&pmwin_handle, NULL, 883}, /* WinShowWindow */
- {&pmwin_handle, NULL, 872}, /* WinIsWindow */
+ {&pmwin_handle, NULL, 772}, /* WinIsWindow */
{&pmwin_handle, NULL, 899}, /* WinWindowFromId */
{&pmwin_handle, NULL, 900}, /* WinWindowFromPoint */
{&pmwin_handle, NULL, 919}, /* WinPostMsg */
+ {&pmwin_handle, NULL, 735}, /* WinEnableWindow */
+ {&pmwin_handle, NULL, 736}, /* WinEnableWindowUpdate */
+ {&pmwin_handle, NULL, 773}, /* WinIsWindowEnabled */
+ {&pmwin_handle, NULL, 774}, /* WinIsWindowShowing */
+ {&pmwin_handle, NULL, 775}, /* WinIsWindowVisible */
+ {&pmwin_handle, NULL, 839}, /* WinQueryWindowPtr */
+ {&pmwin_handle, NULL, 843}, /* WinQueryWindowULong */
+ {&pmwin_handle, NULL, 844}, /* WinQueryWindowUShort */
+ {&pmwin_handle, NULL, 874}, /* WinSetWindowBits */
+ {&pmwin_handle, NULL, 876}, /* WinSetWindowPtr */
+ {&pmwin_handle, NULL, 878}, /* WinSetWindowULong */
+ {&pmwin_handle, NULL, 879}, /* WinSetWindowUShort */
+ {&pmwin_handle, NULL, 813}, /* WinQueryDesktopWindow */
+ {&pmwin_handle, NULL, 851}, /* WinSetActiveWindow */
+ {&doscalls_handle, NULL, 360}, /* DosQueryModFromEIP */
};
static PFN ExtFCN[C_ARR_LEN(loadOrdinals)]; /* Labeled by ord ORD_*. */
if (pDosVerifyPidTid) { /* Warp3 or later */
/* Up to some fixpak QuerySysState() kills the system if a non-existent
pid is used. */
- if (!pDosVerifyPidTid(pid, 1))
+ if (CheckOSError(pDosVerifyPidTid(pid, 1)))
return 0;
}
New(1322, pbuffer, buf_len, char);
if (strEQ(PL_Argv[0],"/bin/sh"))
PL_Argv[0] = PL_sh_path;
- if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
- && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
- && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
- ) /* 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, n_a)))
tmps = PL_Argv[0];
+ if (tmps[0] != '/' && tmps[0] != '\\'
+ && !(tmps[0] && tmps[1] == ':'
+ && (tmps[2] == '/' || tmps[2] != '\\'))
+ ) /* will spawnvp use PATH? */
+ TAINT_ENV(); /* testing IFS here is overkill, probably */
reread:
force_shell = 0;
if (flag == P_NOWAIT)
flag = P_PM;
else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
- Perl_warner(aTHX_ WARN_EXEC, "Starting PM process with flag=%d, mytype=%d",
+ Perl_warner(aTHX_ packWARN(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)
- Perl_warner(aTHX_ WARN_EXEC, "Starting Full Screen process with flag=%d, mytype=%d",
+ Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d",
flag, os2_mytype);
}
}
}
if (PerlIO_close(file) != 0) { /* Failure */
panic_file:
- Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s",
+ Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
scr, Strerror(errno));
buf = ""; /* Not #! */
goto doshell_args;
*s++ = 0;
}
if (nargs == -1) {
- Perl_warner(aTHX_ WARN_EXEC, "Too many args on %.*s line of \"%s\"",
+ Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"",
s1 - buf, buf, scr);
nargs = 4;
argsp = fargs;
}
}
if (rc < 0 && ckWARN(WARN_EXEC))
- Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n",
+ Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n",
((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
? "spawn" : "exec"),
PL_Argv[0], Strerror(errno));
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",
+ Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
(execf == EXECF_SPAWN ? "spawn" : "exec"),
shell, Strerror(errno));
if (rc < 0)
#if OS2_STAT_HACK
+enum os2_stat_extra { /* EMX 0.9d fix 4 defines up to 0100000 */
+ os2_stat_archived = 0x1000000, /* 0100000000 */
+ os2_stat_hidden = 0x2000000, /* 0200000000 */
+ os2_stat_system = 0x4000000, /* 0400000000 */
+ os2_stat_force = 0x8000000, /* Do not ignore flags on chmod */
+};
+
+#define OS2_STAT_SPECIAL (os2_stat_system | os2_stat_archived | os2_stat_hidden)
+
+static void
+massage_os2_attr(struct stat *st)
+{
+ if ( ((st->st_mode & S_IFMT) != S_IFREG
+ && (st->st_mode & S_IFMT) != S_IFDIR)
+ || !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM)))
+ return;
+
+ if ( st->st_attr & FILE_ARCHIVED )
+ st->st_mode |= (os2_stat_archived | os2_stat_force);
+ if ( st->st_attr & FILE_HIDDEN )
+ st->st_mode |= (os2_stat_hidden | os2_stat_force);
+ if ( st->st_attr & FILE_SYSTEM )
+ st->st_mode |= (os2_stat_system | os2_stat_force);
+}
+
/* First attempt used DosQueryFSAttach which crashed the system when
used with 5.001. Now just look for /dev/. */
-
int
os2_stat(const char *name, struct stat *st)
{
static int ino = SHRT_MAX;
-
- if (stricmp(name, "/dev/con") != 0
- && stricmp(name, "/dev/tty") != 0)
- return stat(name, st);
+ STRLEN l = strlen(name);
+
+ if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0
+ || ( stricmp(name + 5, "con") != 0
+ && stricmp(name + 5, "tty") != 0
+ && stricmp(name + 5, "nul") != 0
+ && stricmp(name + 5, "null") != 0) ) {
+ int s = stat(name, st);
+
+ if (s)
+ return s;
+ massage_os2_attr(st);
+ return 0;
+ }
memset(st, 0, sizeof *st);
st->st_mode = S_IFCHR|0666;
return 0;
}
+int
+os2_fstat(int handle, struct stat *st)
+{
+ int s = fstat(handle, st);
+
+ if (s)
+ return s;
+ massage_os2_attr(st);
+ return 0;
+}
+
+#undef chmod
+int
+os2_chmod (const char *name, int pmode) /* Modelled after EMX src/lib/io/chmod.c */
+{
+ int attr, rc;
+
+ if (!(pmode & os2_stat_force))
+ return chmod(name, pmode);
+
+ attr = __chmod (name, 0, 0); /* Get attributes */
+ if (attr < 0)
+ return -1;
+ if (pmode & S_IWRITE)
+ attr &= ~FILE_READONLY;
+ else
+ attr |= FILE_READONLY;
+ /* New logic */
+ attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM);
+
+ if ( pmode & os2_stat_archived )
+ attr |= FILE_ARCHIVED;
+ if ( pmode & os2_stat_hidden )
+ attr |= FILE_HIDDEN;
+ if ( pmode & os2_stat_system )
+ attr |= FILE_SYSTEM;
+
+ rc = __chmod (name, 1, attr);
+ if (rc >= 0) rc = 0;
+ return rc;
+}
+
#endif
#ifdef USE_PERL_SBRK
}
avlen --;
}
-#ifdef USE_5005THREADS
- sum++; /* Avoid conflict of DLLs in memory. */
-#endif
/* 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.
char *
os2error(int rc)
{
+ dTHX;
static char buf[300];
ULONG len;
char *s;
return buf;
}
+void
+ResetWinError(void)
+{
+ WinError_2_Perl_rc;
+}
+
+void
+CroakWinError(int die, char *name)
+{
+ FillWinError;
+ if (die && Perl_rc) {
+ dTHX;
+
+ Perl_croak(aTHX_ "%s: %s", (name ? name : "Win* API call"), os2error(Perl_rc));
+ }
+}
+
char *
os2_execname(pTHX)
{
HMQ
Perl_Register_MQ(int serve)
{
+ if (Perl_hmq_refcnt <= 0) {
PPIB pib;
PTIB tib;
- if (Perl_os2_initial_mode++)
- return Perl_hmq;
+ Perl_hmq_refcnt = 0; /* Be extra safe */
DosGetInfoBlocks(&tib, &pib);
Perl_os2_initial_mode = pib->pib_ultype;
/* Try morphing into a PM application. */
/* 64 messages if before OS/2 3.0, ignored otherwise */
Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
if (!Perl_hmq) {
+ dTHX;
static int cnt;
SAVEINT(cnt); /* Allow catch()ing. */
_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... */
XSRETURN(1);
}
+/* Input: Address, BufLen
+APIRET APIENTRY
+DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
+ ULONG * Offset, ULONG Address);
+*/
+
+DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
+ (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
+ ULONG * Offset, ULONG Address),
+ (hmod, obj, BufLen, Buf, Offset, Address))
+
+enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full};
+
+static SV*
+module_name_at(void *pp, enum module_name_how how)
+{
+ dTHX;
+ char buf[MAXPATHLEN];
+ char *p = buf;
+ HMODULE mod;
+ ULONG obj, offset, rc;
+
+ if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, (ULONG)pp))
+ return &PL_sv_undef;
+ if (how == mod_name_handle)
+ return newSVuv(mod);
+ /* Full name... */
+ if ( how == mod_name_full
+ && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
+ return &PL_sv_undef;
+ while (*p) {
+ if (*p == '\\')
+ *p = '/';
+ p++;
+ }
+ return newSVpv(buf, 0);
+}
+
+static SV*
+module_name_of_cv(SV *cv, enum module_name_how how)
+{
+ if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
+ dTHX;
+
+ Perl_croak(aTHX_ "Not an XSUB reference");
+ }
+ return module_name_at(CvXSUB(SvRV(cv)), how);
+}
+
+/* Find module name to which *this* subroutine is compiled */
+#define module_name(how) module_name_at(&module_name_at, how)
+
+XS(XS_OS2_DLLname)
+{
+ dXSARGS;
+ if (items > 2)
+ Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
+ {
+ SV * RETVAL;
+ int how;
+
+ if (items < 1)
+ how = mod_name_full;
+ else {
+ how = (int)SvIV(ST(0));
+ }
+ if (items < 2)
+ RETVAL = module_name(how);
+ else
+ RETVAL = module_name_of_cv(ST(1), how);
+ ST(0) = RETVAL;
+ sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
#define get_control87() _control87(0,0)
#define set_control87 _control87
{
dXSARGS;
if (items != 2)
- croak("Usage: OS2::_control87(new,mask)");
+ Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
{
unsigned new = (unsigned)SvIV(ST(0));
unsigned mask = (unsigned)SvIV(ST(1));
{
dXSARGS;
if (items != 0)
- croak("Usage: OS2::get_control87()");
+ Perl_croak(aTHX_ "Usage: OS2::get_control87()");
{
unsigned RETVAL;
{
dXSARGS;
if (items < 0 || items > 2)
- croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
+ Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
{
unsigned new;
unsigned mask;
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, ";$$");
+ newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
GvMULTI_on(gv);
#ifdef PERL_IS_AOUT
my_os_version() {
static ULONG res; /* Cannot be on stack! */
- /* Can't just call emx_init(), since it moves the stack pointer */
- /* It also busts a lot of registers, so be extra careful */
+ /* Can't just call __os_version(), since it does not follow C
+ calling convention: it busts a lot of registers, so be extra careful */
__asm__( "pushf\n"
"pusha\n"
"call ___os_version\n"
if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
}
}
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
MUTEX_INIT(&start_thread_mutex);
+#endif
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 rmdir
+/* EMX flavors do not tolerate trailing slashes. t/op/mkdir.t has many
+ trailing slashes, so we need to support this as well. */
+
int
my_rmdir (__const__ char *s)
{
- char buf[MAXPATHLEN];
+ char b[MAXPATHLEN];
+ char *buf = b;
STRLEN l = strlen(s);
+ int rc;
- if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX rmdir fails... */
+ if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
+ if (l >= sizeof b)
+ New(1305, buf, l + 1, char);
strcpy(buf,s);
- buf[l - 1] = 0;
+ while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
+ l--;
+ buf[l] = 0;
s = buf;
}
- return rmdir(s);
+ rc = rmdir(s);
+ if (b != buf)
+ Safefree(buf);
+ return rc;
}
#undef mkdir
int
my_mkdir (__const__ char *s, long perm)
{
- char buf[MAXPATHLEN];
+ char b[MAXPATHLEN];
+ char *buf = b;
STRLEN l = strlen(s);
+ int rc;
if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
+ if (l >= sizeof b)
+ New(1305, buf, l + 1, char);
strcpy(buf,s);
- buf[l - 1] = 0;
+ while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
+ l--;
+ buf[l] = 0;
s = buf;
}
- return mkdir(s, perm);
+ rc = mkdir(s, perm);
+ if (b != buf)
+ Safefree(buf);
+ return rc;
}
#undef flock
if (!(_emx_env & 0x200) || !use_my)
return flock(handle, o); /* Delegate to EMX. */
- // is this a file?
+ /* is this a file? */
if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
(handle_type & 0xFF))
{
errno = EBADF;
return -1;
}
- // set lock/unlock ranges
+ /* set lock/unlock ranges */
rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
rFull.lRange = 0x7FFFFFFF;
- // set timeout for blocking
+ /* set timeout for blocking */
timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
- // shared or exclusive?
+ /* shared or exclusive? */
shared = (o & LOCK_SH) ? 1 : 0;
- // do not block the unlock
+ /* do not block the unlock */
if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
switch (rc) {
errno = ENOLCK;
return -1;
case ERROR_LOCK_VIOLATION:
- break; // not an error
+ break; /* not an error */
case ERROR_INVALID_PARAMETER:
case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
case ERROR_READ_LOCKS_NOT_SUPPORTED:
return -1;
}
}
- // lock may block
+ /* lock may block */
if (o & (LOCK_SH | LOCK_EX)) {
- // for blocking operations
+ /* for blocking operations */
for (;;) {
rc =
DosSetFileLocks(
errno = EINVAL;
return -1;
}
- // give away timeslice
+ /* give away timeslice */
DosSleep(1);
}
}
if (!use_my_pwent())
return getpwent(); /* Delegate to EMX. */
if (pwent_cnt++)
- return 0; // Return one entry only
+ return 0; /* Return one entry only */
return getpwuid(0);
}
getgrent (void)
{
if (grent_cnt++)
- return 0; // Return one entry only
+ return 0; /* Return one entry only */
return getgrgid(0);
}
{
return passw_wrap(getpwnam(n));
}
+
+char *
+gcvt_os2 (double value, int digits, char *buffer)
+{
+ return gcvt (value, digits, buffer);
+}
+
+#undef fork
+int fork_with_resources()
+{
+#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
+ dTHX;
+ void *ctx = PERL_GET_CONTEXT;
+#endif
+
+ int rc = fork();
+
+#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
+ if (rc == 0) { /* child */
+ ALLOC_THREAD_KEY; /* Acquire the thread-local memory */
+ PERL_SET_CONTEXT(ctx); /* Reinit the thread-local memory */
+ }
+#endif
+ return rc;
+}
projects / p5sagit/p5-mst-13.2.git / blobdiff