#include <limits.h>
#include <process.h>
#include <fcntl.h>
+#include <pwd.h>
+#include <grp.h>
#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 *);
}
#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);
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
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;
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)) {
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;
#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" }; */
/* 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;
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;
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);
}
}
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);
}
}
case FAPPTYP_NOTSPEC:
/* Let the shell handle this... */
force_shell = 1;
+ buf = ""; /* Pacify a warning */
+ file = 0; /* Pacify a warning */
goto doshell_args;
break;
}
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));
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] == '#') {
s = buf + 8;
}
if (!s) {
- buf[0] = 0; /* Not #! */
+ buf = ""; /* Not #! */
goto doshell_args;
}
*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;
if (inicmd) { /* No spaces at start! */
s = inicmd;
while (*s && !isSPACE(*s)) {
- if (*s++ = '/') {
+ if (*s++ == '/') {
inicmd = NULL; /* Cannot use */
break;
}
}
}
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));
{
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)
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)
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)
/* 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;
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');
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++ */
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;
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)
static char fname[9];
int pos = 6, len, avlen;
unsigned int sum = 0;
- AV *av;
- SV *svp;
char *s;
STRLEN n_a;
}
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.
{
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)
{
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. */
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);
RETVAL = _getcwd2(p, MAXPATHLEN);
ST(0) = sv_newmortal();
sv_setpv((SV*)ST(0), RETVAL);
+#ifndef INCOMPLETE_TAINTS
+ SvTAINTED_on(ST(0));
+#endif
}
XSRETURN(1);
}
{
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;
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))
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);
}
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)
{
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
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);
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 <emx/startup.h>
+
+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);
my_tmpnam (char *str)
{
char *p = getenv("TMP"), *tpath;
- int len;
if (!p) p = getenv("TEMP");
tpath = tempnam(p, "pltmp");
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) {
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:
return -1;
}
}
- // lock may block
+ /* lock may block */
if (o & (LOCK_SH | LOCK_EX)) {
- // for blocking operations
+ /* for blocking operations */
for (;;) {
rc =
DosSetFileLocks(
errno = EINVAL;
return -1;
}
- // give away timeslice
+ /* give away timeslice */
DosSleep(1);
}
}
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);
+}
projects / p5sagit/p5-mst-13.2.git / blobdiff