X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=os2%2Fos2.c;h=0490449f0d235b26d523b7ab12afcc88e914187a;hb=e0e3c57ad9f042b7ff4eb12755ee3feaad30892b;hp=39463e6cb6ed9eed44b735f6f6a1f16659744dc1;hpb=ebdd4fa0c0f72122a0aef85c22b8fa4d49b01b78;p=p5sagit%2Fp5-mst-13.2.git diff --git a/os2/os2.c b/os2/os2.c index 39463e6..0490449 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -9,6 +9,7 @@ #define SPU_ENABLESUPPRESSION 1 #include #include "dlfcn.h" +#include #include @@ -29,7 +30,7 @@ #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 *); @@ -40,6 +41,8 @@ enum pthreads_state { pthreads_st_exited, pthreads_st_detached, pthreads_st_waited, + pthreads_st_norun, + pthreads_st_exited_waited, }; const char *pthreads_states[] = { "uninit", @@ -47,8 +50,24 @@ const char *pthreads_states[] = { "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; @@ -63,43 +82,90 @@ int 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; @@ -111,43 +177,89 @@ pthread_startit(void *arg) 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); @@ -157,16 +269,35 @@ pthread_detach(perl_os_thread tid) 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) { @@ -180,9 +311,10 @@ 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); @@ -276,10 +408,25 @@ static const struct { {&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_*. */ @@ -378,7 +525,7 @@ get_sysinfo(ULONG pid, ULONG flags) 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); @@ -618,14 +765,14 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) 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; @@ -667,7 +814,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) 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); } } @@ -678,7 +825,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) 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); } } @@ -775,7 +922,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) } 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; @@ -819,7 +966,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) *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; @@ -922,7 +1069,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) } } 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)); @@ -1031,7 +1178,7 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) 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) @@ -1265,17 +1412,51 @@ int setgid(x) { errno = EINVAL; return -1; } #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; @@ -1284,6 +1465,48 @@ os2_stat(const char *name, struct stat *st) 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 @@ -1391,9 +1614,6 @@ mod2fname(pTHX_ SV *sv) } 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. @@ -1431,6 +1651,7 @@ XS(XS_DynaLoader_mod2fname) char * os2error(int rc) { + dTHX; static char buf[300]; ULONG len; char *s; @@ -1467,6 +1688,23 @@ os2error(int rc) 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) { @@ -1558,11 +1796,11 @@ Perl_hab_GET() /* Needed if perl.h cannot be included */ 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. */ @@ -1572,6 +1810,7 @@ Perl_Register_MQ(int serve) /* 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. */ @@ -1579,6 +1818,7 @@ Perl_Register_MQ(int serve) _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... */ @@ -2194,6 +2434,82 @@ XS(XS_Cwd_extLibpath_set) 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 @@ -2201,7 +2517,7 @@ XS(XS_OS2__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)); @@ -2218,7 +2534,7 @@ XS(XS_OS2_get_control87) { dXSARGS; if (items != 0) - croak("Usage: OS2::get_control87()"); + Perl_croak(aTHX_ "Usage: OS2::get_control87()"); { unsigned RETVAL; @@ -2234,7 +2550,7 @@ XS(XS_OS2_set_control87) { 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; @@ -2291,6 +2607,7 @@ Xs_OS2_init(pTHX) 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 @@ -2365,8 +2682,8 @@ static ULONG 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" @@ -2654,7 +2971,9 @@ Perl_OS2_init3(char **env, void **preg, int flags) 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); @@ -2692,18 +3011,30 @@ my_tmpfile () #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 @@ -2711,15 +3042,24 @@ my_rmdir (__const__ char *s) 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 @@ -2744,21 +3084,21 @@ my_flock(int handle, int o) 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) { @@ -2772,7 +3112,7 @@ my_flock(int handle, int o) 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: @@ -2786,9 +3126,9 @@ my_flock(int handle, int o) return -1; } } - // lock may block + /* lock may block */ if (o & (LOCK_SH | LOCK_EX)) { - // for blocking operations + /* for blocking operations */ for (;;) { rc = DosSetFileLocks( @@ -2826,7 +3166,7 @@ my_flock(int handle, int o) errno = EINVAL; return -1; } - // give away timeslice + /* give away timeslice */ DosSleep(1); } } @@ -2880,7 +3220,7 @@ my_getpwent (void) 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); } @@ -2901,7 +3241,7 @@ struct group * getgrent (void) { if (grent_cnt++) - return 0; // Return one entry only + return 0; /* Return one entry only */ return getgrgid(0); } @@ -2939,3 +3279,28 @@ my_getpwnam (__const__ char *n) { 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; +}