diff options
Diffstat (limited to 'os2/os2.c')
| -rw-r--r-- | os2/os2.c | 186 |
1 files changed, 164 insertions, 22 deletions
@@ -8,6 +8,7 @@ #define SPU_DISABLESUPPRESSION 0 #define SPU_ENABLESUPPRESSION 1 #include <os2.h> +#include "dlfcn.h" #include <sys/uflags.h> @@ -189,6 +190,16 @@ static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */ #define ORD_SET_ELP 1 struct PMWIN_entries_t PMWIN_entries; +HMODULE +loadModule(char *modname) +{ + HMODULE h = (HMODULE)dlopen(modname, 0); + if (!h) + Perl_croak_nocontext("Error loading module '%s': %s", + modname, dlerror()); + return h; +} + APIRET loadByOrd(char *modname, ULONG ord) { @@ -198,11 +209,14 @@ loadByOrd(char *modname, ULONG ord) PFN fcn; APIRET rc; - if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf, - modname, &hdosc))) - || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn))) - Perl_croak_nocontext("This version of OS/2 does not support %s.%i", - modname, loadOrd[ord]); + + if (!hdosc) { + hdosc = loadModule(modname); + if (CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn))) + Perl_croak_nocontext( + "This version of OS/2 does not support %s.%i", + modname, loadOrd[ord]); + } ExtFCN[ord] = fcn; } if ((long)ExtFCN[ord] == -1) @@ -220,6 +234,8 @@ init_PMWIN_entries(void) 918, /* PeekMsg */ 915, /* GetMsg */ 912, /* DispatchMsg */ + 753, /* GetLastError */ + 705, /* CancelShutdown */ }; BYTE buf[20]; int i = 0; @@ -228,9 +244,8 @@ init_PMWIN_entries(void) if (hpmwin) return; - if (CheckOSError(DosLoadModule(buf, sizeof buf, "pmwin", &hpmwin))) - Perl_croak_nocontext("This version of OS/2 does not support pmwin: error in %s", buf); - while (i <= 5) { + hpmwin = loadModule("pmwin"); + while (i < sizeof(ords)/sizeof(int)) { if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL, ((PFN*)&PMWIN_entries)+i))) Perl_croak_nocontext("This version of OS/2 does not support pmwin.%d", ords[i]); @@ -1138,12 +1153,11 @@ static HMODULE htcp = 0; static void * tcp0(char *name) { - static BYTE buf[20]; PFN fcn; 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); + htcp = loadModule("tcp32dll"); if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) return (void *) ((void * (*)(void)) fcn) (); return 0; @@ -1367,15 +1381,30 @@ os2error(int rc) char * os2_execname(pTHX) { - char buf[300], *p; + char buf[300], *p, *o = PL_origargv[0], ok = 1; if (_execname(buf, sizeof buf) != 0) - return PL_origargv[0]; + return o; p = buf; while (*p) { if (*p == '\\') *p = '/'; + if (*p == '/') { + if (ok && *o != '/' && *o != '\\') + ok = 0; + } else if (ok && tolower(*o) != tolower(*p)) + ok = 0; p++; + o++; + } + if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */ + strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */ + p = buf; + while (*p) { + if (*p == '\\') + *p = '/'; + p++; + } } p = savepv(buf); SAVEFREEPV(p); @@ -1447,7 +1476,6 @@ Perl_Register_MQ(int serve) return Perl_hmq; DosGetInfoBlocks(&tib, &pib); Perl_os2_initial_mode = pib->pib_ultype; - Perl_hmq_refcnt = 1; /* Try morphing into a PM application. */ if (pib->pib_ultype != 3) /* 2 is VIO */ pib->pib_ultype = 3; /* 3 is PM */ @@ -1456,10 +1484,20 @@ Perl_Register_MQ(int serve) Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64); if (!Perl_hmq) { static int cnt; + + SAVEINT(cnt); /* Allow catch()ing. */ if (cnt++) _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... */ + (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0); + Perl_hmq_servers++; + } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */ + (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); + Perl_hmq_refcnt++; return Perl_hmq; } @@ -1469,9 +1507,9 @@ Perl_Serve_Messages(int force) int cnt = 0; QMSG msg; - if (Perl_hmq_servers && !force) + if (Perl_hmq_servers > 0 && !force) return 0; - if (!Perl_hmq_refcnt) + if (Perl_hmq_refcnt <= 0) Perl_croak_nocontext("No message queue"); while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) { cnt++; @@ -1487,9 +1525,9 @@ Perl_Process_Messages(int force, I32 *cntp) { QMSG msg; - if (Perl_hmq_servers && !force) + if (Perl_hmq_servers > 0 && !force) return 0; - if (!Perl_hmq_refcnt) + if (Perl_hmq_refcnt <= 0) Perl_croak_nocontext("No message queue"); while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) { if (cntp) @@ -1509,21 +1547,23 @@ Perl_Deregister_MQ(int serve) PPIB pib; PTIB tib; - if (--Perl_hmq_refcnt == 0) { + if (serve) + Perl_hmq_servers--; + if (--Perl_hmq_refcnt <= 0) { + init_PMWIN_entries(); /* To be extra safe */ (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq); Perl_hmq = 0; /* Try morphing back from a PM application. */ + DosGetInfoBlocks(&tib, &pib); if (pib->pib_ultype == 3) /* 3 is PM */ pib->pib_ultype = Perl_os2_initial_mode; else Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM", pib->pib_ultype); - } + } else if (serve && Perl_hmq_servers <= 0) /* Last server exited */ + (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); } -extern void dlopen(); -void *fakedl = &dlopen; /* Pull in dynaloading part. */ - #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \ && ((path)[2] == '/' || (path)[2] == '\\')) #define sys_is_rooted _fnisabs @@ -2026,6 +2066,71 @@ XS(XS_Cwd_extLibpath_set) XSRETURN(1); } +#define get_control87() _control87(0,0) +#define set_control87 _control87 + +XS(XS_OS2__control87) +{ + dXSARGS; + if (items != 2) + croak("Usage: OS2::_control87(new,mask)"); + { + unsigned new = (unsigned)SvIV(ST(0)); + unsigned mask = (unsigned)SvIV(ST(1)); + unsigned RETVAL; + + RETVAL = _control87(new, mask); + ST(0) = sv_newmortal(); + sv_setiv(ST(0), (IV)RETVAL); + } + XSRETURN(1); +} + +XS(XS_OS2_get_control87) +{ + dXSARGS; + if (items != 0) + croak("Usage: OS2::get_control87()"); + { + unsigned RETVAL; + + RETVAL = get_control87(); + ST(0) = sv_newmortal(); + sv_setiv(ST(0), (IV)RETVAL); + } + XSRETURN(1); +} + + +XS(XS_OS2_set_control87) +{ + dXSARGS; + if (items < 0 || items > 2) + croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)"); + { + unsigned new; + unsigned mask; + unsigned RETVAL; + + 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); + ST(0) = sv_newmortal(); + sv_setiv(ST(0), (IV)RETVAL); + } + XSRETURN(1); +} + int Xs_OS2_init(pTHX) { @@ -2055,6 +2160,9 @@ Xs_OS2_init(pTHX) 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); + 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, ";$$"); gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); GvMULTI_on(gv); #ifdef PERL_IS_AOUT @@ -2106,6 +2214,8 @@ Perl_OS2_init(char **env) } MUTEX_INIT(&start_thread_mutex); 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 tmpnam @@ -2139,6 +2249,38 @@ my_tmpfile () grants TMP. */ } +#undef rmdir + +int +my_rmdir (__const__ char *s) +{ + char buf[MAXPATHLEN]; + STRLEN l = strlen(s); + + if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX rmdir fails... */ + strcpy(buf,s); + buf[l - 1] = 0; + s = buf; + } + return rmdir(s); +} + +#undef mkdir + +int +my_mkdir (__const__ char *s, long perm) +{ + char buf[MAXPATHLEN]; + STRLEN l = strlen(s); + + if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */ + strcpy(buf,s); + buf[l - 1] = 0; + s = buf; + } + return mkdir(s, perm); +} + #undef flock /* This code was contributed by Rocco Caputo. */ |