+ if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
+ dTHX;
+
+ if (how & mod_name_C_function)
+ return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function);
+ else if (how & mod_name_HMODULE)
+ return module_name_at((void*)SvIV(cv), how);
+ Perl_croak(aTHX_ "Not an XSUB reference");
+ }
+ return module_name_at(CvXSUB(SvRV(cv)), 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);
+}
+
+DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo,
+ (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum),
+ (r1, r2, buf, szbuf, fnum))
+
+XS(XS_OS2__headerInfo)
+{
+ dXSARGS;
+ if (items > 4 || items < 2)
+ Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])");
+ {
+ ULONG req = (ULONG)SvIV(ST(0));
+ STRLEN size = (STRLEN)SvIV(ST(1)), n_a;
+ ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0);
+ ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0);
+
+ if (size <= 0)
+ Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size);
+ ST(0) = newSVpvn("",0);
+ SvGROW(ST(0), size + 1);
+ sv_2mortal(ST(0));
+
+ if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req))
+ Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
+ req, size, handle, offset, os2error(Perl_rc));
+ SvCUR_set(ST(0), size);
+ *SvEND(ST(0)) = 0;
+ }
+ XSRETURN(1);
+}
+
+#define DQHI_QUERYLIBPATHSIZE 4
+#define DQHI_QUERYLIBPATH 5
+
+XS(XS_OS2_libPath)
+{
+ dXSARGS;
+ if (items != 0)
+ Perl_croak(aTHX_ "Usage: OS2::libPath()");
+ {
+ ULONG size;
+ STRLEN n_a;
+
+ if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size),
+ DQHI_QUERYLIBPATHSIZE))
+ Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
+ DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0,
+ os2error(Perl_rc));
+ ST(0) = newSVpvn("",0);
+ SvGROW(ST(0), size + 1);
+ sv_2mortal(ST(0));
+
+ /* We should be careful: apparently, this entry point does not
+ pay attention to the size argument, so may overwrite
+ unrelated data! */
+ if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size,
+ DQHI_QUERYLIBPATH))
+ Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
+ DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc));
+ SvCUR_set(ST(0), size);
+ *SvEND(ST(0)) = 0;
+ }
+ XSRETURN(1);
+}
+
+#define get_control87() _control87(0,0)
+#define set_control87 _control87
+
+XS(XS_OS2__control87)
+{
+ dXSARGS;
+ if (items != 2)
+ Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
+ {
+ unsigned new = (unsigned)SvIV(ST(0));
+ unsigned mask = (unsigned)SvIV(ST(1));
+ unsigned RETVAL;
+ dXSTARG;
+
+ RETVAL = _control87(new, mask);
+ XSprePUSH; PUSHi((IV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_mytype)
+{
+ dXSARGS;
+ int which = 0;
+
+ if (items < 0 || items > 1)
+ Perl_croak(aTHX_ "Usage: OS2::mytype([which])");
+ if (items == 1)
+ which = (int)SvIV(ST(0));
+ {
+ unsigned RETVAL;
+ dXSTARG;
+
+ switch (which) {
+ case 0:
+ RETVAL = os2_mytype; /* Reset after fork */
+ break;
+ case 1:
+ RETVAL = os2_mytype_ini; /* Before any fork */
+ break;
+ case 2:
+ RETVAL = Perl_os2_initial_mode; /* Before first morphing */
+ break;
+ case 3:
+ RETVAL = my_type(); /* Morphed type */
+ break;
+ default:
+ Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which);
+ }
+ XSprePUSH; PUSHi((IV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
+
+XS(XS_OS2_mytype_set)
+{
+ dXSARGS;
+ int type;
+
+ if (items == 1)
+ type = (int)SvIV(ST(0));
+ else
+ Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)");
+ my_type_set(type);
+ XSRETURN_EMPTY;
+}
+
+
+XS(XS_OS2_get_control87)
+{
+ dXSARGS;
+ if (items != 0)
+ Perl_croak(aTHX_ "Usage: OS2::get_control87()");
+ {
+ unsigned RETVAL;
+ dXSTARG;
+
+ RETVAL = get_control87();
+ XSprePUSH; PUSHi((IV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
+
+XS(XS_OS2_set_control87)
+{
+ dXSARGS;
+ if (items < 0 || items > 2)
+ Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
+ {
+ unsigned new;
+ unsigned mask;
+ unsigned RETVAL;
+ dXSTARG;
+
+ if (items < 1)
+ new = MCW_EM;
+ else {
+ new = (unsigned)SvIV(ST(0));
+ }
+
+ if (items < 2)
+ mask = MCW_EM;
+ else {
+ mask = (unsigned)SvIV(ST(1));
+ }
+
+ RETVAL = set_control87(new, mask);
+ XSprePUSH; PUSHi((IV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */
+{
+ dXSARGS;
+ if (items < 0 || items > 1)
+ Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)");
+ {
+ LONG delta;
+ ULONG RETVAL, rc;
+ dXSTARG;
+
+ if (items < 1)
+ delta = 0;
+ else
+ delta = (LONG)SvIV(ST(0));
+
+ if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL)))
+ croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error");
+ XSprePUSH; PUSHu((UV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
+int
+Xs_OS2_init(pTHX)
+{
+ char *file = __FILE__;
+ {
+ GV *gv;
+
+ if (_emx_env & 0x200) { /* OS/2 */
+ newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
+ newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
+ newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
+ newXS("OS2::extLibpath", XS_Cwd_extLibpath, file);
+ newXS("OS2::extLibpath_set", XS_Cwd_extLibpath_set, file);
+ }
+ newXS("OS2::Error", XS_OS2_Error, file);
+ newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
+ newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
+ newXSproto("OS2::DevCap", XS_OS2_DevCap, file, ";$$");
+ newXSproto("OS2::SysInfoFor", XS_OS2_SysInfoFor, file, "$;$");
+ newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
+ newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
+ newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
+ newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
+ newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
+ newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
+ newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
+ newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
+ newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
+ newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
+ newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
+ newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
+ newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
+ newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
+ newXS("OS2::replaceModule", XS_OS2_replaceModule, file);
+ newXS("OS2::perfSysCall", XS_OS2_perfSysCall, file);
+ 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, ";$$");
+ newXSproto("OS2::mytype", XS_OS2_mytype, file, ";$");
+ newXSproto("OS2::mytype_set", XS_OS2_mytype_set, file, "$");
+ newXSproto("OS2::_headerInfo", XS_OS2__headerInfo, file, "$$;$$");
+ newXSproto("OS2::libPath", XS_OS2_libPath, file, "");
+ newXSproto("OS2::Timer", XS_OS2_Timer, file, "");
+ newXSproto("OS2::msCounter", XS_OS2_msCounter, file, "");
+ newXSproto("OS2::ms_sleep", XS_OS2_ms_sleep, file, "$;$");
+ newXSproto("OS2::_InfoTable", XS_OS2__InfoTable, file, ";$");
+ newXSproto("OS2::incrMaxFHandles", XS_OS2_incrMaxFHandles, file, ";$");
+ newXSproto("OS2::SysValues", XS_OS2_SysValues, file, ";$$");
+ newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$");
+ newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$");
+ gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+#ifdef PERL_IS_AOUT
+ sv_setiv(GvSV(gv), 1);
+#endif
+ gv = gv_fetchpv("OS2::is_static", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+#ifdef PERL_IS_AOUT
+ sv_setiv(GvSV(gv), 1);
+#endif
+ gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setiv(GvSV(gv), exe_is_aout());
+ gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setiv(GvSV(gv), _emx_rev);
+ sv_setpv(GvSV(gv), _emx_vprt);
+ SvIOK_on(GvSV(gv));
+ gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setiv(GvSV(gv), _emx_env);
+ gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
+ gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
+ }
+ return 0;
+}
+
+extern void _emx_init(void*);
+
+static void jmp_out_of_atexit(void);
+
+#define FORCE_EMX_INIT_CONTRACT_ARGV 1
+#define FORCE_EMX_INIT_INSTALL_ATEXIT 2
+
+static void
+my_emx_init(void *layout) {
+ static volatile void *old_esp = 0; /* 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 */
+ __asm__( "pushf\n"
+ "pusha\n"
+ "movl %%esp, %1\n"
+ "push %0\n"
+ "call __emx_init\n"
+ "movl %1, %%esp\n"
+ "popa\n"
+ "popf\n" : : "r" (layout), "m" (old_esp) );
+}
+
+struct layout_table_t {
+ ULONG text_base;
+ ULONG text_end;
+ ULONG data_base;
+ ULONG data_end;
+ ULONG bss_base;
+ ULONG bss_end;
+ ULONG heap_base;
+ ULONG heap_end;
+ ULONG heap_brk;
+ ULONG heap_off;
+ ULONG os2_dll;
+ ULONG stack_base;
+ ULONG stack_end;
+ ULONG flags;
+ ULONG reserved[2];
+ char options[64];
+};
+
+static ULONG
+my_os_version() {
+ static ULONG osv_res; /* Cannot be on stack! */
+
+ /* 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"
+ "movl %%eax, %0\n"
+ "popa\n"
+ "popf\n" : "=m" (osv_res) );
+
+ return osv_res;
+}
+
+static void
+force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
+{
+ /* Calling emx_init() will bust the top of stack: it installs an
+ exception handler and puts argv data there. */
+ char *oldarg, *oldenv;
+ void *oldstackend, *oldstack;
+ PPIB pib;
+ PTIB tib;
+ ULONG rc, error = 0, out;
+ char buf[512];
+ static struct layout_table_t layout_table;
+ struct {
+ char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
+ double alignment1;
+ EXCEPTIONREGISTRATIONRECORD xreg;
+ } *newstack;
+ char *s;
+
+ layout_table.os2_dll = (ULONG)&os2_dll_fake;
+ layout_table.flags = 0x02000002; /* flags: application, OMF */
+
+ DosGetInfoBlocks(&tib, &pib);
+ oldarg = pib->pib_pchcmd;
+ oldenv = pib->pib_pchenv;
+ oldstack = tib->tib_pstack;
+ oldstackend = tib->tib_pstacklimit;
+
+ if ( (char*)&s < (char*)oldstack + 4*1024
+ || (char *)oldstackend < (char*)oldstack + 52*1024 )
+ early_error("It is a lunacy to try to run EMX Perl ",
+ "with less than 64K of stack;\r\n",
+ " at least with non-EMX starter...\r\n");
+
+ /* Minimize the damage to the stack via reducing the size of argv. */
+ if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
+ pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */
+ pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */
+ }
+
+ newstack = alloca(sizeof(*newstack));
+ /* Emulate the stack probe */
+ s = ((char*)newstack) + sizeof(*newstack);
+ while (s > (char*)newstack) {
+ s[-1] = 0;
+ s -= 4096;
+ }
+
+ /* Reassigning stack is documented to work */
+ tib->tib_pstack = (void*)newstack;
+ tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
+
+ /* Can't just call emx_init(), since it moves the stack pointer */
+ my_emx_init((void*)&layout_table);
+
+ /* Remove the exception handler, cannot use it - too low on the stack.
+ Check whether it is inside the new stack. */
+ buf[0] = 0;
+ if (tib->tib_pexchain >= tib->tib_pstacklimit
+ || tib->tib_pexchain < tib->tib_pstack) {
+ error = 1;
+ sprintf(buf,
+ "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
+ (unsigned long)tib->tib_pstack,
+ (unsigned long)tib->tib_pexchain,
+ (unsigned long)tib->tib_pstacklimit);
+ goto finish;
+ }
+ if (tib->tib_pexchain != &(newstack->xreg)) {
+ sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
+ (unsigned long)tib->tib_pexchain,
+ (unsigned long)&(newstack->xreg));
+ }
+ rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
+ if (rc)
+ sprintf(buf + strlen(buf),
+ "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
+
+ if (preg) {
+ /* ExceptionRecords should be on stack, in a correct order. Sigh... */
+ preg->prev_structure = 0;
+ preg->ExceptionHandler = _emx_exception;
+ rc = DosSetExceptionHandler(preg);
+ if (rc) {
+ sprintf(buf + strlen(buf),
+ "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
+ DosWrite(2, buf, strlen(buf), &out);
+ emx_exception_init = 1; /* Do it around spawn*() calls */
+ }
+ } else
+ emx_exception_init = 1; /* Do it around spawn*() calls */
+
+ finish:
+ /* Restore the damage */
+ pib->pib_pchcmd = oldarg;
+ pib->pib_pchcmd = oldenv;
+ tib->tib_pstacklimit = oldstackend;
+ tib->tib_pstack = oldstack;
+ emx_runtime_init = 1;
+ if (buf[0])
+ DosWrite(2, buf, strlen(buf), &out);
+ if (error)
+ exit(56);
+}
+
+static void
+jmp_out_of_atexit(void)
+{
+ if (longjmp_at_exit)
+ longjmp(at_exit_buf, 1);
+}
+
+extern void _CRT_term(void);
+
+void
+Perl_OS2_term(void **p, int exitstatus, int flags)
+{
+ if (!emx_runtime_secondary)
+ return;
+
+ /* The principal executable is not running the same CRTL, so there
+ is nobody to shutdown *this* CRTL except us... */
+ if (flags & FORCE_EMX_DEINIT_EXIT) {
+ if (p && !emx_exception_init)
+ DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
+ /* Do not run the executable's CRTL's termination routines */
+ exit(exitstatus); /* Run at-exit, flush buffers, etc */
+ }
+ /* Run at-exit list, and jump out at the end */
+ if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
+ longjmp_at_exit = 1;
+ exit(exitstatus); /* The first pass through "if" */
+ }
+
+ /* Get here if we managed to jump out of exit(), or did not run atexit. */
+ longjmp_at_exit = 0; /* Maybe exit() is called again? */
+#if 0 /* _atexit_n is not exported */
+ if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
+ _atexit_n = 0; /* Remove the atexit() handlers */
+#endif
+ /* Will segfault on program termination if we leave this dangling... */
+ if (p && !emx_exception_init)
+ DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
+ /* Typically there is no need to do this, done from _DLL_InitTerm() */
+ if (flags & FORCE_EMX_DEINIT_CRT_TERM)
+ _CRT_term(); /* Flush buffers, etc. */
+ /* Now it is a good time to call exit() in the caller's CRTL... */
+}
+
+#include <emx/startup.h>
+
+extern ULONG __os_version(); /* See system.doc */
+
+void
+check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
+{
+ ULONG v_crt, v_emx, count = 0, rc = NO_ERROR, rc1, maybe_inited = 0;
+ static HMTX hmtx_emx_init = NULLHANDLE;
+ static int emx_init_done = 0;
+
+ /* If _environ is not set, this code sits in a DLL which
+ uses a CRT DLL which not compatible with the executable's
+ CRT library. Some parts of the DLL are not initialized.
+ */
+ if (_environ != NULL)
+ return; /* Properly initialized */
+
+ /* It is not DOS, so we may use OS/2 API now */
+ /* Some data we manipulate is static; protect ourselves from
+ calling the same API from a different thread. */
+ DosEnterMustComplete(&count);
+
+ rc1 = DosEnterCritSec();
+ if (!hmtx_emx_init)
+ rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/
+ else
+ maybe_inited = 1;
+
+ if (rc != NO_ERROR)
+ hmtx_emx_init = NULLHANDLE;
+
+ if (rc1 == NO_ERROR)
+ DosExitCritSec();
+ DosExitMustComplete(&count);
+
+ while (maybe_inited) { /* Other thread did or is doing the same now */
+ if (emx_init_done)
+ return;
+ rc = DosRequestMutexSem(hmtx_emx_init,
+ (ULONG) SEM_INDEFINITE_WAIT); /* Timeout (none) */
+ if (rc == ERROR_INTERRUPT)
+ continue;
+ if (rc != NO_ERROR) {
+ char buf[80];
+ ULONG out;
+
+ sprintf(buf,
+ "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc);
+ DosWrite(2, buf, strlen(buf), &out);
+ return;
+ }
+ DosReleaseMutexSem(hmtx_emx_init);
+ return;
+ }
+
+ /* If the executable does not use EMX.DLL, EMX.DLL is not completely
+ initialized either. Uninitialized EMX.DLL returns 0 in the low
+ nibble of __os_version(). */
+ v_emx = my_os_version();
+
+ /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
+ (=>_CRT_init=>_entry2) via a call to __os_version(), then
+ reset when the EXE initialization code calls _text=>_init=>_entry2.
+ The first time they are wrongly set to 0; the second time the
+ EXE initialization code had already called emx_init=>initialize1
+ which correctly set version_major, version_minor used by
+ __os_version(). */
+ v_crt = (_osmajor | _osminor);
+
+ if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */
+ force_init_emx_runtime( preg,
+ FORCE_EMX_INIT_CONTRACT_ARGV
+ | FORCE_EMX_INIT_INSTALL_ATEXIT );
+ emx_wasnt_initialized = 1;
+ /* Update CRTL data basing on now-valid EMX runtime data */
+ if (!v_crt) { /* The only wrong data are the versions. */
+ v_emx = my_os_version(); /* *Now* it works */
+ *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
+ *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
+ }
+ }
+ emx_runtime_secondary = 1;
+ /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
+ atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */
+
+ if (env == NULL) { /* Fetch from the process info block */
+ int c = 0;
+ PPIB pib;
+ PTIB tib;
+ char *e, **ep;
+
+ DosGetInfoBlocks(&tib, &pib);
+ e = pib->pib_pchenv;
+ while (*e) { /* Get count */
+ c++;
+ e = e + strlen(e) + 1;
+ }
+ Newx(env, c + 1, char*);
+ ep = env;
+ e = pib->pib_pchenv;
+ while (c--) {
+ *ep++ = e;
+ e = e + strlen(e) + 1;
+ }
+ *ep = NULL;
+ }
+ _environ = _org_environ = env;
+ emx_init_done = 1;
+ if (hmtx_emx_init)
+ DosReleaseMutexSem(hmtx_emx_init);
+}
+
+#define ENTRY_POINT 0x10000
+
+static int
+exe_is_aout(void)
+{
+ struct layout_table_t *layout;
+ if (emx_wasnt_initialized)
+ return 0;
+ /* Now we know that the principal executable is an EMX application
+ - unless somebody did already play with delayed initialization... */
+ /* With EMX applications to determine whether it is AOUT one needs
+ to examine the start of the executable to find "layout" */
+ if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */
+ || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */
+ || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */
+ || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */
+ return 0; /* ! EMX executable */
+ /* Fix alignment */
+ Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
+ return !(layout->flags & 2);
+}
+
+void
+Perl_OS2_init(char **env)
+{
+ Perl_OS2_init3(env, 0, 0);
+}
+
+void
+Perl_OS2_init3(char **env, void **preg, int flags)
+{
+ char *shell, *s;
+ ULONG rc;
+
+ _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
+ MALLOC_INIT;
+
+ check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
+
+ settmppath();
+ OS2_Perl_data.xs_init = &Xs_OS2_init;
+ if (perl_sh_installed) {
+ int l = strlen(perl_sh_installed);
+
+ Newx(PL_sh_path, l + 1, char);
+ memcpy(PL_sh_path, perl_sh_installed, l + 1);
+ } else if ( (shell = getenv("PERL_SH_DRIVE")) ) {
+ Newx(PL_sh_path, strlen(SH_PATH) + 1, char);
+ strcpy(PL_sh_path, SH_PATH);
+ PL_sh_path[0] = shell[0];
+ } else if ( (shell = getenv("PERL_SH_DIR")) ) {
+ int l = strlen(shell), i;
+
+ while (l && (shell[l-1] == '/' || shell[l-1] == '\\'))
+ l--;
+ Newx(PL_sh_path, l + 8, char);
+ strncpy(PL_sh_path, shell, l);
+ strcpy(PL_sh_path + l, "/sh.exe");
+ for (i = 0; i < l; i++) {
+ if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
+ }
+ }
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
+ MUTEX_INIT(&start_thread_mutex);
+ MUTEX_INIT(&perlos2_state_mutex);
+#endif
+ os2_mytype = my_type(); /* Do it before morphing. Needed? */
+ os2_mytype_ini = os2_mytype;
+ Perl_os2_initial_mode = -1; /* Uninit */
+
+ s = getenv("PERL_BEGINLIBPATH");
+ if (s)
+ rc = fill_extLibpath(0, s, NULL, 1, "PERL_BEGINLIBPATH");
+ else
+ rc = fill_extLibpath(0, getenv("PERL_PRE_BEGINLIBPATH"), getenv("PERL_POST_BEGINLIBPATH"), 0, "PERL_(PRE/POST)_BEGINLIBPATH");
+ if (!rc) {
+ s = getenv("PERL_ENDLIBPATH");
+ if (s)
+ rc = fill_extLibpath(1, s, NULL, 1, "PERL_ENDLIBPATH");
+ else
+ rc = fill_extLibpath(1, getenv("PERL_PRE_ENDLIBPATH"), getenv("PERL_POST_ENDLIBPATH"), 0, "PERL_(PRE/POST)_ENDLIBPATH");
+ }
+ if (rc) {
+ char buf[1024];
+
+ snprintf(buf, sizeof buf, "Error setting BEGIN/ENDLIBPATH: %s\n",
+ os2error(rc));
+ DosWrite(2, buf, strlen(buf), &rc);
+ exit(2);
+ }
+
+ _emxload_env("PERL_EMXLOAD_SECS");
+ /* Some DLLs reset FP flags on load. We may have been linked with them */
+ _control87(MCW_EM, MCW_EM);
+}
+
+int
+fd_ok(int fd)
+{
+ static ULONG max_fh = 0;
+
+ if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
+ if (fd >= max_fh) { /* Renew */
+ LONG delta = 0;
+
+ if (DosSetRelMaxFH(&delta, &max_fh)) /* Assume it OK??? */
+ return 1;
+ }
+ return fd < max_fh;
+}
+
+/* Kernels up to Oct 2003 trap on (invalid) dup(max_fh); [off-by-one + double fault]. */
+int
+dup2(int from, int to)
+{
+ if (fd_ok(from < to ? to : from))
+ return _dup2(from, to);
+ errno = EBADF;
+ return -1;
+}
+
+int
+dup(int from)
+{
+ if (fd_ok(from))
+ return _dup(from);
+ errno = EBADF;
+ return -1;
+}
+
+#undef tmpnam
+#undef tmpfile
+
+char *
+my_tmpnam (char *str)
+{
+ char *p = getenv("TMP"), *tpath;
+
+ if (!p) p = getenv("TEMP");
+ tpath = tempnam(p, "pltmp");
+ if (str && tpath) {
+ strcpy(str, tpath);
+ return str;
+ }
+ return tpath;
+}
+
+FILE *
+my_tmpfile ()
+{
+ struct stat s;