X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=os2%2Fos2.c;h=4ce933d81b4e3bcba4af6b2f09634e504af11c30;hb=3189d65a81e5869a7ba75fe52949ef916f5017e9;hp=45e1d2fb65a9e75e111e93772de671b77bc49c6e;hpb=4b19af017623bfa3bb72bb164598a517f586e0d3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/os2/os2.c b/os2/os2.c index 45e1d2f..4ce933d 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -8,6 +8,7 @@ #define SPU_DISABLESUPPRESSION 0 #define SPU_ENABLESUPPRESSION 1 #include +#include "dlfcn.h" #include @@ -21,6 +22,8 @@ #include #include +#define PERLIO_NOT_STDIO 0 + #include "EXTERN.h" #include "perl.h" @@ -187,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) { @@ -196,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) @@ -218,6 +234,8 @@ init_PMWIN_entries(void) 918, /* PeekMsg */ 915, /* GetMsg */ 912, /* DispatchMsg */ + 753, /* GetLastError */ + 705, /* CancelShutdown */ }; BYTE buf[20]; int i = 0; @@ -226,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]); @@ -375,7 +392,6 @@ spawn_sighandler(int sig) static int 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() */ @@ -467,7 +483,6 @@ static ULONG os2_mytype; int do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) { - dTHR; int trueflag = flag; int rc, pass = 1; char *tmps; @@ -605,8 +620,9 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) char *scr = find_script(PL_Argv[0], TRUE, NULL, 0); if (scr) { - FILE *file; - char *s = 0, *s1; + PerlIO *file; + SSize_t rd; + char *s = 0, *s1, *s2; int l; l = strlen(scr); @@ -622,14 +638,18 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) Safefree(scr); scr = scrbuf; - file = fopen(scr, "r"); + file = PerlIO_open(scr, "r"); PL_Argv[0] = scr; if (!file) goto panic_file; - if (!fgets(buf, sizeof buf, file)) { /* Empty... */ + rd = PerlIO_read(file, buf, sizeof buf-1); + buf[rd]='\0'; + if ((s2 = strchr(buf, '\n')) != NULL) *++s2 = '\0'; + + if (!rd) { /* Empty... */ buf[0] = 0; - fclose(file); + PerlIO_close(file); /* Special case: maybe from -Zexe build, so there is an executable around (contrary to documentation, DosQueryAppType sometimes (?) @@ -648,7 +668,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) } else goto longbuf; } - if (fclose(file) != 0) { /* Failure */ + if (PerlIO_close(file) != 0) { /* Failure */ panic_file: Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s", scr, Strerror(errno)); @@ -818,7 +838,6 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) int do_spawn3(pTHX_ char *cmd, int execf, int flag) { - dTHR; register char **a; register char *s; char flags[10]; @@ -946,7 +965,6 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) int os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp) { - dTHR; register char **a; int rc; int flag = P_WAIT, flag_set = 0; @@ -984,21 +1002,18 @@ os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp) int os2_do_spawn(pTHX_ char *cmd) { - dTHR; return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0); } int do_spawn_nowait(pTHX_ char *cmd) { - dTHR; return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0); } bool Perl_do_exec(pTHX_ char *cmd) { - dTHR; do_spawn3(aTHX_ cmd, EXECF_EXEC, 0); return FALSE; } @@ -1006,7 +1021,6 @@ Perl_do_exec(pTHX_ char *cmd) bool os2exec(pTHX_ char *cmd) { - dTHR; return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0); } @@ -1123,9 +1137,9 @@ fork(void) #endif /*******************************************************************/ -/* not implemented in EMX 0.9a */ +/* not implemented in EMX 0.9d */ -void * ctermid(x) { return 0; } +char * ctermid(char *s) { return 0; } #ifdef MYTTYNAME /* was not in emx0.9a */ void * ttyname(x) { return 0; } @@ -1139,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; @@ -1163,10 +1176,11 @@ tcp1(char *name, int arg) ((void (*)(int)) fcn) (arg); } -void * gethostent() { return tcp0("GETHOSTENT"); } -void * getnetent() { return tcp0("GETNETENT"); } -void * getprotoent() { return tcp0("GETPROTOENT"); } -void * getservent() { return tcp0("GETSERVENT"); } +struct hostent * gethostent() { return tcp0("GETHOSTENT"); } +struct netent * getnetent() { return tcp0("GETNETENT"); } +struct protoent * getprotoent() { return tcp0("GETPROTOENT"); } +struct servent * getservent() { return tcp0("GETSERVENT"); } + void sethostent(x) { tcp1("SETHOSTENT", x); } void setnetent(x) { tcp1("SETNETENT", x); } void setprotoent(x) { tcp1("SETPROTOENT", x); } @@ -1367,16 +1381,30 @@ os2error(int rc) char * os2_execname(pTHX) { - dTHR; - 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); @@ -1448,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 */ @@ -1457,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; } @@ -1470,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++; @@ -1488,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) @@ -1510,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 @@ -1718,17 +1757,20 @@ XS(XS_OS2_Process_Messages) { bool force = SvOK(ST(0)); unsigned long cnt; - I32 *cntp = NULL; if (items == 2) { + I32 cntr; SV *sv = ST(1); int fake = SvIV(sv); /* Force SvIVX */ if (!SvIOK(sv)) Perl_croak_nocontext("Can't upgrade count to IV"); - cntp = &SvIVX(sv); - } - cnt = Perl_Process_Messages(force, cntp); + cntr = SvIVX(sv); + cnt = Perl_Process_Messages(force, &cntr); + SvIVX(sv) = cntr; + } else { + cnt = Perl_Process_Messages(force, NULL); + } ST(0) = sv_newmortal(); sv_setiv(ST(0), cnt); } @@ -2024,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) { @@ -2053,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 @@ -2104,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 @@ -2137,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. */