X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=os2%2Fos2.c;h=fcf1bfdef0b009a43fb0b929b82e3e9f762988ef;hb=2541781061ff0c7313c98fd8a3f90c3c73f6e201;hp=a2b196e3eb261fcf5a29f8a7874cb2764f0603e6;hpb=5a9d00411dea1511aa16f9e2a0a94ac23d679e78;p=p5sagit%2Fp5-mst-13.2.git diff --git a/os2/os2.c b/os2/os2.c index a2b196e..fcf1bfd 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -21,13 +21,15 @@ #include #include #include +#include +#include #define PERLIO_NOT_STDIO 0 #include "EXTERN.h" #include "perl.h" -#ifdef USE_THREADS +#ifdef USE_5005THREADS typedef void (*emx_startroutine)(void *); typedef void* (*pthreads_startroutine)(void *); @@ -182,86 +184,218 @@ os2_cond_wait(perl_cond *c, perl_mutex *m) } #endif +static int exe_is_aout(void); + /*****************************************************************************/ /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */ -static PFN ExtFCN[2]; /* Labeled by ord below. */ -static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */ -#define ORD_QUERY_ELP 0 -#define ORD_SET_ELP 1 +#define C_ARR_LEN(sym) (sizeof(sym)/sizeof(*sym)) + +struct dll_handle { + const char *modname; + HMODULE handle; +}; +static struct dll_handle doscalls_handle = {"doscalls", 0}; +static struct dll_handle tcp_handle = {"tcp32dll", 0}; +static struct dll_handle pmwin_handle = {"pmwin", 0}; +static struct dll_handle rexx_handle = {"rexx", 0}; +static struct dll_handle rexxapi_handle = {"rexxapi", 0}; +static struct dll_handle sesmgr_handle = {"sesmgr", 0}; +static struct dll_handle pmshapi_handle = {"pmshapi", 0}; + +/* This should match enum entries_ordinals defined in os2ish.h. */ +static const struct { + struct dll_handle *dll; + const char *entryname; + int entrypoint; +} loadOrdinals[ORD_NENTRIES] = { + {&doscalls_handle, NULL, 874}, /* DosQueryExtLibpath */ + {&doscalls_handle, NULL, 873}, /* DosSetExtLibpath */ + {&doscalls_handle, NULL, 460}, /* DosVerifyPidTid */ + {&tcp_handle, "SETHOSTENT", 0}, + {&tcp_handle, "SETNETENT" , 0}, + {&tcp_handle, "SETPROTOENT", 0}, + {&tcp_handle, "SETSERVENT", 0}, + {&tcp_handle, "GETHOSTENT", 0}, + {&tcp_handle, "GETNETENT" , 0}, + {&tcp_handle, "GETPROTOENT", 0}, + {&tcp_handle, "GETSERVENT", 0}, + {&tcp_handle, "ENDHOSTENT", 0}, + {&tcp_handle, "ENDNETENT", 0}, + {&tcp_handle, "ENDPROTOENT", 0}, + {&tcp_handle, "ENDSERVENT", 0}, + {&pmwin_handle, NULL, 763}, /* WinInitialize */ + {&pmwin_handle, NULL, 716}, /* WinCreateMsgQueue */ + {&pmwin_handle, NULL, 726}, /* WinDestroyMsgQueue */ + {&pmwin_handle, NULL, 918}, /* WinPeekMsg */ + {&pmwin_handle, NULL, 915}, /* WinGetMsg */ + {&pmwin_handle, NULL, 912}, /* WinDispatchMsg */ + {&pmwin_handle, NULL, 753}, /* WinGetLastError */ + {&pmwin_handle, NULL, 705}, /* WinCancelShutdown */ + /* These are needed in extensions. + How to protect PMSHAPI: it comes through EMX functions? */ + {&rexx_handle, "RexxStart", 0}, + {&rexx_handle, "RexxVariablePool", 0}, + {&rexxapi_handle, "RexxRegisterFunctionExe", 0}, + {&rexxapi_handle, "RexxDeregisterFunction", 0}, + {&sesmgr_handle, "DOSSMSETTITLE", 0}, /* Would not work runtime-loaded */ + {&pmshapi_handle, "PRF32QUERYPROFILESIZE", 0}, + {&pmshapi_handle, "PRF32OPENPROFILE", 0}, + {&pmshapi_handle, "PRF32CLOSEPROFILE", 0}, + {&pmshapi_handle, "PRF32QUERYPROFILE", 0}, + {&pmshapi_handle, "PRF32RESET", 0}, + {&pmshapi_handle, "PRF32QUERYPROFILEDATA", 0}, + {&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0}, + + /* At least some of these do not work by name, since they need + WIN32 instead of WIN... */ +#if 0 + These were generated with + nm I:\emx\lib\os2.a | fgrep -f API-list | grep = > API-list-entries + perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( ORD_$1,)" API-list-entries > API-list-ORD_ + perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( {${2}_handle, NULL, $3},\t\t/* $1 */)" WinSwitch-API-list-entries >API-list-entry +#endif + {&pmshapi_handle, NULL, 123}, /* WinChangeSwitchEntry */ + {&pmshapi_handle, NULL, 124}, /* WinQuerySwitchEntry */ + {&pmshapi_handle, NULL, 125}, /* WinQuerySwitchHandle */ + {&pmshapi_handle, NULL, 126}, /* WinQuerySwitchList */ + {&pmshapi_handle, NULL, 131}, /* WinSwitchToProgram */ + {&pmwin_handle, NULL, 702}, /* WinBeginEnumWindows */ + {&pmwin_handle, NULL, 737}, /* WinEndEnumWindows */ + {&pmwin_handle, NULL, 740}, /* WinEnumDlgItem */ + {&pmwin_handle, NULL, 756}, /* WinGetNextWindow */ + {&pmwin_handle, NULL, 768}, /* WinIsChild */ + {&pmwin_handle, NULL, 799}, /* WinQueryActiveWindow */ + {&pmwin_handle, NULL, 805}, /* WinQueryClassName */ + {&pmwin_handle, NULL, 817}, /* WinQueryFocus */ + {&pmwin_handle, NULL, 834}, /* WinQueryWindow */ + {&pmwin_handle, NULL, 837}, /* WinQueryWindowPos */ + {&pmwin_handle, NULL, 838}, /* WinQueryWindowProcess */ + {&pmwin_handle, NULL, 841}, /* WinQueryWindowText */ + {&pmwin_handle, NULL, 842}, /* WinQueryWindowTextLength */ + {&pmwin_handle, NULL, 860}, /* WinSetFocus */ + {&pmwin_handle, NULL, 875}, /* WinSetWindowPos */ + {&pmwin_handle, NULL, 877}, /* WinSetWindowText */ + {&pmwin_handle, NULL, 883}, /* WinShowWindow */ + {&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_*. */ +const Perl_PFN * const pExtFCN = ExtFCN; struct PMWIN_entries_t PMWIN_entries; HMODULE -loadModule(char *modname) +loadModule(const char *modname, int fail) { HMODULE h = (HMODULE)dlopen(modname, 0); - if (!h) + + if (!h && fail) Perl_croak_nocontext("Error loading module '%s': %s", modname, dlerror()); return h; } -APIRET -loadByOrd(char *modname, ULONG ord) +PFN +loadByOrdinal(enum entries_ordinals ord, int fail) { if (ExtFCN[ord] == NULL) { - static HMODULE hdosc = 0; PFN fcn = (PFN)-1; APIRET rc; - if (!hdosc) - hdosc = loadModule(modname); - if (CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn))) + if (!loadOrdinals[ord].dll->handle) + loadOrdinals[ord].dll->handle + = loadModule(loadOrdinals[ord].dll->modname, fail); + if (!loadOrdinals[ord].dll->handle) + return 0; /* Possible with FAIL==0 only */ + if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle, + loadOrdinals[ord].entrypoint, + loadOrdinals[ord].entryname,&fcn))) { + char buf[20], *s = (char*)loadOrdinals[ord].entryname; + + if (!fail) + return 0; + if (!s) + sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint); Perl_croak_nocontext( - "This version of OS/2 does not support %s.%i", - modname, loadOrd[ord]); + "This version of OS/2 does not support %s.%s", + loadOrdinals[ord].dll->modname, s); + } ExtFCN[ord] = fcn; } - if ((long)ExtFCN[ord] == -1) + if ((long)ExtFCN[ord] == -1) Perl_croak_nocontext("panic queryaddr"); + return ExtFCN[ord]; } void init_PMWIN_entries(void) { - static HMODULE hpmwin = 0; - static const int ords[] = { - 763, /* Initialize */ - 716, /* CreateMsgQueue */ - 726, /* DestroyMsgQueue */ - 918, /* PeekMsg */ - 915, /* GetMsg */ - 912, /* DispatchMsg */ - 753, /* GetLastError */ - 705, /* CancelShutdown */ - }; - BYTE buf[20]; - int i = 0; - unsigned long rc; - - if (hpmwin) - return; + int i; - 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]); - i++; - } + for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++) + ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1); } +/*****************************************************/ +/* socket forwarders without linking with tcpip DLLs */ + +DeclFuncByORD(struct hostent *, gethostent, ORD_GETHOSTENT, (void), ()) +DeclFuncByORD(struct netent *, getnetent, ORD_GETNETENT, (void), ()) +DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ()) +DeclFuncByORD(struct servent *, getservent, ORD_GETSERVENT, (void), ()) + +DeclVoidFuncByORD(sethostent, ORD_SETHOSTENT, (int x), (x)) +DeclVoidFuncByORD(setnetent, ORD_SETNETENT, (int x), (x)) +DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x)) +DeclVoidFuncByORD(setservent, ORD_SETSERVENT, (int x), (x)) + +DeclVoidFuncByORD(endhostent, ORD_ENDHOSTENT, (void), ()) +DeclVoidFuncByORD(endnetent, ORD_ENDNETENT, (void), ()) +DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ()) +DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ()) /* priorities */ static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, self inverse. */ #define QSS_INI_BUFFER 1024 +ULONG (*pDosVerifyPidTid) (PID pid, TID tid); +static int pidtid_lookup; + PQTOPLEVEL get_sysinfo(ULONG pid, ULONG flags) { char *pbuffer; ULONG rc, buf_len = QSS_INI_BUFFER; + PQTOPLEVEL psi; + if (!pidtid_lookup) { + pidtid_lookup = 1; + *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0); + } + if (pDosVerifyPidTid) { /* Warp3 or later */ + /* Up to some fixpak QuerySysState() kills the system if a non-existent + pid is used. */ + if (CheckOSError(pDosVerifyPidTid(pid, 1))) + return 0; + } New(1322, pbuffer, buf_len, char); /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */ rc = QuerySysState(flags, pid, pbuffer, buf_len); @@ -274,7 +408,12 @@ get_sysinfo(ULONG pid, ULONG flags) Safefree(pbuffer); return 0; } - return (PQTOPLEVEL)pbuffer; + psi = (PQTOPLEVEL)pbuffer; + if (psi && pid && pid != psi->procdata->pid) { + Safefree(psi); + Perl_croak_nocontext("panic: wrong pid in sysinfo"); + } + return psi; } #define PRIO_ERR 0x1111 @@ -285,14 +424,11 @@ sys_prio(pid) ULONG prio; PQTOPLEVEL psi; + if (!pid) + return PRIO_ERR; psi = get_sysinfo(pid, QSS_PROCESS); - if (!psi) { + if (!psi) return PRIO_ERR; - } - if (pid != psi->procdata->pid) { - Safefree(psi); - Perl_croak_nocontext("panic: wrong pid in sysinfo"); - } prio = psi->procdata->threads->priority; Safefree(psi); return prio; @@ -301,10 +437,7 @@ sys_prio(pid) int setpriority(int which, int pid, int val) { - ULONG rc, prio; - PQTOPLEVEL psi; - - prio = sys_prio(pid); + ULONG rc, prio = sys_prio(pid); if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) { @@ -333,37 +466,27 @@ setpriority(int which, int pid, int val) abs(pid))) ? -1 : 0; } -/* else return CheckOSError(DosSetPriority((pid < 0) */ -/* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */ -/* priors[(32 - val) >> 5] + 1, */ -/* (32 - val) % 32 - (prio & 0xFF), */ -/* abs(pid))) */ -/* ? -1 : 0; */ } int getpriority(int which /* ignored */, int pid) { - TIB *tib; - PIB *pib; - ULONG rc, ret; + ULONG ret; if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ - /* DosGetInfoBlocks has old priority! */ -/* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */ -/* if (pid != pib->pib_ulpid) { */ ret = sys_prio(pid); if (ret == PRIO_ERR) { return -1; } -/* } else */ -/* ret = tib->tib_ptib2->tib2_ulpri; */ return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF); } /*****************************************************************************/ /* spawn */ +int emx_runtime_init; /* If 1, we need to manually init it */ +int emx_exception_init; /* If 1, we need to manually set it */ + /* There is no big sense to make it thread-specific, since signals are delivered to thread 1 only. XXXX Maybe make it into an array? */ static int spawn_pid; @@ -426,11 +549,14 @@ result(pTHX_ int flag, int pid) #endif } -#define EXECF_SPAWN 0 -#define EXECF_EXEC 1 -#define EXECF_TRUEEXEC 2 -#define EXECF_SPAWN_NOWAIT 3 -#define EXECF_SPAWN_BYFLAG 4 +enum execf_t { + EXECF_SPAWN, + EXECF_EXEC, + EXECF_TRUEEXEC, + EXECF_SPAWN_NOWAIT, + EXECF_SPAWN_BYFLAG, + EXECF_SYNC +}; /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */ @@ -477,21 +603,28 @@ static ULONG os2_mytype; /* Spawn/exec a program, revert to shell if needed. */ /* global PL_Argv[] contains arguments. */ +extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *, + EXCEPTIONREGISTRATIONRECORD *, + CONTEXTRECORD *, + void *); + int do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) { int trueflag = flag; int rc, pass = 1; char *tmps; - char buf[256], *s = 0, scrbuf[280]; char *args[4]; static char * fargs[4] = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", }; char **argsp = fargs; - char nargs = 4; + int nargs = 4; int force_shell; - int new_stderr = -1, nostderr = 0, fl_stderr; + int new_stderr = -1, nostderr = 0; + int fl_stderr = 0; STRLEN n_a; + char *buf; + PerlIO *file; if (flag == P_WAIT) flag = P_NOWAIT; @@ -500,14 +633,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; @@ -549,7 +682,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); } } @@ -560,7 +693,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); } } @@ -568,6 +701,8 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) case FAPPTYP_NOTSPEC: /* Let the shell handle this... */ force_shell = 1; + buf = ""; /* Pacify a warning */ + file = 0; /* Pacify a warning */ goto doshell_args; break; } @@ -600,6 +735,8 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv); else if (execf == EXECF_SPAWN_NOWAIT) rc = spawnvp(flag,tmps,PL_Argv); + else if (execf == EXECF_SYNC) + rc = spawnvp(trueflag,tmps,PL_Argv); else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */ rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv)); @@ -617,59 +754,45 @@ 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) { - PerlIO *file; - SSize_t rd; - char *s = 0, *s1, *s2; - int l; + char *s = 0, *s1; + SV *scrsv = sv_2mortal(newSVpv(scr, 0)); + SV *bufsv = sv_newmortal(); - l = strlen(scr); - - if (l >= sizeof scrbuf) { - Safefree(scr); - longbuf: - Perl_warner(aTHX_ WARN_EXEC, "Size of scriptname too big: %d", l); - rc = -1; - goto finish; - } - strcpy(scrbuf, scr); Safefree(scr); - scr = scrbuf; + scr = SvPV(scrsv, n_a); /* free()ed later */ file = PerlIO_open(scr, "r"); PL_Argv[0] = scr; if (!file) goto panic_file; - 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; + buf = sv_gets(bufsv, file, 0 /* No append */); + if (!buf) + buf = ""; /* XXX Needed? */ + if (!buf[0]) { /* Empty... */ PerlIO_close(file); /* Special case: maybe from -Zexe build, so there is an executable around (contrary to documentation, DosQueryAppType sometimes (?) does not append ".exe", so we could have reached this place). */ - if (l + 5 < sizeof scrbuf) { - strcpy(scrbuf + l, ".exe"); - if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0 - && !S_ISDIR(PL_statbuf.st_mode)) { - /* Found */ + sv_catpv(scrsv, ".exe"); + scr = SvPV(scrsv, n_a); /* Reload */ + if (PerlLIO_stat(scr,&PL_statbuf) >= 0 + && !S_ISDIR(PL_statbuf.st_mode)) { /* Found */ tmps = scr; pass++; goto reread; - } else - scrbuf[l] = 0; - } else - goto longbuf; + } else { /* Restore */ + SvCUR_set(scrsv, SvCUR(scrsv) - 4); + *SvEND(scrsv) = 0; + } } 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[0] = 0; /* Not #! */ + buf = ""; /* Not #! */ goto doshell_args; } if (buf[0] == '#') { @@ -685,7 +808,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) s = buf + 8; } if (!s) { - buf[0] = 0; /* Not #! */ + buf = ""; /* Not #! */ goto doshell_args; } @@ -711,11 +834,12 @@ 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; } + /* Can jump from far, buf/file invalid if force_shell: */ doshell_args: { char **a = PL_Argv; @@ -737,7 +861,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) if (inicmd) { /* No spaces at start! */ s = inicmd; while (*s && !isSPACE(*s)) { - if (*s++ = '/') { + if (*s++ == '/') { inicmd = NULL; /* Cannot use */ break; } @@ -813,7 +937,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)); @@ -837,10 +961,8 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) { register char **a; register char *s; - char flags[10]; char *shell, *copt, *news = NULL; - int rc, err, seenspace = 0, mergestderr = 0; - char fullcmd[MAXNAMLEN + 1]; + int rc, seenspace = 0, mergestderr = 0; #ifdef TRYSHELL if ((shell = getenv("EMXSHELL")) != NULL) @@ -909,7 +1031,7 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) should be smart enough to start itself gloriously. */ doshell: if (execf == EXECF_TRUEEXEC) - rc = execl(shell,shell,copt,cmd,(char*)0); + rc = execl(shell,shell,copt,cmd,(char*)0); else if (execf == EXECF_EXEC) rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0); else if (execf == EXECF_SPAWN_NOWAIT) @@ -918,10 +1040,13 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) rc = spawnl(flag,shell,shell,copt,cmd,(char*)0); else { /* In the ak code internal P_NOWAIT is P_WAIT ??? */ - rc = result(aTHX_ P_WAIT, - spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); + if (execf == EXECF_SYNC) + rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0); + else + 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) @@ -960,8 +1085,10 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) /* Array spawn. */ int -os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp) +os2_do_aspawn(pTHX_ SV *really, register void **vmark, register void **vsp) { + register SV **mark = (SV **)vmark; + register SV **sp = (SV **)vsp; register char **a; int rc; int flag = P_WAIT, flag_set = 0; @@ -1025,13 +1152,11 @@ PerlIO * my_syspopen(pTHX_ char *cmd, char *mode) { #ifndef USE_POPEN - int p[2]; register I32 this, that, newfd; - register I32 pid, rc; - PerlIO *res; + register I32 pid; SV *sv; - int fh_fl; + int fh_fl = 0; /* Pacify the warning */ /* `this' is what we use in the parent, `that' in the child. */ this = (*mode == 'w'); @@ -1142,51 +1267,6 @@ char * ctermid(char *s) { return 0; } void * ttyname(x) { return 0; } #endif -/******************************************************************/ -/* my socket forwarders - EMX lib only provides static forwarders */ - -static HMODULE htcp = 0; - -static void * -tcp0(char *name) -{ - PFN fcn; - - if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */ - if (!htcp) - htcp = loadModule("tcp32dll"); - if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) - return (void *) ((void * (*)(void)) fcn) (); - return 0; -} - -static void -tcp1(char *name, int arg) -{ - 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); - if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) - ((void (*)(int)) fcn) (arg); -} - -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); } -void setservent(x) { tcp1("SETSERVENT", x); } -void endhostent() { tcp0("ENDHOSTENT"); } -void endnetent() { tcp0("ENDNETENT"); } -void endprotoent() { tcp0("ENDPROTOENT"); } -void endservent() { tcp0("ENDSERVENT"); } - /*****************************************************************************/ /* not implemented in C Set++ */ @@ -1204,7 +1284,7 @@ int setgid(x) { errno = EINVAL; return -1; } used with 5.001. Now just look for /dev/. */ int -os2_stat(char *name, struct stat *st) +os2_stat(const char *name, struct stat *st) { static int ino = SHRT_MAX; @@ -1288,7 +1368,9 @@ XS(XS_File__Copy_syscopy) XSRETURN(1); } +#define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */ #include "patchlevel.h" +#undef PERL_PATCHLEVEL_H_IMPLICIT char * mod2fname(pTHX_ SV *sv) @@ -1296,8 +1378,6 @@ mod2fname(pTHX_ SV *sv) static char fname[9]; int pos = 6, len, avlen; unsigned int sum = 0; - AV *av; - SV *svp; char *s; STRLEN n_a; @@ -1326,7 +1406,7 @@ mod2fname(pTHX_ SV *sv) } avlen --; } -#ifdef USE_THREADS +#ifdef USE_5005THREADS sum++; /* Avoid conflict of DLLs in memory. */ #endif /* We always load modules as *specific* DLLs, and with the full name. @@ -1368,24 +1448,54 @@ os2error(int rc) { static char buf[300]; ULONG len; + char *s; + int number = SvTRUE(get_sv("OS2::nsyserror", TRUE)); if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */ if (rc == 0) - return NULL; - if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len)) - sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc); - else { - buf[len] = '\0'; - if (len && buf[len - 1] == '\n') - buf[--len] = 0; - if (len && buf[len - 1] == '\r') - buf[--len] = 0; - if (len && buf[len - 1] == '.') - buf[--len] = 0; + return ""; + if (number) { + sprintf(buf, "SYS%04d=%#x: ", rc, rc); + s = buf + strlen(buf); + } else + s = buf; + if (DosGetMessage(NULL, 0, s, sizeof(buf) - 1 - (s-buf), + rc, "OSO001.MSG", &len)) { + if (!number) { + sprintf(buf, "SYS%04d=%#x: ", rc, rc); + s = buf + strlen(buf); + } + sprintf(s, "[No description found in OSO001.MSG]"); + } else { + s[len] = '\0'; + if (len && s[len - 1] == '\n') + s[--len] = 0; + if (len && s[len - 1] == '\r') + s[--len] = 0; + if (len && s[len - 1] == '.') + s[--len] = 0; + if (len >= 10 && number && strnEQ(s, buf, 7) + && s[7] == ':' && s[8] == ' ') + /* Some messages start with SYSdddd:, some not */ + Move(s + 9, s, (len -= 9) + 1, char); } return buf; } +void +ResetWinError(void) +{ + WinError_2_Perl_rc; +} + +void +CroakWinError(int die, char *name) +{ + FillWinError; + if (die && Perl_rc) + croak("%s: %s", (name ? name : "Win* API call"), os2error(Perl_rc)); +} + char * os2_execname(pTHX) { @@ -1480,8 +1590,9 @@ Perl_Register_MQ(int serve) PPIB pib; PTIB tib; - if (Perl_os2_initial_mode++) + if (Perl_hmq_refcnt > 0) 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. */ @@ -1769,8 +1880,8 @@ XS(XS_OS2_Process_Messages) if (items == 2) { I32 cntr; SV *sv = ST(1); - int fake = SvIV(sv); /* Force SvIVX */ - + + (void)SvIV(sv); /* Force SvIVX */ if (!SvIOK(sv)) Perl_croak_nocontext("Can't upgrade count to IV"); cntr = SvIVX(sv); @@ -1896,6 +2007,9 @@ XS(XS_Cwd_sys_cwd) RETVAL = _getcwd2(p, MAXPATHLEN); ST(0) = sv_newmortal(); sv_setpv((SV*)ST(0), RETVAL); +#ifndef INCOMPLETE_TAINTS + SvTAINTED_on(ST(0)); +#endif } XSRETURN(1); } @@ -1908,9 +2022,11 @@ XS(XS_Cwd_sys_abspath) { STRLEN n_a; char * path = (char *)SvPV(ST(0),n_a); - char * dir; + char * dir, *s, *t, *e; char p[MAXPATHLEN]; char * RETVAL; + int l; + SV *sv; if (items < 2) dir = NULL; @@ -1963,8 +2079,6 @@ XS(XS_Cwd_sys_abspath) In all the cases it is safe to drop the drive part of the path. */ if ( !sys_is_relative(path) ) { - int is_drived; - if ( ( ( sys_is_absolute(dir) || (isALPHA(dir[0]) && dir[1] == ':' && strnicmp(dir, path,1) == 0)) @@ -2002,8 +2116,31 @@ XS(XS_Cwd_sys_abspath) done: } } + if (!RETVAL) + XSRETURN_EMPTY; + /* Backslashes are already converted to slashes. */ + /* Remove trailing slashes */ + l = strlen(RETVAL); + while (l > 0 && RETVAL[l-1] == '/') + l--; ST(0) = sv_newmortal(); - sv_setpv((SV*)ST(0), RETVAL); + sv_setpvn( sv = (SV*)ST(0), RETVAL, l); + /* Remove duplicate slashes, skipping the first three, which + may be parts of a server-based path */ + s = t = 3 + SvPV_force(sv, n_a); + e = SvEND(sv); + /* Do not worry about multibyte chars here, this would contradict the + eventual UTFization, and currently most other places break too... */ + while (s < e) { + if (s[0] == t[-1] && s[0] == '/') + s++; /* Skip duplicate / */ + else + *t++ = *s++; + } + if (t < e) { + *t = 0; + SvCUR_set(sv, t - SvPVX(sv)); + } } XSRETURN(1); } @@ -2018,22 +2155,22 @@ APIRET ExtLIBPATH(ULONG ord, PSZ path, IV type) { ULONG what; + PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */ - loadByOrd("doscalls",ord); /* Guarantied to load or die! */ if (type > 0) what = END_LIBPATH; else if (type == 0) what = BEGIN_LIBPATH; else what = LIBPATHSTRICT; - return (*(PELP)ExtFCN[ord])(path, what); + return (*(PELP)f)(path, what); } #define extLibpath(to,type) \ - (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, (to), (type))) ? NULL : (to) ) + (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) ) #define extLibpath_set(p,type) \ - (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), (type)))) + (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type)))) XS(XS_Cwd_extLibpath) { @@ -2087,6 +2224,78 @@ 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) +{ + 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))) + croak("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 @@ -2184,11 +2393,15 @@ 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 sv_setiv(GvSV(gv), 1); -#endif +#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); @@ -2200,23 +2413,334 @@ Xs_OS2_init(pTHX) 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; } OS2_Perl_data_t OS2_Perl_data; +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 *p = 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" (p) ); +} + +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 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" (res) ); + + return 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; + static ULONG os2_dll; + 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; + 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; + + /* 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); +} + +jmp_buf at_exit_buf; +int longjmp_at_exit; + +static void +jmp_out_of_atexit(void) +{ + if (longjmp_at_exit) + longjmp(at_exit_buf, 1); +} + +extern void _CRT_term(void); + +int emx_runtime_secondary; + +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 + +extern ULONG __os_version(); /* See system.doc */ + +static int emx_wasnt_initialized; + +void +check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg) +{ + ULONG v_crt, v_emx; + + /* 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 */ + + /* 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; + } + New(1307, 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; +} + +#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; + _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY); MALLOC_INIT; + + check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg); + settmppath(); OS2_Perl_data.xs_init = &Xs_OS2_init; - _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY); - if (environ == NULL && env) { - environ = env; - } if ( (shell = getenv("PERL_SH_DRIVE")) ) { New(1304, PL_sh_path, strlen(SH_PATH) + 1, char); strcpy(PL_sh_path, SH_PATH); @@ -2246,7 +2770,6 @@ char * my_tmpnam (char *str) { char *p = getenv("TMP"), *tpath; - int len; if (!p) p = getenv("TEMP"); tpath = tempnam(p, "pltmp"); @@ -2324,21 +2847,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) { @@ -2352,7 +2875,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: @@ -2366,9 +2889,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( @@ -2406,7 +2929,7 @@ my_flock(int handle, int o) errno = EINVAL; return -1; } - // give away timeslice + /* give away timeslice */ DosSleep(1); } } @@ -2414,3 +2937,114 @@ my_flock(int handle, int o) errno = 0; return 0; } + +static int pwent_cnt; +static int _my_pwent = -1; + +static int +use_my_pwent(void) +{ + if (_my_pwent == -1) { + char *s = getenv("USE_PERL_PWENT"); + if (s) + _my_pwent = atoi(s); + else + _my_pwent = 1; + } + return _my_pwent; +} + +#undef setpwent +#undef getpwent +#undef endpwent + +void +my_setpwent(void) +{ + if (!use_my_pwent()) { + setpwent(); /* Delegate to EMX. */ + return; + } + pwent_cnt = 0; +} + +void +my_endpwent(void) +{ + if (!use_my_pwent()) { + endpwent(); /* Delegate to EMX. */ + return; + } +} + +struct passwd * +my_getpwent (void) +{ + if (!use_my_pwent()) + return getpwent(); /* Delegate to EMX. */ + if (pwent_cnt++) + return 0; /* Return one entry only */ + return getpwuid(0); +} + +static int grent_cnt; + +void +setgrent(void) +{ + grent_cnt = 0; +} + +void +endgrent(void) +{ +} + +struct group * +getgrent (void) +{ + if (grent_cnt++) + return 0; /* Return one entry only */ + return getgrgid(0); +} + +#undef getpwuid +#undef getpwnam + +/* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */ +static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK"; + +static struct passwd * +passw_wrap(struct passwd *p) +{ + static struct passwd pw; + char *s; + + if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */ + return p; + pw = *p; + s = getenv("PW_PASSWD"); + if (!s) + s = (char*)pw_p; /* Make match impossible */ + + pw.pw_passwd = s; + return &pw; +} + +struct passwd * +my_getpwuid (uid_t id) +{ + return passw_wrap(getpwuid(id)); +} + +struct passwd * +my_getpwnam (__const__ char *n) +{ + return passw_wrap(getpwnam(n)); +} + +char * +gcvt_os2 (double value, int digits, char *buffer) +{ + return gcvt (value, digits, buffer); +}