#define INCL_DOSFILEMGR
#define INCL_DOSMEMMGR
#define INCL_DOSERRORS
+/* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */
+#define INCL_DOSPROCESS
+#define SPU_DISABLESUPPRESSION 0
+#define SPU_ENABLESUPPRESSION 1
#include <os2.h>
+#include "dlfcn.h"
+
+#include <sys/uflags.h>
/*
* Various Unix compatibility functions for OS/2
#include <errno.h>
#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_5005THREADS
+
+typedef void (*emx_startroutine)(void *);
+typedef void* (*pthreads_startroutine)(void *);
+
+enum pthreads_state {
+ pthreads_st_none = 0,
+ pthreads_st_run,
+ pthreads_st_exited,
+ pthreads_st_detached,
+ pthreads_st_waited,
+};
+const char *pthreads_states[] = {
+ "uninit",
+ "running",
+ "exited",
+ "detached",
+ "waited for",
+};
+
+typedef struct {
+ void *status;
+ perl_cond cond;
+ enum pthreads_state state;
+} thread_join_t;
+
+thread_join_t *thread_join_data;
+int thread_join_count;
+perl_mutex start_thread_mutex;
+
+int
+pthread_join(perl_os_thread tid, void **status)
+{
+ MUTEX_LOCK(&start_thread_mutex);
+ switch (thread_join_data[tid].state) {
+ case pthreads_st_exited:
+ thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
+ MUTEX_UNLOCK(&start_thread_mutex);
+ *status = thread_join_data[tid].status;
+ break;
+ case pthreads_st_waited:
+ MUTEX_UNLOCK(&start_thread_mutex);
+ Perl_croak_nocontext("join with a thread with a waiter");
+ break;
+ case pthreads_st_run:
+ thread_join_data[tid].state = pthreads_st_waited;
+ COND_INIT(&thread_join_data[tid].cond);
+ MUTEX_UNLOCK(&start_thread_mutex);
+ COND_WAIT(&thread_join_data[tid].cond, NULL);
+ COND_DESTROY(&thread_join_data[tid].cond);
+ thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
+ *status = thread_join_data[tid].status;
+ break;
+ default:
+ MUTEX_UNLOCK(&start_thread_mutex);
+ Perl_croak_nocontext("join: unknown thread state: '%s'",
+ pthreads_states[thread_join_data[tid].state]);
+ break;
+ }
+ return 0;
+}
+
+void
+pthread_startit(void *arg)
+{
+ /* Thread is already started, we need to transfer control only */
+ pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
+ int tid = pthread_self();
+ void *retval;
+
+ arg = ((void**)arg)[1];
+ if (tid >= thread_join_count) {
+ int oc = thread_join_count;
+
+ thread_join_count = tid + 5 + tid/5;
+ if (thread_join_data) {
+ Renew(thread_join_data, thread_join_count, thread_join_t);
+ Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
+ } else {
+ Newz(1323, thread_join_data, thread_join_count, thread_join_t);
+ }
+ }
+ if (thread_join_data[tid].state != pthreads_st_none)
+ Perl_croak_nocontext("attempt to reuse thread id %i", tid);
+ thread_join_data[tid].state = pthreads_st_run;
+ /* Now that we copied/updated the guys, we may release the caller... */
+ MUTEX_UNLOCK(&start_thread_mutex);
+ thread_join_data[tid].status = (*start_routine)(arg);
+ switch (thread_join_data[tid].state) {
+ case pthreads_st_waited:
+ COND_SIGNAL(&thread_join_data[tid].cond);
+ break;
+ default:
+ thread_join_data[tid].state = pthreads_st_exited;
+ break;
+ }
+}
+
+int
+pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
+ void *(*start_routine)(void*), void *arg)
+{
+ void *args[2];
+
+ args[0] = (void*)start_routine;
+ args[1] = arg;
+
+ MUTEX_LOCK(&start_thread_mutex);
+ *tid = _beginthread(pthread_startit, /*stack*/ NULL,
+ /*stacksize*/ 10*1024*1024, (void*)args);
+ MUTEX_LOCK(&start_thread_mutex);
+ MUTEX_UNLOCK(&start_thread_mutex);
+ return *tid ? 0 : EINVAL;
+}
+
+int
+pthread_detach(perl_os_thread tid)
+{
+ MUTEX_LOCK(&start_thread_mutex);
+ switch (thread_join_data[tid].state) {
+ case pthreads_st_waited:
+ MUTEX_UNLOCK(&start_thread_mutex);
+ Perl_croak_nocontext("detach on a thread with a waiter");
+ break;
+ case pthreads_st_run:
+ thread_join_data[tid].state = pthreads_st_detached;
+ MUTEX_UNLOCK(&start_thread_mutex);
+ break;
+ default:
+ MUTEX_UNLOCK(&start_thread_mutex);
+ Perl_croak_nocontext("detach: unknown thread state: '%s'",
+ pthreads_states[thread_join_data[tid].state]);
+ break;
+ }
+ return 0;
+}
+
+/* This is a very bastardized version: */
+int
+os2_cond_wait(perl_cond *c, perl_mutex *m)
+{
+ int rc;
+ STRLEN n_a;
+ if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
+ Perl_croak_nocontext("panic: COND_WAIT-reset: rc=%i", rc);
+ if (m) MUTEX_UNLOCK(m);
+ if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
+ && (rc != ERROR_INTERRUPT))
+ Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc);
+ if (rc == ERROR_INTERRUPT)
+ errno = EINTR;
+ if (m) MUTEX_LOCK(m);
+}
+#endif
+
+static int exe_is_aout(void);
+
/*****************************************************************************/
+/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
+#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, 872}, /* WinIsWindow */
+ {&pmwin_handle, NULL, 899}, /* WinWindowFromId */
+ {&pmwin_handle, NULL, 900}, /* WinWindowFromPoint */
+ {&pmwin_handle, NULL, 919}, /* WinPostMsg */
+};
+
+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(const char *modname, int fail)
+{
+ HMODULE h = (HMODULE)dlopen(modname, 0);
+
+ if (!h && fail)
+ Perl_croak_nocontext("Error loading module '%s': %s",
+ modname, dlerror());
+ return h;
+}
+
+PFN
+loadByOrdinal(enum entries_ordinals ord, int fail)
+{
+ if (ExtFCN[ord] == NULL) {
+ PFN fcn = (PFN)-1;
+ APIRET rc;
+
+ 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.%s",
+ loadOrdinals[ord].dll->modname, s);
+ }
+ ExtFCN[ord] = fcn;
+ }
+ if ((long)ExtFCN[ord] == -1)
+ Perl_croak_nocontext("panic queryaddr");
+ return ExtFCN[ord];
+}
+
+void
+init_PMWIN_entries(void)
+{
+ int 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;
- New(1022, pbuffer, buf_len, char);
+ 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 (!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);
while (rc == ERROR_BUFFER_OVERFLOW) {
Renew(pbuffer, buf_len *= 2, char);
- rc = QuerySysState(QSS_PROCESS, pid, pbuffer, buf_len);
+ rc = QuerySysState(flags, pid, pbuffer, buf_len);
}
if (rc) {
FillOSError(rc);
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);
- croak("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)) {
/* Do not change class. */
return CheckOSError(DosSetPriority((pid < 0)
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;
- /* DosGetInfoBlocks has old priority! */
-/* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
-/* if (pid != pib->pib_ulpid) { */
+ if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
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;
+static int spawn_killed;
+
+static Signal_t
+spawn_sighandler(int sig)
+{
+ /* Some programs do not arrange for the keyboard signals to be
+ delivered to them. We need to deliver the signal manually. */
+ /* We may get a signal only if
+ a) kid does not receive keyboard signal: deliver it;
+ b) kid already died, and we get a signal. We may only hope
+ that the pid number was not reused.
+ */
+
+ if (spawn_killed)
+ sig = SIGKILL; /* Try harder. */
+ kill(spawn_pid, sig);
+ spawn_killed = 1;
+}
+
static int
-result(int flag, int pid)
+result(pTHX_ int flag, int pid)
{
int r, status;
Signal_t (*ihand)(); /* place to save signal during system() */
return pid;
#ifdef __EMX__
- ihand = signal(SIGINT, SIG_IGN);
- qhand = signal(SIGQUIT, SIG_IGN);
+ spawn_pid = pid;
+ spawn_killed = 0;
+ ihand = rsignal(SIGINT, &spawn_sighandler);
+ qhand = rsignal(SIGQUIT, &spawn_sighandler);
do {
r = wait4pid(pid, &status, 0);
} while (r == -1 && errno == EINTR);
- signal(SIGINT, ihand);
- signal(SIGQUIT, qhand);
+ rsignal(SIGINT, ihand);
+ rsignal(SIGQUIT, qhand);
- statusvalue = (U16)status;
+ PL_statusvalue = (U16)status;
if (r < 0)
return -1;
return status & 0xFFFF;
#else
- ihand = signal(SIGINT, SIG_IGN);
+ ihand = rsignal(SIGINT, SIG_IGN);
r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
- signal(SIGINT, ihand);
- statusvalue = res.codeResult << 8 | res.codeTerminate;
+ rsignal(SIGINT, ihand);
+ PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
if (r)
return -1;
- return statusvalue;
+ return PL_statusvalue;
#endif
}
-int
-do_aspawn(really,mark,sp)
-SV *really;
-register SV **mark;
-register SV **sp;
+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" }; */
+
+static int
+my_type()
{
- register char **a;
- char *tmps;
int rc;
- int flag = P_WAIT, trueflag;
-
- if (sp > mark) {
- New(401,Argv, sp - mark + 1, char*);
- a = Argv;
+ TIB *tib;
+ PIB *pib;
+
+ if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
+ if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
+ return -1;
+
+ return (pib->pib_ultype);
+}
- if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
- ++mark;
- flag = SvIVx(*mark);
+static ULONG
+file_type(char *path)
+{
+ int rc;
+ ULONG apptype;
+
+ if (!(_emx_env & 0x200))
+ Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
+ if (CheckOSError(DosQueryAppType(path, &apptype))) {
+ switch (rc) {
+ case ERROR_FILE_NOT_FOUND:
+ case ERROR_PATH_NOT_FOUND:
+ return -1;
+ case ERROR_ACCESS_DENIED: /* Directory with this name found? */
+ return -3;
+ default: /* Found, but not an
+ executable, or some other
+ read error. */
+ return -2;
}
+ }
+ return apptype;
+}
- while (++mark <= sp) {
- if (*mark)
- *a++ = SvPVx(*mark, na);
- else
- *a++ = "";
- }
- *a = Nullch;
+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 *);
- trueflag = flag;
+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 *args[4];
+ static char * fargs[4]
+ = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
+ char **argsp = fargs;
+ int nargs = 4;
+ int force_shell;
+ 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 (*Argv[0] != '/' && *Argv[0] != '\\'
- && !(*Argv[0] && *Argv[1] == ':'
- && (*Argv[2] == '/' || *Argv[2] != '\\'))
- ) /* will swawnvp use PATH? */
+ retry:
+ 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, na)))
- rc = result(trueflag, spawnvp(flag,tmps,Argv));
- else
- rc = result(trueflag, spawnvp(flag,Argv[0],Argv));
+ if (!really || !*(tmps = SvPV(really, n_a)))
+ tmps = PL_Argv[0];
+
+ reread:
+ force_shell = 0;
+ if (_emx_env & 0x200) { /* OS/2. */
+ int type = file_type(tmps);
+ type_again:
+ if (type == -1) { /* Not found */
+ errno = ENOENT;
+ rc = -1;
+ goto do_script;
+ }
+ else if (type == -2) { /* Not an EXE */
+ errno = ENOEXEC;
+ rc = -1;
+ goto do_script;
+ }
+ else if (type == -3) { /* Is a directory? */
+ /* Special-case this */
+ char tbuf[512];
+ int l = strlen(tmps);
+
+ if (l + 5 <= sizeof tbuf) {
+ strcpy(tbuf, tmps);
+ strcpy(tbuf + l, ".exe");
+ type = file_type(tbuf);
+ if (type >= -3)
+ goto type_again;
+ }
+
+ errno = ENOEXEC;
+ rc = -1;
+ goto do_script;
+ }
+ switch (type & 7) {
+ /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
+ case FAPPTYP_WINDOWAPI:
+ {
+ if (os2_mytype != 3) { /* not PM */
+ 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",
+ flag, os2_mytype);
+ }
+ }
+ break;
+ case FAPPTYP_NOTWINDOWCOMPAT:
+ {
+ if (os2_mytype != 0) { /* not full screen */
+ 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",
+ flag, os2_mytype);
+ }
+ }
+ break;
+ case FAPPTYP_NOTSPEC:
+ /* Let the shell handle this... */
+ force_shell = 1;
+ buf = ""; /* Pacify a warning */
+ file = 0; /* Pacify a warning */
+ goto doshell_args;
+ break;
+ }
+ }
- if (rc < 0 && dowarn)
- warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
- if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
- } else
- rc = -1;
- do_execfree();
+ if (addflag) {
+ addflag = 0;
+ new_stderr = dup(2); /* Preserve stderr */
+ if (new_stderr == -1) {
+ if (errno == EBADF)
+ nostderr = 1;
+ else {
+ rc = -1;
+ goto finish;
+ }
+ } else
+ fl_stderr = fcntl(2, F_GETFD);
+ rc = dup2(1,2);
+ if (rc == -1)
+ goto finish;
+ fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
+ }
+
+#if 0
+ rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv));
+#else
+ if (execf == EXECF_TRUEEXEC)
+ rc = execvp(tmps,PL_Argv);
+ else if (execf == EXECF_EXEC)
+ 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));
+#endif
+ if (rc < 0 && pass == 1
+ && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
+ do_script:
+ {
+ int err = errno;
+
+ if (err == ENOENT || err == ENOEXEC) {
+ /* No such file, or is a script. */
+ /* Try adding script extensions to the file name, and
+ search on PATH. */
+ char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
+
+ if (scr) {
+ char *s = 0, *s1;
+ SV *scrsv = sv_2mortal(newSVpv(scr, 0));
+ SV *bufsv = sv_newmortal();
+
+ Safefree(scr);
+ scr = SvPV(scrsv, n_a); /* free()ed later */
+
+ file = PerlIO_open(scr, "r");
+ PL_Argv[0] = scr;
+ if (!file)
+ goto panic_file;
+
+ 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). */
+ 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 { /* 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",
+ scr, Strerror(errno));
+ buf = ""; /* Not #! */
+ goto doshell_args;
+ }
+ if (buf[0] == '#') {
+ if (buf[1] == '!')
+ s = buf + 2;
+ } else if (buf[0] == 'e') {
+ if (strnEQ(buf, "extproc", 7)
+ && isSPACE(buf[7]))
+ s = buf + 8;
+ } else if (buf[0] == 'E') {
+ if (strnEQ(buf, "EXTPROC", 7)
+ && isSPACE(buf[7]))
+ s = buf + 8;
+ }
+ if (!s) {
+ buf = ""; /* Not #! */
+ goto doshell_args;
+ }
+
+ s1 = s;
+ nargs = 0;
+ argsp = args;
+ while (1) {
+ /* Do better than pdksh: allow a few args,
+ strip trailing whitespace. */
+ while (isSPACE(*s))
+ s++;
+ if (*s == 0)
+ break;
+ if (nargs == 4) {
+ nargs = -1;
+ break;
+ }
+ args[nargs++] = s;
+ while (*s && !isSPACE(*s))
+ s++;
+ if (*s == 0)
+ break;
+ *s++ = 0;
+ }
+ if (nargs == -1) {
+ Perl_warner(aTHX_ 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;
+ char *exec_args[2];
+
+ if (force_shell
+ || (!buf[0] && file)) { /* File without magic */
+ /* In fact we tried all what pdksh would
+ try. There is no point in calling
+ pdksh, we may just emulate its logic. */
+ char *shell = getenv("EXECSHELL");
+ char *shell_opt = NULL;
+
+ if (!shell) {
+ char *s;
+
+ shell_opt = "/c";
+ shell = getenv("OS2_SHELL");
+ if (inicmd) { /* No spaces at start! */
+ s = inicmd;
+ while (*s && !isSPACE(*s)) {
+ if (*s++ == '/') {
+ inicmd = NULL; /* Cannot use */
+ break;
+ }
+ }
+ }
+ if (!inicmd) {
+ s = PL_Argv[0];
+ while (*s) {
+ /* Dosish shells will choke on slashes
+ in paths, fortunately, this is
+ important for zeroth arg only. */
+ if (*s == '/')
+ *s = '\\';
+ s++;
+ }
+ }
+ }
+ /* If EXECSHELL is set, we do not set */
+
+ if (!shell)
+ shell = ((_emx_env & 0x200)
+ ? "c:/os2/cmd.exe"
+ : "c:/command.com");
+ nargs = shell_opt ? 2 : 1; /* shell file args */
+ exec_args[0] = shell;
+ exec_args[1] = shell_opt;
+ argsp = exec_args;
+ if (nargs == 2 && inicmd) {
+ /* Use the original cmd line */
+ /* XXXX This is good only until we refuse
+ quoted arguments... */
+ PL_Argv[0] = inicmd;
+ PL_Argv[1] = Nullch;
+ }
+ } else if (!buf[0] && inicmd) { /* No file */
+ /* Start with the original cmdline. */
+ /* XXXX This is good only until we refuse
+ quoted arguments... */
+
+ PL_Argv[0] = inicmd;
+ PL_Argv[1] = Nullch;
+ nargs = 2; /* shell -c */
+ }
+
+ while (a[1]) /* Get to the end */
+ a++;
+ a++; /* Copy finil NULL too */
+ while (a >= PL_Argv) {
+ *(a + nargs) = *a; /* PL_Argv was preallocated to be
+ long enough. */
+ a--;
+ }
+ while (--nargs >= 0)
+ PL_Argv[nargs] = argsp[nargs];
+ /* Enable pathless exec if #! (as pdksh). */
+ pass = (buf[0] == '#' ? 2 : 3);
+ goto retry;
+ }
+ }
+ /* Not found: restore errno */
+ errno = err;
+ }
+ }
+ } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
+ char *no_dir = strrchr(PL_Argv[0], '/');
+
+ /* Do as pdksh port does: if not found with /, try without
+ path. */
+ if (no_dir) {
+ PL_Argv[0] = no_dir + 1;
+ pass++;
+ goto retry;
+ }
+ }
+ if (rc < 0 && ckWARN(WARN_EXEC))
+ Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n",
+ ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
+ ? "spawn" : "exec"),
+ PL_Argv[0], Strerror(errno));
+ if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
+ && ((trueflag & 0xFF) == P_WAIT))
+ rc = -1;
+
+ finish:
+ if (new_stderr != -1) { /* How can we use error codes? */
+ dup2(new_stderr, 2);
+ close(new_stderr);
+ fcntl(2, F_SETFD, fl_stderr);
+ } else if (nostderr)
+ close(2);
return rc;
}
-#define EXECF_SPAWN 0
-#define EXECF_EXEC 1
-#define EXECF_TRUEEXEC 2
-
+/* Try converting 1-arg form to (usually shell-less) multi-arg form. */
int
-do_spawn2(cmd, execf)
-char *cmd;
-int execf;
+do_spawn3(pTHX_ char *cmd, int execf, int flag)
{
register char **a;
register char *s;
- char flags[10];
- char *shell, *copt;
- int rc;
+ char *shell, *copt, *news = NULL;
+ int rc, seenspace = 0, mergestderr = 0;
#ifdef TRYSHELL
if ((shell = getenv("EMXSHELL")) != NULL)
have a shell which will not change between computers with the
same architecture, to avoid "action on a distance".
And to have simple build, this shell should be sh. */
- shell = SH_PATH;
+ shell = PL_sh_path;
copt = "-c";
#endif
while (*cmd && isSPACE(*cmd))
cmd++;
+ if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
+ STRLEN l = strlen(PL_sh_path);
+
+ New(1302, news, strlen(cmd) - 7 + l + 1, char);
+ strcpy(news, PL_sh_path);
+ strcpy(news + l, cmd + 7);
+ cmd = news;
+ }
+
/* save an extra exec if possible */
/* see if there are shell metacharacters in it */
for (s = cmd; *s; s++) {
if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
- if (*s == '\n' && !s[1]) {
+ if (*s == '\n' && s[1] == '\0') {
*s = '\0';
break;
+ } else if (*s == '\\' && !seenspace) {
+ continue; /* Allow backslashes in names */
+ } else if (*s == '>' && s >= cmd + 3
+ && s[-1] == '2' && s[1] == '&' && s[2] == '1'
+ && isSPACE(s[-2]) ) {
+ char *t = s + 3;
+
+ while (*t && isSPACE(*t))
+ t++;
+ if (!*t) {
+ s[-2] = '\0';
+ mergestderr = 1;
+ break; /* Allow 2>&1 as the last thing */
+ }
}
+ /* We do not convert this to do_spawn_ve since shell
+ should be smart enough to start itself gloriously. */
doshell:
if (execf == EXECF_TRUEEXEC)
- return execl(shell,shell,copt,cmd,(char*)0);
+ rc = execl(shell,shell,copt,cmd,(char*)0);
else if (execf == EXECF_EXEC)
- return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
- /* In the ak code internal P_NOWAIT is P_WAIT ??? */
- rc = result(P_WAIT,
- spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
- if (rc < 0 && dowarn)
- warn("Can't %s \"%s\": %s",
- (execf == EXECF_SPAWN ? "spawn" : "exec"),
- shell, Strerror(errno));
- if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
+ rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
+ else if (execf == EXECF_SPAWN_NOWAIT)
+ rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
+ else if (execf == EXECF_SPAWN_BYFLAG)
+ rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
+ else {
+ /* In the ak code internal P_NOWAIT is P_WAIT ??? */
+ 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",
+ (execf == EXECF_SPAWN ? "spawn" : "exec"),
+ shell, Strerror(errno));
+ if (rc < 0)
+ rc = -1;
+ }
+ if (news)
+ Safefree(news);
return rc;
+ } else if (*s == ' ' || *s == '\t') {
+ seenspace = 1;
}
}
- New(402,Argv, (s - cmd) / 2 + 2, char*);
- Cmd = savepvn(cmd, s-cmd);
- a = Argv;
- for (s = Cmd; *s;) {
+ /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
+ New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
+ PL_Cmd = savepvn(cmd, s-cmd);
+ a = PL_Argv;
+ for (s = PL_Cmd; *s;) {
while (*s && isSPACE(*s)) s++;
if (*s)
*(a++) = s;
*s++ = '\0';
}
*a = Nullch;
- if (Argv[0]) {
- if (execf == EXECF_TRUEEXEC)
- rc = execvp(Argv[0],Argv);
- else if (execf == EXECF_EXEC)
- rc = spawnvp(P_OVERLAY,Argv[0],Argv);
- else
- rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
- if (rc < 0 && dowarn)
- warn("Can't %s \"%s\": %s",
- (execf == EXECF_SPAWN ? "spawn" : "exec"),
- Argv[0], Strerror(errno));
- if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
+ if (PL_Argv[0])
+ rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
+ else
+ rc = -1;
+ if (news)
+ Safefree(news);
+ do_execfree();
+ return rc;
+}
+
+/* Array spawn. */
+int
+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;
+ STRLEN n_a;
+
+ if (sp > mark) {
+ New(1301,PL_Argv, sp - mark + 3, char*);
+ a = PL_Argv;
+
+ if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
+ ++mark;
+ flag = SvIVx(*mark);
+ flag_set = 1;
+
+ }
+
+ while (++mark <= sp) {
+ if (*mark)
+ *a++ = SvPVx(*mark, n_a);
+ else
+ *a++ = "";
+ }
+ *a = Nullch;
+
+ if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
+ rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
+ } else
+ rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0);
} else
rc = -1;
do_execfree();
}
int
-do_spawn(cmd)
-char *cmd;
+os2_do_spawn(pTHX_ char *cmd)
+{
+ return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
+}
+
+int
+do_spawn_nowait(pTHX_ char *cmd)
{
- return do_spawn2(cmd, EXECF_SPAWN);
+ return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
}
bool
-do_exec(cmd)
-char *cmd;
+Perl_do_exec(pTHX_ char *cmd)
{
- return do_spawn2(cmd, EXECF_EXEC);
+ do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
+ return FALSE;
}
bool
-os2exec(cmd)
-char *cmd;
+os2exec(pTHX_ char *cmd)
{
- return do_spawn2(cmd, EXECF_TRUEEXEC);
+ return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
}
-#ifndef HAS_FORK
-FILE *
-my_popen(cmd,mode)
-char *cmd;
-char *mode;
+PerlIO *
+my_syspopen(pTHX_ char *cmd, char *mode)
{
-#ifdef TRYSHELL
- return popen(cmd, mode);
-#else
- char *shell = getenv("EMXSHELL");
- FILE *res;
+#ifndef USE_POPEN
+ int p[2];
+ register I32 this, that, newfd;
+ register I32 pid;
+ SV *sv;
+ int fh_fl = 0; /* Pacify the warning */
- my_setenv("EMXSHELL", SH_PATH);
+ /* `this' is what we use in the parent, `that' in the child. */
+ this = (*mode == 'w');
+ that = !this;
+ if (PL_tainting) {
+ taint_env();
+ taint_proper("Insecure %s%s", "EXEC");
+ }
+ if (pipe(p) < 0)
+ return Nullfp;
+ /* Now we need to spawn the child. */
+ if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
+ int new = dup(p[this]);
+
+ if (new == -1)
+ goto closepipes;
+ close(p[this]);
+ p[this] = new;
+ }
+ newfd = dup(*mode == 'r'); /* Preserve std* */
+ if (newfd == -1) {
+ /* This cannot happen due to fh being bad after pipe(), since
+ pipe() should have created fh 0 and 1 even if they were
+ initially closed. But we closed p[this] before. */
+ if (errno != EBADF) {
+ closepipes:
+ close(p[0]);
+ close(p[1]);
+ return Nullfp;
+ }
+ } else
+ fh_fl = fcntl(*mode == 'r', F_GETFD);
+ if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
+ dup2(p[that], *mode == 'r');
+ close(p[that]);
+ }
+ /* Where is `this' and newfd now? */
+ fcntl(p[this], F_SETFD, FD_CLOEXEC);
+ if (newfd != -1)
+ fcntl(newfd, F_SETFD, FD_CLOEXEC);
+ pid = do_spawn_nowait(aTHX_ cmd);
+ if (newfd == -1)
+ close(*mode == 'r'); /* It was closed initially */
+ else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
+ dup2(newfd, *mode == 'r'); /* Return std* back. */
+ close(newfd);
+ fcntl(*mode == 'r', F_SETFD, fh_fl);
+ } else
+ fcntl(*mode == 'r', F_SETFD, fh_fl);
+ if (p[that] == (*mode == 'r'))
+ close(p[that]);
+ if (pid == -1) {
+ close(p[this]);
+ return Nullfp;
+ }
+ if (p[that] < p[this]) { /* Make fh as small as possible */
+ dup2(p[this], p[that]);
+ close(p[this]);
+ p[this] = p[that];
+ }
+ sv = *av_fetch(PL_fdpid,p[this],TRUE);
+ (void)SvUPGRADE(sv,SVt_IV);
+ SvIVX(sv) = pid;
+ PL_forkprocess = pid;
+ return PerlIO_fdopen(p[this], mode);
+
+#else /* USE_POPEN */
+
+ PerlIO *res;
+ SV *sv;
+
+# ifdef TRYSHELL
+ res = popen(cmd, mode);
+# else
+ char *shell = getenv("EMXSHELL");
+
+ my_setenv("EMXSHELL", PL_sh_path);
res = popen(cmd, mode);
my_setenv("EMXSHELL", shell);
+# endif
+ sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
+ (void)SvUPGRADE(sv,SVt_IV);
+ SvIVX(sv) = -1; /* A cooky. */
return res;
-#endif
+
+#endif /* USE_POPEN */
+
}
-#endif
-/*****************************************************************************/
+/******************************************************************/
#ifndef HAS_FORK
int
fork(void)
{
- die(no_func, "Unsupported function fork");
+ Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
errno = EINVAL;
return -1;
}
#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; }
#endif
/*****************************************************************************/
-/* my socket forwarders - EMX lib only provides static forwarders */
-
-static HMODULE htcp = 0;
-
-static void *
-tcp0(char *name)
-{
- static BYTE buf[20];
- PFN fcn;
- if (!htcp)
- DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
- 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 (!htcp)
- DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
- if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
- ((void (*)(int)) fcn) (arg);
-}
-
-void * gethostent() { return tcp0("GETHOSTENT"); }
-void * getnetent() { return tcp0("GETNETENT"); }
-void * getprotoent() { return tcp0("GETPROTOENT"); }
-void * 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++ */
#ifndef __EMX__
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;
if (rc == ERROR_NOT_ENOUGH_MEMORY) {
return (void *) -1;
- } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
+ } else if ( rc )
+ Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
return got;
}
if (!p) return;
len = strlen(p);
tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
- strcpy(tpath, p);
- tpath[len] = '/';
- strcpy(tpath + len + 1, TMPPATH1);
- tmppath = tpath;
+ if (tpath) {
+ strcpy(tpath, p);
+ tpath[len] = '/';
+ strcpy(tpath + len + 1, TMPPATH1);
+ tmppath = tpath;
+ }
}
#include "XSUB.h"
{
dXSARGS;
if (items < 2 || items > 3)
- croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
+ Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
{
- char * src = (char *)SvPV(ST(0),na);
- char * dst = (char *)SvPV(ST(1),na);
+ STRLEN n_a;
+ char * src = (char *)SvPV(ST(0),n_a);
+ char * dst = (char *)SvPV(ST(1),n_a);
U32 flag;
int RETVAL, rc;
XSRETURN(1);
}
+#define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */
+#include "patchlevel.h"
+#undef PERL_PATCHLEVEL_H_IMPLICIT
+
char *
-mod2fname(sv)
- SV *sv;
+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;
- if (!SvROK(sv)) croak("Not a reference given to mod2fname");
+ if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
sv = SvRV(sv);
if (SvTYPE(sv) != SVt_PVAV)
- croak("Not array reference given to mod2fname");
+ Perl_croak_nocontext("Not array reference given to mod2fname");
avlen = av_len((AV*)sv);
if (avlen < 0)
- croak("Empty array reference given to mod2fname");
+ Perl_croak_nocontext("Empty array reference given to mod2fname");
- s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
+ s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
strncpy(fname, s, 8);
len = strlen(s);
if (len < 6) pos = len;
}
avlen --;
while (avlen >= 0) {
- s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
+ s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
while (*s) {
sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
}
avlen --;
}
+#ifdef USE_5005THREADS
+ sum++; /* Avoid conflict of DLLs in memory. */
+#endif
+ /* We always load modules as *specific* DLLs, and with the full name.
+ When loading a specific DLL by its full name, one cannot get a
+ different DLL, even if a DLL with the same basename is loaded already.
+ Thus there is no need to include the version into the mangling scheme. */
+#if 0
+ sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
+#else
+# ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
+# define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
+# endif
+ sum += COMPATIBLE_VERSION_SUM;
+#endif
fname[pos] = 'A' + (sum % 26);
fname[pos + 1] = 'A' + (sum / 26 % 26);
fname[pos + 2] = '\0';
{
dXSARGS;
if (items != 1)
- croak("Usage: DynaLoader::mod2fname(sv)");
+ Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
{
SV * sv = ST(0);
char * RETVAL;
- RETVAL = mod2fname(sv);
+ RETVAL = mod2fname(aTHX_ sv);
ST(0) = sv_newmortal();
sv_setpv((SV*)ST(0), RETVAL);
}
{
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';
+ 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;
}
-OS2_Perl_data_t OS2_Perl_data;
-
-int
-Xs_OS2_init()
-{
- char *file = __FILE__;
- {
- GV *gv;
-
- newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
- newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
- gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
- GvMULTI_on(gv);
-#ifdef PERL_IS_AOUT
- sv_setiv(GvSV(gv), 1);
-#endif
- }
-}
-
-void
-Perl_OS2_init()
+char *
+os2_execname(pTHX)
{
- char *shell;
-
- settmppath();
- OS2_Perl_data.xs_init = &Xs_OS2_init;
- if ( (shell = getenv("PERL_SH_DRIVE")) ) {
- sh_path[0] = shell[0];
- } else if ( (shell = getenv("PERL_SH_DIR")) ) {
- int l = strlen(shell);
- if (shell[l-1] == '/' || shell[l-1] == '\\') {
- l--;
- }
- if (l > STATIC_FILE_LENGTH - 7) {
- die("PERL_SH_DIR too long");
- }
- strncpy(sh_path, shell, l);
- strcpy(sh_path + l, "/sh.exe");
- }
+ char buf[300], *p, *o = PL_origargv[0], ok = 1;
+
+ if (_execname(buf, sizeof buf) != 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);
+ return p;
}
-char sh_path[STATIC_FILE_LENGTH+1] = BIN_SH;
-
char *
perllib_mangle(char *s, unsigned int l)
{
if (!newp && !notfound) {
newp = getenv("PERLLIB_PREFIX");
if (newp) {
+ char *s;
+
oldp = newp;
- while (*newp && !isSPACE(*newp)) {
+ while (*newp && !isSPACE(*newp) && *newp != ';') {
newp++; oldl++; /* Skip digits. */
}
while (*newp && (isSPACE(*newp) || *newp == ';')) {
}
newl = strlen(newp);
if (newl == 0 || oldl == 0) {
- die("Malformed PERLLIB_PREFIX");
+ Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
+ }
+ strcpy(ret, newp);
+ s = ret;
+ while (*s) {
+ if (*s == '\\') *s = '/';
+ s++;
}
} else {
notfound = 1;
if (l == 0) {
l = strlen(s);
}
- if (l <= oldl || strnicmp(oldp, s, oldl) != 0) {
+ if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
return s;
}
if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
- die("Malformed PERLLIB_PREFIX");
+ Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
}
- strncpy(ret, newp, newl);
- strncpy(ret + newl, s + oldl, l - oldl);
+ strcpy(ret + newl, s + oldl);
return ret;
}
-extern void dlopen();
-void *fakedl = &dlopen; /* Pull in dynaloading part. */
+unsigned long
+Perl_hab_GET() /* Needed if perl.h cannot be included */
+{
+ return perl_hab_GET();
+}
+
+HMQ
+Perl_Register_MQ(int serve)
+{
+ PPIB pib;
+ PTIB tib;
+
+ if (Perl_os2_initial_mode++)
+ return Perl_hmq;
+ DosGetInfoBlocks(&tib, &pib);
+ Perl_os2_initial_mode = pib->pib_ultype;
+ /* Try morphing into a PM application. */
+ if (pib->pib_ultype != 3) /* 2 is VIO */
+ pib->pib_ultype = 3; /* 3 is PM */
+ init_PMWIN_entries();
+ /* 64 messages if before OS/2 3.0, ignored otherwise */
+ 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;
+}
+
+int
+Perl_Serve_Messages(int force)
+{
+ int cnt = 0;
+ QMSG msg;
+
+ if (Perl_hmq_servers > 0 && !force)
+ return 0;
+ if (Perl_hmq_refcnt <= 0)
+ Perl_croak_nocontext("No message queue");
+ while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
+ cnt++;
+ if (msg.msg == WM_QUIT)
+ Perl_croak_nocontext("QUITing...");
+ (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
+ }
+ return cnt;
+}
+
+int
+Perl_Process_Messages(int force, I32 *cntp)
+{
+ QMSG msg;
+
+ if (Perl_hmq_servers > 0 && !force)
+ return 0;
+ if (Perl_hmq_refcnt <= 0)
+ Perl_croak_nocontext("No message queue");
+ while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
+ if (cntp)
+ (*cntp)++;
+ (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
+ if (msg.msg == WM_DESTROY)
+ return -1;
+ if (msg.msg == WM_CREATE)
+ return +1;
+ }
+ Perl_croak_nocontext("QUITing...");
+}
+
+void
+Perl_Deregister_MQ(int serve)
+{
+ PPIB pib;
+ PTIB tib;
+
+ 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);
+}
+
+#define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
+ && ((path)[2] == '/' || (path)[2] == '\\'))
+#define sys_is_rooted _fnisabs
+#define sys_is_relative _fnisrel
+#define current_drive _getdrive
+
+#undef chdir /* Was _chdir2. */
+#define sys_chdir(p) (chdir(p) == 0)
+#define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
+
+static int DOS_harderr_state = -1;
+
+XS(XS_OS2_Error)
+{
+ dXSARGS;
+ if (items != 2)
+ Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
+ {
+ int arg1 = SvIV(ST(0));
+ int arg2 = SvIV(ST(1));
+ int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
+ | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
+ int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
+ unsigned long rc;
+
+ if (CheckOSError(DosError(a)))
+ Perl_croak_nocontext("DosError(%d) failed", a);
+ ST(0) = sv_newmortal();
+ if (DOS_harderr_state >= 0)
+ sv_setiv(ST(0), DOS_harderr_state);
+ DOS_harderr_state = RETVAL;
+ }
+ XSRETURN(1);
+}
+
+static signed char DOS_suppression_state = -1;
+
+XS(XS_OS2_Errors2Drive)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
+ {
+ STRLEN n_a;
+ SV *sv = ST(0);
+ int suppress = SvOK(sv);
+ char *s = suppress ? SvPV(sv, n_a) : NULL;
+ char drive = (s ? *s : 0);
+ unsigned long rc;
+
+ if (suppress && !isALPHA(drive))
+ Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
+ if (CheckOSError(DosSuppressPopUps((suppress
+ ? SPU_ENABLESUPPRESSION
+ : SPU_DISABLESUPPRESSION),
+ drive)))
+ Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
+ ST(0) = sv_newmortal();
+ if (DOS_suppression_state > 0)
+ sv_setpvn(ST(0), &DOS_suppression_state, 1);
+ else if (DOS_suppression_state == 0)
+ sv_setpvn(ST(0), "", 0);
+ DOS_suppression_state = drive;
+ }
+ XSRETURN(1);
+}
+
+static const char * const si_fields[QSV_MAX] = {
+ "MAX_PATH_LENGTH",
+ "MAX_TEXT_SESSIONS",
+ "MAX_PM_SESSIONS",
+ "MAX_VDM_SESSIONS",
+ "BOOT_DRIVE",
+ "DYN_PRI_VARIATION",
+ "MAX_WAIT",
+ "MIN_SLICE",
+ "MAX_SLICE",
+ "PAGE_SIZE",
+ "VERSION_MAJOR",
+ "VERSION_MINOR",
+ "VERSION_REVISION",
+ "MS_COUNT",
+ "TIME_LOW",
+ "TIME_HIGH",
+ "TOTPHYSMEM",
+ "TOTRESMEM",
+ "TOTAVAILMEM",
+ "MAXPRMEM",
+ "MAXSHMEM",
+ "TIMER_INTERVAL",
+ "MAX_COMP_LENGTH",
+ "FOREGROUND_FS_SESSION",
+ "FOREGROUND_PROCESS"
+};
+
+XS(XS_OS2_SysInfo)
+{
+ dXSARGS;
+ if (items != 0)
+ Perl_croak_nocontext("Usage: OS2::SysInfo()");
+ {
+ ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
+ APIRET rc = NO_ERROR; /* Return code */
+ int i = 0, j = 0;
+
+ if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
+ QSV_MAX, /* information */
+ (PVOID)si,
+ sizeof(si))))
+ Perl_croak_nocontext("DosQuerySysInfo() failed");
+ EXTEND(SP,2*QSV_MAX);
+ while (i < QSV_MAX) {
+ ST(j) = sv_newmortal();
+ sv_setpv(ST(j++), si_fields[i]);
+ ST(j) = sv_newmortal();
+ sv_setiv(ST(j++), si[i]);
+ i++;
+ }
+ }
+ XSRETURN(2 * QSV_MAX);
+}
+
+XS(XS_OS2_BootDrive)
+{
+ dXSARGS;
+ if (items != 0)
+ Perl_croak_nocontext("Usage: OS2::BootDrive()");
+ {
+ ULONG si[1] = {0}; /* System Information Data Buffer */
+ APIRET rc = NO_ERROR; /* Return code */
+ char c;
+
+ if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
+ (PVOID)si, sizeof(si))))
+ Perl_croak_nocontext("DosQuerySysInfo() failed");
+ ST(0) = sv_newmortal();
+ c = 'a' - 1 + si[0];
+ sv_setpvn(ST(0), &c, 1);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_MorphPM)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
+ {
+ bool serve = SvOK(ST(0));
+ unsigned long pmq = perl_hmq_GET(serve);
+
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), pmq);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_UnMorphPM)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
+ {
+ bool serve = SvOK(ST(0));
+
+ perl_hmq_UNSET(serve);
+ }
+ XSRETURN(0);
+}
+
+XS(XS_OS2_Serve_Messages)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
+ {
+ bool force = SvOK(ST(0));
+ unsigned long cnt = Perl_Serve_Messages(force);
+
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), cnt);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_Process_Messages)
+{
+ dXSARGS;
+ if (items < 1 || items > 2)
+ Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
+ {
+ bool force = SvOK(ST(0));
+ unsigned long cnt;
+
+ if (items == 2) {
+ I32 cntr;
+ SV *sv = ST(1);
+
+ (void)SvIV(sv); /* Force SvIVX */
+ if (!SvIOK(sv))
+ Perl_croak_nocontext("Can't upgrade count to IV");
+ 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);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_current_drive)
+{
+ dXSARGS;
+ if (items != 0)
+ Perl_croak_nocontext("Usage: Cwd::current_drive()");
+ {
+ char RETVAL;
+
+ RETVAL = current_drive();
+ ST(0) = sv_newmortal();
+ sv_setpvn(ST(0), (char *)&RETVAL, 1);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_chdir)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
+ {
+ STRLEN n_a;
+ char * path = (char *)SvPV(ST(0),n_a);
+ bool RETVAL;
+
+ RETVAL = sys_chdir(path);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_change_drive)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
+ {
+ STRLEN n_a;
+ char d = (char)*SvPV(ST(0),n_a);
+ bool RETVAL;
+
+ RETVAL = change_drive(d);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_is_absolute)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
+ {
+ STRLEN n_a;
+ char * path = (char *)SvPV(ST(0),n_a);
+ bool RETVAL;
+
+ RETVAL = sys_is_absolute(path);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_is_rooted)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
+ {
+ STRLEN n_a;
+ char * path = (char *)SvPV(ST(0),n_a);
+ bool RETVAL;
+
+ RETVAL = sys_is_rooted(path);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_is_relative)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
+ {
+ STRLEN n_a;
+ char * path = (char *)SvPV(ST(0),n_a);
+ bool RETVAL;
+
+ RETVAL = sys_is_relative(path);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_cwd)
+{
+ dXSARGS;
+ if (items != 0)
+ Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
+ {
+ char p[MAXPATHLEN];
+ char * RETVAL;
+ RETVAL = _getcwd2(p, MAXPATHLEN);
+ ST(0) = sv_newmortal();
+ sv_setpv((SV*)ST(0), RETVAL);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_abspath)
+{
+ dXSARGS;
+ if (items < 1 || items > 2)
+ Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
+ {
+ STRLEN n_a;
+ char * path = (char *)SvPV(ST(0),n_a);
+ char * dir, *s, *t, *e;
+ char p[MAXPATHLEN];
+ char * RETVAL;
+ int l;
+ SV *sv;
+
+ if (items < 2)
+ dir = NULL;
+ else {
+ dir = (char *)SvPV(ST(1),n_a);
+ }
+ if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
+ path += 2;
+ }
+ if (dir == NULL) {
+ if (_abspath(p, path, MAXPATHLEN) == 0) {
+ RETVAL = p;
+ } else {
+ RETVAL = NULL;
+ }
+ } else {
+ /* Absolute with drive: */
+ if ( sys_is_absolute(path) ) {
+ if (_abspath(p, path, MAXPATHLEN) == 0) {
+ RETVAL = p;
+ } else {
+ RETVAL = NULL;
+ }
+ } else if (path[0] == '/' || path[0] == '\\') {
+ /* Rooted, but maybe on different drive. */
+ if (isALPHA(dir[0]) && dir[1] == ':' ) {
+ char p1[MAXPATHLEN];
+
+ /* Need to prepend the drive. */
+ p1[0] = dir[0];
+ p1[1] = dir[1];
+ Copy(path, p1 + 2, strlen(path) + 1, char);
+ RETVAL = p;
+ if (_abspath(p, p1, MAXPATHLEN) == 0) {
+ RETVAL = p;
+ } else {
+ RETVAL = NULL;
+ }
+ } else if (_abspath(p, path, MAXPATHLEN) == 0) {
+ RETVAL = p;
+ } else {
+ RETVAL = NULL;
+ }
+ } else {
+ /* Either path is relative, or starts with a drive letter. */
+ /* If the path starts with a drive letter, then dir is
+ relevant only if
+ a/b) it is absolute/x:relative on the same drive.
+ c) path is on current drive, and dir is rooted
+ In all the cases it is safe to drop the drive part
+ of the path. */
+ if ( !sys_is_relative(path) ) {
+ if ( ( ( sys_is_absolute(dir)
+ || (isALPHA(dir[0]) && dir[1] == ':'
+ && strnicmp(dir, path,1) == 0))
+ && strnicmp(dir, path,1) == 0)
+ || ( !(isALPHA(dir[0]) && dir[1] == ':')
+ && toupper(path[0]) == current_drive())) {
+ path += 2;
+ } else if (_abspath(p, path, MAXPATHLEN) == 0) {
+ RETVAL = p; goto done;
+ } else {
+ RETVAL = NULL; goto done;
+ }
+ }
+ {
+ /* Need to prepend the absolute path of dir. */
+ char p1[MAXPATHLEN];
+
+ if (_abspath(p1, dir, MAXPATHLEN) == 0) {
+ int l = strlen(p1);
+
+ if (p1[ l - 1 ] != '/') {
+ p1[ l ] = '/';
+ l++;
+ }
+ Copy(path, p1 + l, strlen(path) + 1, char);
+ if (_abspath(p, p1, MAXPATHLEN) == 0) {
+ RETVAL = p;
+ } else {
+ RETVAL = NULL;
+ }
+ } else {
+ RETVAL = NULL;
+ }
+ }
+ 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_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);
+}
+typedef APIRET (*PELP)(PSZ path, ULONG type);
+
+/* Kernels after 2000/09/15 understand this too: */
+#ifndef LIBPATHSTRICT
+# define LIBPATHSTRICT 3
+#endif
+
+APIRET
+ExtLIBPATH(ULONG ord, PSZ path, IV type)
+{
+ ULONG what;
+ PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */
+
+ if (type > 0)
+ what = END_LIBPATH;
+ else if (type == 0)
+ what = BEGIN_LIBPATH;
+ else
+ what = LIBPATHSTRICT;
+ return (*(PELP)f)(path, what);
+}
+
+#define extLibpath(to,type) \
+ (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
+
+#define extLibpath_set(p,type) \
+ (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
+
+XS(XS_Cwd_extLibpath)
+{
+ dXSARGS;
+ if (items < 0 || items > 1)
+ Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
+ {
+ IV type;
+ char to[1024];
+ U32 rc;
+ char * RETVAL;
+
+ if (items < 1)
+ type = 0;
+ else {
+ type = SvIV(ST(0));
+ }
+
+ to[0] = 1; to[1] = 0; /* Sometimes no error reported */
+ RETVAL = extLibpath(to, type);
+ if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
+ Perl_croak_nocontext("panic Cwd::extLibpath parameter");
+ ST(0) = sv_newmortal();
+ sv_setpv((SV*)ST(0), RETVAL);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_extLibpath_set)
+{
+ dXSARGS;
+ if (items < 1 || items > 2)
+ Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
+ {
+ STRLEN n_a;
+ char * s = (char *)SvPV(ST(0),n_a);
+ IV type;
+ U32 rc;
+ bool RETVAL;
+
+ if (items < 2)
+ type = 0;
+ else {
+ type = SvIV(ST(1));
+ }
+
+ RETVAL = extLibpath_set(s, type);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ 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)
+{
+ char *file = __FILE__;
+ {
+ GV *gv;
+
+ if (_emx_env & 0x200) { /* OS/2 */
+ newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
+ newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
+ newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
+ }
+ newXS("OS2::Error", XS_OS2_Error, file);
+ newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
+ newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
+ newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
+ newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
+ newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
+ newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
+ newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
+ newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
+ newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
+ newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
+ newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
+ newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
+ newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
+ newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
+ newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
+ newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
+ 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
+ sv_setiv(GvSV(gv), 1);
+#endif
+ gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setiv(GvSV(gv), exe_is_aout());
+ gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setiv(GvSV(gv), _emx_rev);
+ sv_setpv(GvSV(gv), _emx_vprt);
+ SvIOK_on(GvSV(gv));
+ gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setiv(GvSV(gv), _emx_env);
+ gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
+ gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
+ }
+ return 0;
+}
+
+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 emx_init(), since it moves the stack pointer */
+ /* It also 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) { /* 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;
+ }
+ 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;
+ if ( (shell = getenv("PERL_SH_DRIVE")) ) {
+ New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
+ strcpy(PL_sh_path, SH_PATH);
+ PL_sh_path[0] = shell[0];
+ } else if ( (shell = getenv("PERL_SH_DIR")) ) {
+ int l = strlen(shell), i;
+ if (shell[l-1] == '/' || shell[l-1] == '\\') {
+ l--;
+ }
+ New(1304, PL_sh_path, l + 8, char);
+ strncpy(PL_sh_path, shell, l);
+ strcpy(PL_sh_path + l, "/sh.exe");
+ for (i = 0; i < l; i++) {
+ if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
+ }
+ }
+ 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
+#undef tmpfile
+
+char *
+my_tmpnam (char *str)
+{
+ char *p = getenv("TMP"), *tpath;
+
+ if (!p) p = getenv("TEMP");
+ tpath = tempnam(p, "pltmp");
+ if (str && tpath) {
+ strcpy(str, tpath);
+ return str;
+ }
+ return tpath;
+}
+
+FILE *
+my_tmpfile ()
+{
+ struct stat s;
+
+ stat(".", &s);
+ if (s.st_mode & S_IWOTH) {
+ return tmpfile();
+ }
+ return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
+ 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. */
+int
+my_flock(int handle, int o)
+{
+ FILELOCK rNull, rFull;
+ ULONG timeout, handle_type, flag_word;
+ APIRET rc;
+ int blocking, shared;
+ static int use_my = -1;
+
+ if (use_my == -1) {
+ char *s = getenv("USE_PERL_FLOCK");
+ if (s)
+ use_my = atoi(s);
+ else
+ use_my = 1;
+ }
+ if (!(_emx_env & 0x200) || !use_my)
+ return flock(handle, o); /* Delegate to EMX. */
+
+ // is this a file?
+ if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
+ (handle_type & 0xFF))
+ {
+ errno = EBADF;
+ return -1;
+ }
+ // set lock/unlock ranges
+ rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
+ rFull.lRange = 0x7FFFFFFF;
+ // set timeout for blocking
+ timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
+ // shared or exclusive?
+ shared = (o & LOCK_SH) ? 1 : 0;
+ // do not block the unlock
+ if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
+ rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
+ switch (rc) {
+ case 0:
+ errno = 0;
+ return 0;
+ case ERROR_INVALID_HANDLE:
+ errno = EBADF;
+ return -1;
+ case ERROR_SHARING_BUFFER_EXCEEDED:
+ errno = ENOLCK;
+ return -1;
+ case ERROR_LOCK_VIOLATION:
+ break; // not an error
+ case ERROR_INVALID_PARAMETER:
+ case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
+ case ERROR_READ_LOCKS_NOT_SUPPORTED:
+ errno = EINVAL;
+ return -1;
+ case ERROR_INTERRUPT:
+ errno = EINTR;
+ return -1;
+ default:
+ errno = EINVAL;
+ return -1;
+ }
+ }
+ // lock may block
+ if (o & (LOCK_SH | LOCK_EX)) {
+ // for blocking operations
+ for (;;) {
+ rc =
+ DosSetFileLocks(
+ handle,
+ &rNull,
+ &rFull,
+ timeout,
+ shared
+ );
+ switch (rc) {
+ case 0:
+ errno = 0;
+ return 0;
+ case ERROR_INVALID_HANDLE:
+ errno = EBADF;
+ return -1;
+ case ERROR_SHARING_BUFFER_EXCEEDED:
+ errno = ENOLCK;
+ return -1;
+ case ERROR_LOCK_VIOLATION:
+ if (!blocking) {
+ errno = EWOULDBLOCK;
+ return -1;
+ }
+ break;
+ case ERROR_INVALID_PARAMETER:
+ case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
+ case ERROR_READ_LOCKS_NOT_SUPPORTED:
+ errno = EINVAL;
+ return -1;
+ case ERROR_INTERRUPT:
+ errno = EINTR;
+ return -1;
+ default:
+ errno = EINVAL;
+ return -1;
+ }
+ // 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));
+}
https://perl5.git.perl.org / perl5.git / blobdiff