/repo: perl-5.22.2/os2/os2.c comparison

comparison perl-5.22.2/os2/os2.c @ 8045:a16537d2fe07

<xfix> tar xf perl-5.22.2.tar.gz # Ah, whatever, I\'m doing it anyway

author	HackBot
date	Sat, 14 May 2016 14:54:38 +0000
parents
children

comparison

equal deleted inserted replaced

-:711c038a7dce
+:a16537d2fe07
+#define INCL_DOS
+#define INCL_NOPM
+#define INCL_DOSFILEMGR
+#define INCL_DOSMEMMGR
+#define INCL_DOSERRORS
+#define INCL_WINERRORS
+#define INCL_WINSYS
+/* 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 <emx/syscalls.h>
+#include <sys/emxload.h>
+#include <sys/uflags.h>
+/*
+* Various Unix compatibility functions for OS/2
+*/
+#include <stdio.h>
+#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"
+enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full,
+mod_name_C_function = 0x100, mod_name_HMODULE = 0x200};
+/* Find module name to which *this* subroutine is compiled */
+#define module_name(how)	module_name_at(&module_name_at, how)
+static SV* module_name_at(void *pp, enum module_name_how how);
+void
+croak_with_os2error(char *s)
+{
+Perl_croak_nocontext("%s: %s", s, os2error(Perl_rc));
+}
+struct PMWIN_entries_t PMWIN_entries;
+/*****************************************************************************/
+/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
+struct dll_handle_t {
+const char *modname;
+HMODULE handle;
+int requires_pm;
+};
+static struct dll_handle_t dll_handles[] = {
+{"doscalls", 0, 0},
+{"tcp32dll", 0, 0},
+{"pmwin", 0, 1},
+{"rexx", 0, 0},
+{"rexxapi", 0, 0},
+{"sesmgr", 0, 0},
+{"pmshapi", 0, 1},
+{"pmwp", 0, 1},
+{"pmgpi", 0, 1},
+{NULL, 0},
+};
+enum dll_handle_e {
+dll_handle_doscalls,
+dll_handle_tcp32dll,
+dll_handle_pmwin,
+dll_handle_rexx,
+dll_handle_rexxapi,
+dll_handle_sesmgr,
+dll_handle_pmshapi,
+dll_handle_pmwp,
+dll_handle_pmgpi,
+dll_handle_LAST,
+};
+#define doscalls_handle		(dll_handles[dll_handle_doscalls])
+#define tcp_handle		(dll_handles[dll_handle_tcp32dll])
+#define pmwin_handle		(dll_handles[dll_handle_pmwin])
+#define rexx_handle		(dll_handles[dll_handle_rexx])
+#define rexxapi_handle		(dll_handles[dll_handle_rexxapi])
+#define sesmgr_handle		(dll_handles[dll_handle_sesmgr])
+#define pmshapi_handle		(dll_handles[dll_handle_pmshapi])
+#define pmwp_handle		(dll_handles[dll_handle_pmwp])
+#define pmgpi_handle		(dll_handles[dll_handle_pmgpi])
+/*  The following local-scope data is not yet included:
+fargs.140			// const => OK
+ino.165				// locked - and the access is almost cosmetic
+layout_table.260			// startup only, locked
+osv_res.257			// startup only, locked
+old_esp.254			// startup only, locked
+priors				// const ==> OK
+use_my_flock.283			// locked
+emx_init_done.268		// locked
+dll_handles			// locked
+hmtx_emx_init.267		// THIS is the lock for startup
+perlos2_state_mutex		// THIS is the lock for all the rest
+BAD:
+perlos2_state			// see below
+*/
+/*  The following global-scope data is not yet included:
+OS2_Perl_data
+pthreads_states			// const now?
+start_thread_mutex
+thread_join_count		// protected
+thread_join_data			// protected
+tmppath
+pDosVerifyPidTid
+Perl_OS2_init3() - should it be protected?
+*/
+OS2_Perl_data_t OS2_Perl_data;
+static struct perlos2_state_t {
+int po2__my_pwent;				/* = -1; */
+int po2_DOS_harderr_state;			/* = -1;    */
+signed char po2_DOS_suppression_state;	/* = -1;    */
+PFN po2_ExtFCN[ORD_NENTRIES];	/* Labeled by ord ORD_*. */
+/*  struct PMWIN_entries_t po2_PMWIN_entries; */
+int po2_emx_wasnt_initialized;
+char po2_fname[9];
+int po2_rmq_cnt;
+int po2_grent_cnt;
+char *po2_newp;
+char *po2_oldp;
+int po2_newl;
+int po2_oldl;
+int po2_notfound;
+char po2_mangle_ret[STATIC_FILE_LENGTH+1];
+ULONG po2_os2_dll_fake;
+ULONG po2_os2_mytype;
+ULONG po2_os2_mytype_ini;
+int po2_pidtid_lookup;
+struct passwd po2_pw;
+int po2_pwent_cnt;
+char po2_pthreads_state_buf[80];
+char po2_os2error_buf[300];
+/* 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? */
+int po2_spawn_pid;
+int po2_spawn_killed;
+jmp_buf po2_at_exit_buf;
+int po2_longjmp_at_exit;
+int po2_emx_runtime_init;		/* If 1, we need to manually init it */
+int po2_emx_exception_init;		/* If 1, we need to manually set it */
+int po2_emx_runtime_secondary;
+char* (*po2_perllib_mangle_installed)(char *s, unsigned int l);
+char* po2_perl_sh_installed;
+PGINFOSEG po2_gTable;
+PLINFOSEG po2_lTable;
+} perlos2_state = {
+-1,					/* po2__my_pwent */
+-1,					/* po2_DOS_harderr_state */
+-1,					/* po2_DOS_suppression_state */
+};
+#define Perl_po2()		(&perlos2_state)
+#define ExtFCN			(Perl_po2()->po2_ExtFCN)
+/* #define PMWIN_entries		(Perl_po2()->po2_PMWIN_entries) */
+#define emx_wasnt_initialized	(Perl_po2()->po2_emx_wasnt_initialized)
+#define fname			(Perl_po2()->po2_fname)
+#define rmq_cnt			(Perl_po2()->po2_rmq_cnt)
+#define grent_cnt		(Perl_po2()->po2_grent_cnt)
+#define newp			(Perl_po2()->po2_newp)
+#define oldp			(Perl_po2()->po2_oldp)
+#define newl			(Perl_po2()->po2_newl)
+#define oldl			(Perl_po2()->po2_oldl)
+#define notfound		(Perl_po2()->po2_notfound)
+#define mangle_ret		(Perl_po2()->po2_mangle_ret)
+#define os2_dll_fake		(Perl_po2()->po2_os2_dll_fake)
+#define os2_mytype		(Perl_po2()->po2_os2_mytype)
+#define os2_mytype_ini		(Perl_po2()->po2_os2_mytype_ini)
+#define pidtid_lookup		(Perl_po2()->po2_pidtid_lookup)
+#define pw			(Perl_po2()->po2_pw)
+#define pwent_cnt		(Perl_po2()->po2_pwent_cnt)
+#define _my_pwent		(Perl_po2()->po2__my_pwent)
+#define pthreads_state_buf	(Perl_po2()->po2_pthreads_state_buf)
+#define os2error_buf		(Perl_po2()->po2_os2error_buf)
+/* 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? */
+#define spawn_pid		(Perl_po2()->po2_spawn_pid)
+#define spawn_killed		(Perl_po2()->po2_spawn_killed)
+#define DOS_harderr_state	(Perl_po2()->po2_DOS_harderr_state)
+#define DOS_suppression_state		(Perl_po2()->po2_DOS_suppression_state)
+#define at_exit_buf		(Perl_po2()->po2_at_exit_buf)
+#define longjmp_at_exit		(Perl_po2()->po2_longjmp_at_exit)
+#define emx_runtime_init	(Perl_po2()->po2_emx_runtime_init)
+#define emx_exception_init	(Perl_po2()->po2_emx_exception_init)
+#define emx_runtime_secondary	(Perl_po2()->po2_emx_runtime_secondary)
+#define perllib_mangle_installed	(Perl_po2()->po2_perllib_mangle_installed)
+#define perl_sh_installed	(Perl_po2()->po2_perl_sh_installed)
+#define gTable			(Perl_po2()->po2_gTable)
+#define lTable			(Perl_po2()->po2_lTable)
+const Perl_PFN * const pExtFCN = (Perl_po2()->po2_ExtFCN);
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
+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,
+pthreads_st_norun,
+pthreads_st_exited_waited,
+};
+const char * const pthreads_states[] = {
+"uninit",
+"running",
+"exited",
+"detached",
+"waited for",
+"could not start",
+"exited, then waited on",
+};
+enum pthread_exists { pthread_not_existant = -0xff };
+static const char*
+pthreads_state_string(enum pthreads_state state)
+{
+if (state < 0 || state >= sizeof(pthreads_states)/sizeof(*pthreads_states)) {
+snprintf(pthreads_state_buf, sizeof(pthreads_state_buf),
+	     "unknown thread state %d", (int)state);
+return pthreads_state_buf;
+}
+return pthreads_states[state];
+}
+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;
+static perl_mutex perlos2_state_mutex;
+int
+pthread_join(perl_os_thread tid, void **status)
+{
+MUTEX_LOCK(&start_thread_mutex);
+if (tid < 1 || tid >= thread_join_count) {
+	MUTEX_UNLOCK(&start_thread_mutex);
+	if (tid != pthread_not_existant)
+	    Perl_croak_nocontext("panic: join with a thread with strange ordinal %d", (int)tid);
+	Perl_warn_nocontext("panic: join with a thread which could not start");
+	*status = 0;
+	return 0;
+}
+switch (thread_join_data[tid].state) {
+case pthreads_st_exited:
+	thread_join_data[tid].state = pthreads_st_exited_waited;
+	*status = thread_join_data[tid].status;
+	MUTEX_UNLOCK(&start_thread_mutex);
+	COND_SIGNAL(&thread_join_data[tid].cond);
+	break;
+case pthreads_st_waited:
+	MUTEX_UNLOCK(&start_thread_mutex);
+	Perl_croak_nocontext("join with a thread with a waiter");
+	break;
+case pthreads_st_norun:
+{
+	int state = (int)thread_join_data[tid].status;
+	thread_join_data[tid].state = pthreads_st_none;
+	MUTEX_UNLOCK(&start_thread_mutex);
+	Perl_croak_nocontext("panic: join with a thread which could not run"
+			     " due to attempt of tid reuse (state='%s')",
+			     pthreads_state_string(state));
+	break;
+}
+case pthreads_st_run:
+{
+	perl_cond cond;
+	thread_join_data[tid].state = pthreads_st_waited;
+	thread_join_data[tid].status = (void *)status;
+	COND_INIT(&thread_join_data[tid].cond);
+	cond = thread_join_data[tid].cond;
+	COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
+	COND_DESTROY(&cond);
+	MUTEX_UNLOCK(&start_thread_mutex);
+	break;
+}
+default:
+	MUTEX_UNLOCK(&start_thread_mutex);
+	Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'",
+	      pthreads_state_string(thread_join_data[tid].state));
+	break;
+}
+return 0;
+}
+typedef struct {
+pthreads_startroutine sub;
+void *arg;
+void *ctx;
+} pthr_startit;
+/* The lock is used:
+	a) Since we temporarily usurp the caller interp, so malloc() may
+	   use it to decide on debugging the call;
+	b) Since *args is on the caller's stack.
+*/
+void
+pthread_startit(void *arg1)
+{
+/* Thread is already started, we need to transfer control only */
+pthr_startit args = *(pthr_startit *)arg1;
+int tid = pthread_self();
+void *rc;
+int state;
+if (tid <= 1) {
+	/* Can't croak, the setjmp() is not in scope... */
+	char buf[80];
+	snprintf(buf, sizeof(buf),
+		 "panic: thread with strange ordinal %d created\n\r", tid);
+	write(2,buf,strlen(buf));
+	MUTEX_UNLOCK(&start_thread_mutex);
+	return;
+}
+/* Until args.sub resets it, makes debugging Perl_malloc() work: */
+PERL_SET_CONTEXT(0);
+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 {
+	    Newxz(thread_join_data, thread_join_count, thread_join_t);
+	}
+}
+if (thread_join_data[tid].state != pthreads_st_none) {
+	/* Can't croak, the setjmp() is not in scope... */
+	char buf[80];
+	snprintf(buf, sizeof(buf),
+		 "panic: attempt to reuse thread id %d (state='%s')\n\r",
+		 tid, pthreads_state_string(thread_join_data[tid].state));
+	write(2,buf,strlen(buf));
+	thread_join_data[tid].status = (void*)thread_join_data[tid].state;
+	thread_join_data[tid].state = pthreads_st_norun;
+	MUTEX_UNLOCK(&start_thread_mutex);
+	return;
+}
+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);
+rc = (*args.sub)(args.arg);
+MUTEX_LOCK(&start_thread_mutex);
+switch (thread_join_data[tid].state) {
+case pthreads_st_waited:
+	COND_SIGNAL(&thread_join_data[tid].cond);
+	thread_join_data[tid].state = pthreads_st_none;
+	*((void**)thread_join_data[tid].status) = rc;
+	break;
+case pthreads_st_detached:
+	thread_join_data[tid].state = pthreads_st_none;
+	break;
+case pthreads_st_run:
+	/* Somebody can wait on us; cannot exit, since OS can reuse the tid
+	   and our waiter will get somebody else's status. */
+	thread_join_data[tid].state = pthreads_st_exited;
+	thread_join_data[tid].status = rc;
+	COND_INIT(&thread_join_data[tid].cond);
+	COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
+	COND_DESTROY(&thread_join_data[tid].cond);
+	thread_join_data[tid].state = pthreads_st_none;	/* Ready to reuse */
+	break;
+default:
+	state = thread_join_data[tid].state;
+	MUTEX_UNLOCK(&start_thread_mutex);
+	Perl_croak_nocontext("panic: unexpected thread state on exit: '%s'",
+			     pthreads_state_string(state));
+}
+MUTEX_UNLOCK(&start_thread_mutex);
+}
+int
+pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr,
+	       void *(*start_routine)(void*), void *arg)
+{
+dTHX;
+pthr_startit args;
+args.sub = (void*)start_routine;
+args.arg = arg;
+args.ctx = PERL_GET_CONTEXT;
+MUTEX_LOCK(&start_thread_mutex);
+/* Test suite creates 31 extra threads;
+on machine without shared-memory-hogs this stack sizeis OK with 31: */
+*tidp = _beginthread(pthread_startit, /*stack*/ NULL,
+			 /*stacksize*/ 4*1024*1024, (void*)&args);
+if (*tidp == -1) {
+	*tidp = pthread_not_existant;
+	MUTEX_UNLOCK(&start_thread_mutex);
+	return EINVAL;
+}
+MUTEX_LOCK(&start_thread_mutex);		/* Wait for init to proceed */
+MUTEX_UNLOCK(&start_thread_mutex);
+return 0;
+}
+int
+pthread_detach(perl_os_thread tid)
+{
+MUTEX_LOCK(&start_thread_mutex);
+if (tid < 1 || tid >= thread_join_count) {
+	MUTEX_UNLOCK(&start_thread_mutex);
+	if (tid != pthread_not_existant)
+	    Perl_croak_nocontext("panic: detach of a thread with strange ordinal %d", (int)tid);
+	Perl_warn_nocontext("detach of a thread which could not start");
+	return 0;
+}
+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;
+case pthreads_st_exited:
+	MUTEX_UNLOCK(&start_thread_mutex);
+	COND_SIGNAL(&thread_join_data[tid].cond);
+	break;
+case pthreads_st_detached:
+	MUTEX_UNLOCK(&start_thread_mutex);
+	Perl_warn_nocontext("detach on an already detached thread");
+	break;
+case pthreads_st_norun:
+{
+	int state = (int)thread_join_data[tid].status;
+	thread_join_data[tid].state = pthreads_st_none;
+	MUTEX_UNLOCK(&start_thread_mutex);
+	Perl_croak_nocontext("panic: detaching thread which could not run"
+			     " due to attempt of tid reuse (state='%s')",
+			     pthreads_state_string(state));
+	break;
+}
+default:
+	MUTEX_UNLOCK(&start_thread_mutex);
+	Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'",
+	      pthreads_state_string(thread_join_data[tid].state));
+	break;
+}
+return 0;
+}
+/* This is a very bastardized version; may be OK due to edge trigger of Wait */
+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_rc = CheckOSError(rc), croak_with_os2error("panic: COND_WAIT-reset");
+if (m) MUTEX_UNLOCK(m);
+if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
+	&& (rc != ERROR_INTERRUPT))
+	croak_with_os2error("panic: COND_WAIT");
+if (rc == ERROR_INTERRUPT)
+	errno = EINTR;
+if (m) MUTEX_LOCK(m);
+return 0;
+}
+#endif
+static int exe_is_aout(void);
+/* This should match enum entries_ordinals defined in os2ish.h. */
+static const struct {
+struct dll_handle_t *dll;
+const char *entryname;
+int entrypoint;
+} loadOrdinals[] = {
+{&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 */
+{&doscalls_handle, NULL, 582},	/* Dos32QueryHeaderInfo */
+{&doscalls_handle, NULL, 362},	/* DosTmrQueryFreq */
+{&doscalls_handle, NULL, 363},	/* DosTmrQueryTime */
+{&pmwp_handle, NULL, 262},		/* WinQueryActiveDesktopPathname */
+{&pmwin_handle, NULL, 765},		/* WinInvalidateRect */
+{&pmwin_handle, NULL, 906},		/* WinCreateFrameControl */
+{&pmwin_handle, NULL, 807},		/* WinQueryClipbrdFmtInfo */
+{&pmwin_handle, NULL, 808},		/* WinQueryClipbrdOwner */
+{&pmwin_handle, NULL, 809},		/* WinQueryClipbrdViewer */
+{&pmwin_handle, NULL, 806},		/* WinQueryClipbrdData */
+{&pmwin_handle, NULL, 793},		/* WinOpenClipbrd */
+{&pmwin_handle, NULL, 707},		/* WinCloseClipbrd */
+{&pmwin_handle, NULL, 854},		/* WinSetClipbrdData */
+{&pmwin_handle, NULL, 855},		/* WinSetClipbrdOwner */
+{&pmwin_handle, NULL, 856},		/* WinSetClipbrdViewer */
+{&pmwin_handle, NULL, 739},		/* WinEnumClipbrdFmts  */
+{&pmwin_handle, NULL, 733},		/* WinEmptyClipbrd */
+{&pmwin_handle, NULL, 700},		/* WinAddAtom */
+{&pmwin_handle, NULL, 744},		/* WinFindAtom */
+{&pmwin_handle, NULL, 721},		/* WinDeleteAtom */
+{&pmwin_handle, NULL, 803},		/* WinQueryAtomUsage */
+{&pmwin_handle, NULL, 802},		/* WinQueryAtomName */
+{&pmwin_handle, NULL, 801},		/* WinQueryAtomLength */
+{&pmwin_handle, NULL, 830},		/* WinQuerySystemAtomTable */
+{&pmwin_handle, NULL, 714},		/* WinCreateAtomTable */
+{&pmwin_handle, NULL, 724},		/* WinDestroyAtomTable */
+{&pmwin_handle, NULL, 794},		/* WinOpenWindowDC */
+{&pmgpi_handle, NULL, 610},		/* DevOpenDC */
+{&pmgpi_handle, NULL, 606},		/* DevQueryCaps */
+{&pmgpi_handle, NULL, 604},		/* DevCloseDC */
+{&pmwin_handle, NULL, 789},		/* WinMessageBox */
+{&pmwin_handle, NULL, 1015},		/* WinMessageBox2 */
+{&pmwin_handle, NULL, 829},		/* WinQuerySysValue */
+{&pmwin_handle, NULL, 873},		/* WinSetSysValue */
+{&pmwin_handle, NULL, 701},		/* WinAlarm */
+{&pmwin_handle, NULL, 745},		/* WinFlashWindow */
+{&pmwin_handle, NULL, 780},		/* WinLoadPointer */
+{&pmwin_handle, NULL, 828},		/* WinQuerySysPointer */
+{&doscalls_handle, NULL, 417},	/* DosReplaceModule */
+{&doscalls_handle, NULL, 976},	/* DosPerfSysCall */
+{&rexxapi_handle, "RexxRegisterSubcomExe", 0},
+};
+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;
+}
+/* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
+static int
+my_type()
+{
+int rc;
+TIB *tib;
+PIB *pib;
+if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
+if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
+	return -1;
+return (pib->pib_ultype);
+}
+static void
+my_type_set(int type)
+{
+int rc;
+TIB *tib;
+PIB *pib;
+if (!(_emx_env & 0x200))
+	Perl_croak_nocontext("Can't set type on DOS"); /* not OS/2. */
+if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
+	croak_with_os2error("Error getting info blocks");
+pib->pib_ultype = type;
+}
+PFN
+loadByOrdinal(enum entries_ordinals ord, int fail)
+{
+if (sizeof(loadOrdinals)/sizeof(loadOrdinals[0]) != ORD_NENTRIES)
+	    Perl_croak_nocontext(
+		 "Wrong size of loadOrdinals array: expected %d, actual %d",
+		 sizeof(loadOrdinals)/sizeof(loadOrdinals[0]), ORD_NENTRIES);
+if (ExtFCN[ord] == NULL) {
+	PFN fcn = (PFN)-1;
+	APIRET rc;
+	if (!loadOrdinals[ord].dll->handle) {
+	    if (loadOrdinals[ord].dll->requires_pm && my_type() < 2) { /* FS */
+		char *s = getenv("PERL_ASIF_PM");
+		if (!s || !atoi(s)) {
+		    /* The module will not function well without PM.
+		       The usual way to detect PM is the existence of the mutex
+		       \SEM32\PMDRAG.SEM. */
+		    HMTX hMtx = 0;
+		    if (CheckOSError(DosOpenMutexSem("\\SEM32\\PMDRAG.SEM",
+						     &hMtx)))
+			Perl_croak_nocontext("Looks like we have no PM; will not load DLL %s without $ENV{PERL_ASIF_PM}",
+					     loadOrdinals[ord].dll->modname);
+		    DosCloseMutexSem(hMtx);
+		}
+	    }
+	    MUTEX_LOCK(&perlos2_state_mutex);
+	    loadOrdinals[ord].dll->handle
+		= loadModule(loadOrdinals[ord].dll->modname, fail);
+	    MUTEX_UNLOCK(&perlos2_state_mutex);
+	}
+	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 const signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
+						     self inverse. */
+#define QSS_INI_BUFFER 1024
+ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
+PQTOPLEVEL
+get_sysinfo(ULONG pid, ULONG flags)
+{
+char *pbuffer;
+ULONG rc, buf_len = QSS_INI_BUFFER;
+PQTOPLEVEL psi;
+if (pid) {
+	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;
+}
+}
+Newx(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(flags, pid, pbuffer, buf_len);
+}
+if (rc) {
+	FillOSError(rc);
+	Safefree(pbuffer);
+	return 0;
+}
+psi = (PQTOPLEVEL)pbuffer;
+if (psi && pid && psi->procdata && pid != psi->procdata->pid) {
+Safefree(psi);
+Perl_croak_nocontext("panic: wrong pid in sysinfo");
+}
+return psi;
+}
+#define PRIO_ERR 0x1111
+static ULONG
+sys_prio(pid)
+{
+ULONG prio;
+PQTOPLEVEL psi;
+if (!pid)
+return PRIO_ERR;
+psi = get_sysinfo(pid, QSS_PROCESS);
+if (!psi)
+return PRIO_ERR;
+prio = psi->procdata->threads->priority;
+Safefree(psi);
+return prio;
+}
+int
+setpriority(int which, int pid, int val)
+{
+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)
+					 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
+					 0,
+					 (32 - val) % 32 - (prio & 0xFF),
+					 abs(pid)))
+? -1 : 0;
+} else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
+/* Documentation claims one can change both class and basevalue,
+* but I find it wrong. */
+/* Change class, but since delta == 0 denotes absolute 0, correct. */
+if (CheckOSError(DosSetPriority((pid < 0)
+				      ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
+				      priors[(32 - val) >> 5] + 1,
+				      0,
+				      abs(pid))))
+	  return -1;
+if ( ((32 - val) % 32) == 0 ) return 0;
+return CheckOSError(DosSetPriority((pid < 0)
+					 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
+					 0,
+					 (32 - val) % 32,
+					 abs(pid)))
+	  ? -1 : 0;
+}
+}
+int
+getpriority(int which /* ignored */, int pid)
+{
+ULONG ret;
+if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
+ret = sys_prio(pid);
+if (ret == PRIO_ERR) {
+return -1;
+}
+return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
+}
+/*****************************************************************************/
+/* spawn */
+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(pTHX_ int flag, int pid)
+{
+	int r, status;
+	Signal_t (*ihand)();     /* place to save signal during system() */
+	Signal_t (*qhand)();     /* place to save signal during system() */
+#ifndef __EMX__
+	RESULTCODES res;
+	int rpid;
+#endif
+	if (pid < 0 || flag != 0)
+		return pid;
+#ifdef __EMX__
+	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);
+	rsignal(SIGINT, ihand);
+	rsignal(SIGQUIT, qhand);
+	PL_statusvalue = (U16)status;
+	if (r < 0)
+		return -1;
+	return status & 0xFFFF;
+#else
+	ihand = rsignal(SIGINT, SIG_IGN);
+	r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
+	rsignal(SIGINT, ihand);
+	PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
+	if (r)
+		return -1;
+	return PL_statusvalue;
+#endif
+}
+enum execf_t {
+EXECF_SPAWN,
+EXECF_EXEC,
+EXECF_TRUEEXEC,
+EXECF_SPAWN_NOWAIT,
+EXECF_SPAWN_BYFLAG,
+EXECF_SYNC
+};
+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;
+}
+/* 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 *real_name = NULL;			/* Shut down the warning */
+	char const * args[4];
+	static const char * const fargs[4]
+	    = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
+	const char * const *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 (really && !*(real_name = SvPV(really, n_a)))
+	    really = NULL;
+retry:
+	if (strEQ(PL_Argv[0],"/bin/sh"))
+	    PL_Argv[0] = PL_sh_path;
+	/* We should check PERL_SH* and PERLLIB_* as well? */
+	if (!really || pass >= 2)
+	    real_name = PL_Argv[0];
+	if (real_name[0] != '/' && real_name[0] != '\\'
+	    && !(real_name[0] && real_name[1] == ':'
+		 && (real_name[2] == '/' || real_name[2] != '\\'))
+	    ) /* will spawnvp use PATH? */
+	    TAINT_ENV();	/* testing IFS here is overkill, probably */
+reread:
+	force_shell = 0;
+	if (_emx_env & 0x200) { /* OS/2. */
+	    int type = file_type(real_name);
+	  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(real_name);
+		if (l + 5 <= sizeof tbuf) {
+		    strcpy(tbuf, real_name);
+		    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:
+	    {	/* Apparently, kids are started basing on startup type, not the morphed type */
+		if (os2_mytype != 3) {	/* not PM */
+		    if (flag == P_NOWAIT)
+			flag = P_PM;
+		    else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
+			Perl_warner(aTHX_ packWARN(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 && ckWARN(WARN_EXEC))
+			Perl_warner(aTHX_ packWARN(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 (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,real_name,PL_Argv));
+#else
+	if (execf == EXECF_TRUEEXEC)
+	    rc = execvp(real_name,PL_Argv);
+	else if (execf == EXECF_EXEC)
+	    rc = spawnvp(trueflag | P_OVERLAY,real_name,PL_Argv);
+	else if (execf == EXECF_SPAWN_NOWAIT)
+	    rc = spawnvp(flag,real_name,PL_Argv);
+else if (execf == EXECF_SYNC)
+	    rc = spawnvp(trueflag,real_name,PL_Argv);
+else				/* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
+	    rc = result(aTHX_ trueflag,
+			spawnvp(flag,real_name,PL_Argv));
+#endif
+	if (rc < 0 && pass == 1) {
+	      do_script:
+	  if (real_name == PL_Argv[0]) {
+	    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");
+	                PL_Argv[0] = scr = SvPV(scrsv, n_a);	/* Reload */
+			if (PerlLIO_stat(scr,&PL_statbuf) >= 0
+			    && !S_ISDIR(PL_statbuf.st_mode)) {	/* Found */
+				real_name = scr;
+				pass++;
+				goto reread;
+			} else {		/* Restore */
+				SvCUR_set(scrsv, SvCUR(scrsv) - 4);
+				*SvEND(scrsv) = 0;
+			}
+		    }
+		    if (PerlIO_close(file) != 0) { /* Failure */
+		      panic_file:
+			if (ckWARN(WARN_EXEC))
+			   Perl_warner(aTHX_ packWARN(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_ 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;
+			const 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] = NULL;
+			    }
+			} 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] = NULL;
+			    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) /* XXXX Discard const... */
+			    PL_Argv[nargs] = (char*)argsp[nargs];
+			/* Enable pathless exec if #! (as pdksh). */
+			pass = (buf[0] == '#' ? 2 : 3);
+			goto retry;
+		    }
+		}
+		/* Not found: restore errno */
+		errno = err;
+	    }
+	  } else if (errno == ENOEXEC) { /* Cannot transfer `real_name' via shell. */
+		if (rc < 0 && ckWARN(WARN_EXEC))
+		    Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s script `%s' with ARGV[0] being `%s'",
+			 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
+			  ? "spawn" : "exec"),
+			 real_name, PL_Argv[0]);
+		goto warned;
+	  } else if (errno == ENOENT) { /* Cannot transfer `real_name' via shell. */
+		if (rc < 0 && ckWARN(WARN_EXEC))
+		    Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)",
+			 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
+			  ? "spawn" : "exec"),
+			 real_name, PL_Argv[0]);
+		goto warned;
+	  }
+	} 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_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n",
+		 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
+		  ? "spawn" : "exec"),
+		 real_name, Strerror(errno));
+warned:
+	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;
+}
+/* Try converting 1-arg form to (usually shell-less) multi-arg form. */
+int
+do_spawn3(pTHX_ char *cmd, int execf, int flag)
+{
+char **a;
+char *s;
+char *shell, *copt, *news = NULL;
+int rc, seenspace = 0, mergestderr = 0;
+#ifdef TRYSHELL
+if ((shell = getenv("EMXSHELL")) != NULL)
+	copt = "-c";
+else if ((shell = getenv("SHELL")) != NULL)
+	copt = "-c";
+else if ((shell = getenv("COMSPEC")) != NULL)
+	copt = "/C";
+else
+	shell = "cmd.exe";
+#else
+/* Consensus on perl5-porters is that it is _very_ important to
+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 = 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);
+	Newx(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 */
+if (*cmd == '.' && isSPACE(cmd[1]))
+	goto doshell;
+if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
+	goto doshell;
+for (s = cmd; *s && isALPHA(*s); s++) ;	/* catch VAR=val gizmo */
+if (*s == '=')
+	goto doshell;
+for (s = cmd; *s; s++) {
+	if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
+	    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)
+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(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_ packWARN(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;
+	}
+}
+/* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
+Newx(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;
+	while (*s && !isSPACE(*s)) s++;
+	if (*s)
+	    *s++ = '\0';
+}
+*a = NULL;
+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;
+}
+#define ASPAWN_WAIT	0
+#define ASPAWN_EXEC	1
+#define ASPAWN_NOWAIT	2
+/* Array spawn/exec.  */
+int
+os2_aspawn_4(pTHX_ SV *really, SV **args, I32 cnt, int execing)
+{
+SV **argp = (SV **)args;
+SV **last = argp + cnt;
+char **a;
+int rc;
+int flag = P_WAIT, flag_set = 0;
+STRLEN n_a;
+if (cnt) {
+	Newx(PL_Argv, cnt + 3, char*); /* 3 extra to expand #! */
+	a = PL_Argv;
+	if (cnt > 1 && SvNIOKp(*argp) && !SvPOKp(*argp)) {
+	    flag = SvIVx(*argp);
+	    flag_set = 1;
+	} else
+	    --argp;
+	while (++argp < last) {
+	    if (*argp)
+		*a++ = SvPVx(*argp, n_a);
+	    else
+		*a++ = "";
+	}
+	*a = NULL;
+	if ( flag_set && (a == PL_Argv + 1)
+	     && !really && execing == ASPAWN_WAIT ) { 		/* One arg? */
+	    rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
+	} else {
+	    const int execf[3] = {EXECF_SPAWN, EXECF_EXEC, EXECF_SPAWN_NOWAIT};
+	    rc = do_spawn_ve(aTHX_ really, flag, execf[execing], NULL, 0);
+	}
+} else
+	rc = -1;
+do_execfree();
+return rc;
+}
+/* Array spawn.  */
+int
+os2_do_aspawn(pTHX_ SV *really, SV **vmark, SV **vsp)
+{
+return os2_aspawn_4(aTHX_ really, vmark + 1, vsp - vmark, ASPAWN_WAIT);
+}
+/* Array exec.  */
+bool
+Perl_do_aexec(pTHX_ SV* really, SV** vmark, SV** vsp)
+{
+return os2_aspawn_4(aTHX_ really, vmark + 1, vsp - vmark, ASPAWN_EXEC);
+}
+int
+os2_do_spawn(pTHX_ char *cmd)
+{
+return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
+}
+int
+do_spawn_nowait(pTHX_ char *cmd)
+{
+return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
+}
+bool
+Perl_do_exec(pTHX_ const char *cmd)
+{
+do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
+return FALSE;
+}
+bool
+os2exec(pTHX_ char *cmd)
+{
+return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
+}
+PerlIO *
+my_syspopen4(pTHX_ char *cmd, char *mode, I32 cnt, SV** args)
+{
+#ifndef USE_POPEN
+int p[2];
+I32 this, that, newfd;
+I32 pid;
+SV *sv;
+int fh_fl = 0;			/* Pacify the warning */
+/* `this' is what we use in the parent, `that' in the child. */
+this = (*mode == 'w');
+that = !this;
+if (TAINTING_get) {
+	taint_env();
+	taint_proper("Insecure %s%s", "EXEC");
+}
+if (pipe(p) < 0)
+	return NULL;
+/* 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 NULL;
+	}
+} 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);
+if (cnt) {	/* Args: "Real cmd", before first arg, the last, execing */
+	pid = os2_aspawn_4(aTHX_ NULL, args, cnt, ASPAWN_NOWAIT);
+} else
+	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 NULL;
+}
+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;
+if (cnt)
+	Perl_croak(aTHX_ "List form of piped open not implemented");
+#  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 /* USE_POPEN */
+}
+PerlIO *
+my_syspopen(pTHX_ char *cmd, char *mode)
+{
+return my_syspopen4(aTHX_ cmd, mode, 0, NULL);
+}
+/******************************************************************/
+#ifndef HAS_FORK
+int
+fork(void)
+{
+Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
+errno = EINVAL;
+return -1;
+}
+#endif
+/*******************************************************************/
+/* not implemented in EMX 0.9d */
+char *	ctermid(char *s)	{ return 0; }
+#ifdef MYTTYNAME /* was not in emx0.9a */
+void *	ttyname(x)	{ return 0; }
+#endif
+/*****************************************************************************/
+/* not implemented in C Set++ */
+#ifndef __EMX__
+int	setuid(x)	{ errno = EINVAL; return -1; }
+int	setgid(x)	{ errno = EINVAL; return -1; }
+#endif
+/*****************************************************************************/
+/* stat() hack for char/block device */
+#if OS2_STAT_HACK
+enum os2_stat_extra {	/* EMX 0.9d fix 4 defines up to 0100000 */
+os2_stat_archived	= 0x1000000,	/* 0100000000 */
+os2_stat_hidden	= 0x2000000,	/* 0200000000 */
+os2_stat_system	= 0x4000000,	/* 0400000000 */
+os2_stat_force	= 0x8000000,	/* Do not ignore flags on chmod */
+};
+#define OS2_STAT_SPECIAL (os2_stat_system | os2_stat_archived | os2_stat_hidden)
+static void
+massage_os2_attr(struct stat *st)
+{
+if ( ((st->st_mode & S_IFMT) != S_IFREG
+	  && (st->st_mode & S_IFMT) != S_IFDIR)
+|| !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM)))
+	return;
+if ( st->st_attr & FILE_ARCHIVED )
+	st->st_mode |= (os2_stat_archived | os2_stat_force);
+if ( st->st_attr & FILE_HIDDEN )
+	st->st_mode |= (os2_stat_hidden | os2_stat_force);
+if ( st->st_attr & FILE_SYSTEM )
+	st->st_mode |= (os2_stat_system | os2_stat_force);
+}
+/* First attempt used DosQueryFSAttach which crashed the system when
+used with 5.001. Now just look for /dev/. */
+int
+os2_stat(const char *name, struct stat *st)
+{
+static int ino = SHRT_MAX;
+STRLEN l = strlen(name);
+if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0
+|| (    stricmp(name + 5, "con") != 0
+	      && stricmp(name + 5, "tty") != 0
+	      && stricmp(name + 5, "nul") != 0
+	      && stricmp(name + 5, "null") != 0) ) {
+	int s = stat(name, st);
+	if (s)
+	    return s;
+	massage_os2_attr(st);
+	return 0;
+}
+memset(st, 0, sizeof *st);
+st->st_mode = S_IFCHR|0666;
+MUTEX_LOCK(&perlos2_state_mutex);
+st->st_ino = (ino-- & 0x7FFF);
+MUTEX_UNLOCK(&perlos2_state_mutex);
+st->st_nlink = 1;
+return 0;
+}
+int
+os2_fstat(int handle, struct stat *st)
+{
+int s = fstat(handle, st);
+if (s)
+	return s;
+massage_os2_attr(st);
+return 0;
+}
+#undef chmod
+int
+os2_chmod (const char *name, int pmode)	/* Modelled after EMX src/lib/io/chmod.c */
+{
+int attr, rc;
+if (!(pmode & os2_stat_force))
+	return chmod(name, pmode);
+attr = __chmod (name, 0, 0);           /* Get attributes */
+if (attr < 0)
+	return -1;
+if (pmode & S_IWRITE)
+	attr &= ~FILE_READONLY;
+else
+	attr |= FILE_READONLY;
+/* New logic */
+attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM);
+if ( pmode & os2_stat_archived )
+attr |= FILE_ARCHIVED;
+if ( pmode & os2_stat_hidden )
+attr |= FILE_HIDDEN;
+if ( pmode & os2_stat_system )
+attr |= FILE_SYSTEM;
+rc = __chmod (name, 1, attr);
+if (rc >= 0) rc = 0;
+return rc;
+}
+#endif
+#ifdef USE_PERL_SBRK
+/* SBRK() emulation, mostly moved to malloc.c. */
+void *
+sys_alloc(int size) {
+void *got;
+APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
+if (rc == ERROR_NOT_ENOUGH_MEMORY) {
+	return (void *) -1;
+} else if ( rc )
+	Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
+return got;
+}
+#endif /* USE_PERL_SBRK */
+/* tmp path */
+const char *tmppath = TMPPATH1;
+void
+settmppath()
+{
+char *p = getenv("TMP"), *tpath;
+int len;
+if (!p) p = getenv("TEMP");
+if (!p) p = getenv("TMPDIR");
+if (!p) return;
+len = strlen(p);
+tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
+if (tpath) {
+	strcpy(tpath, p);
+	tpath[len] = '/';
+	strcpy(tpath + len + 1, TMPPATH1);
+	tmppath = tpath;
+}
+}
+#include "XSUB.h"
+XS(XS_File__Copy_syscopy)
+{
+dXSARGS;
+if (items < 2 || items > 3)
+	Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
+{
+	STRLEN n_a;
+	char *	src = (char *)SvPV(ST(0),n_a);
+	char *	dst = (char *)SvPV(ST(1),n_a);
+	U32	flag;
+	int	RETVAL, rc;
+	dXSTARG;
+	if (items < 3)
+	    flag = 0;
+	else {
+	    flag = (unsigned long)SvIV(ST(2));
+	}
+	RETVAL = !CheckOSError(DosCopy(src, dst, flag));
+	XSprePUSH; PUSHi((IV)RETVAL);
+}
+XSRETURN(1);
+}
+/* APIRET APIENTRY DosReplaceModule (PCSZ pszOld, PCSZ pszNew, PCSZ pszBackup); */
+DeclOSFuncByORD(ULONG,replaceModule,ORD_DosReplaceModule,
+		(char *old, char *new, char *backup), (old, new, backup))
+XS(XS_OS2_replaceModule); /* prototype to pass -Wmissing-prototypes */
+XS(XS_OS2_replaceModule)
+{
+dXSARGS;
+if (items < 1 || items > 3)
+	Perl_croak(aTHX_ "Usage: OS2::replaceModule(target [, source [, backup]])");
+{
+	char *	target = (char *)SvPV_nolen(ST(0));
+	char *	source = (items < 2) ? NULL : (char *)SvPV_nolen(ST(1));
+	char *	backup = (items < 3) ? NULL : (char *)SvPV_nolen(ST(2));
+	if (!replaceModule(target, source, backup))
+	    croak_with_os2error("replaceModule() error");
+}
+XSRETURN_YES;
+}
+/* APIRET APIENTRY DosPerfSysCall(ULONG ulCommand, ULONG ulParm1,
+ULONG ulParm2, ULONG ulParm3); */
+DeclOSFuncByORD(ULONG,perfSysCall,ORD_DosPerfSysCall,
+		(ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3),
+		(ulCommand, ulParm1, ulParm2, ulParm3))
+#ifndef CMD_KI_RDCNT
+#  define CMD_KI_RDCNT	0x63
+#endif
+#ifndef CMD_KI_GETQTY
+#  define CMD_KI_GETQTY 0x41
+#endif
+#ifndef QSV_NUMPROCESSORS
+#  define QSV_NUMPROCESSORS         26
+#endif
+typedef unsigned long long myCPUUTIL[4];	/* time/idle/busy/intr */
+/*
+NO_OUTPUT ULONG
+perfSysCall(ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3)
+PREINIT:
+	ULONG rc;
+POSTCALL:
+	if (!RETVAL)
+	    croak_with_os2error("perfSysCall() error");
+*/
+static int
+numprocessors(void)
+{
+ULONG res;
+if (DosQuerySysInfo(QSV_NUMPROCESSORS, QSV_NUMPROCESSORS, (PVOID)&res, sizeof(res)))
+	return 1;			/* Old system? */
+return res;
+}
+XS(XS_OS2_perfSysCall); /* prototype to pass -Wmissing-prototypes */
+XS(XS_OS2_perfSysCall)
+{
+dXSARGS;
+if (items < 0 || items > 4)
+	Perl_croak(aTHX_ "Usage: OS2::perfSysCall(ulCommand = CMD_KI_RDCNT, ulParm1= 0, ulParm2= 0, ulParm3= 0)");
+SP -= items;
+{
+	dXSTARG;
+	ULONG RETVAL, ulCommand, ulParm1, ulParm2, ulParm3, res;
+	myCPUUTIL u[64];
+	int total = 0, tot2 = 0;
+	if (items < 1)
+	    ulCommand = CMD_KI_RDCNT;
+	else {
+	    ulCommand = (ULONG)SvUV(ST(0));
+	}
+	if (items < 2) {
+	    total = (ulCommand == CMD_KI_RDCNT ? numprocessors() : 0);
+	    ulParm1 = (total ? (ULONG)u : 0);
+	    if (total > C_ARRAY_LENGTH(u))
+		croak("Unexpected number of processors: %d", total);
+	} else {
+	    ulParm1 = (ULONG)SvUV(ST(1));
+	}
+	if (items < 3) {
+	    tot2 = (ulCommand == CMD_KI_GETQTY);
+	    ulParm2 = (tot2 ? (ULONG)&res : 0);
+	} else {
+	    ulParm2 = (ULONG)SvUV(ST(2));
+	}
+	if (items < 4)
+	    ulParm3 = 0;
+	else {
+	    ulParm3 = (ULONG)SvUV(ST(3));
+	}
+	RETVAL = perfSysCall(ulCommand, ulParm1, ulParm2, ulParm3);
+	if (!RETVAL)
+	    croak_with_os2error("perfSysCall() error");
+	XSprePUSH;
+	if (total) {
+	    int i,j;
+	    if (GIMME_V != G_ARRAY) {
+		PUSHn(u[0][0]);		/* Total ticks on the first processor */
+		XSRETURN(1);
+	    }
+	    EXTEND(SP, 4*total);
+	    for (i=0; i < total; i++)
+		for (j=0; j < 4; j++)
+		    PUSHs(sv_2mortal(newSVnv(u[i][j])));
+	    XSRETURN(4*total);
+	}
+	if (tot2) {
+	    PUSHu(res);
+	    XSRETURN(1);
+	}
+}
+XSRETURN_EMPTY;
+}
+#define PERL_PATCHLEVEL_H_IMPLICIT	/* Do not init local_patches. */
+#include "patchlevel.h"
+#undef PERL_PATCHLEVEL_H_IMPLICIT
+char *
+mod2fname(pTHX_ SV *sv)
+{
+int pos = 6, len, avlen;
+unsigned int sum = 0;
+char *s;
+STRLEN n_a;
+if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
+sv = SvRV(sv);
+if (SvTYPE(sv) != SVt_PVAV)
+Perl_croak_nocontext("Not array reference given to mod2fname");
+avlen = av_tindex((AV*)sv);
+if (avlen < 0)
+Perl_croak_nocontext("Empty array reference given to mod2fname");
+s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
+strncpy(fname, s, 8);
+len = strlen(s);
+if (len < 6) pos = len;
+while (*s) {
+	sum = 33 * sum + *(s++);	/* Checksumming first chars to
+					 * get the capitalization into c.s. */
+}
+avlen --;
+while (avlen >= 0) {
+	s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
+	while (*s) {
+	    sum = 33 * sum + *(s++);	/* 7 is primitive mod 13. */
+	}
+	avlen --;
+}
+/* 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';
+return (char *)fname;
+}
+XS(XS_DynaLoader_mod2fname)
+{
+dXSARGS;
+if (items != 1)
+	Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
+{
+	SV *	sv = ST(0);
+	char *	RETVAL;
+	dXSTARG;
+	RETVAL = mod2fname(aTHX_ sv);
+	sv_setpv(TARG, RETVAL);
+	XSprePUSH; PUSHTARG;
+}
+XSRETURN(1);
+}
+char *
+os2error(int rc)
+{
+	dTHX;
+	ULONG len;
+	char *s;
+	int number = SvTRUE(get_sv("OS2::nsyserror", GV_ADD));
+if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
+	if (rc == 0)
+		return "";
+	if (number) {
+	    sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
+	    s = os2error_buf + strlen(os2error_buf);
+	} else
+	    s = os2error_buf;
+	if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf),
+			  rc, "OSO001.MSG", &len)) {
+	    char *name = "";
+	    if (!number) {
+		sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
+		s = os2error_buf + strlen(os2error_buf);
+	    }
+	    switch (rc) {
+	    case PMERR_INVALID_HWND:
+		name = "PMERR_INVALID_HWND";
+		break;
+	    case PMERR_INVALID_HMQ:
+		name = "PMERR_INVALID_HMQ";
+		break;
+	    case PMERR_CALL_FROM_WRONG_THREAD:
+		name = "PMERR_CALL_FROM_WRONG_THREAD";
+		break;
+	    case PMERR_NO_MSG_QUEUE:
+		name = "PMERR_NO_MSG_QUEUE";
+		break;
+	    case PMERR_NOT_IN_A_PM_SESSION:
+		name = "PMERR_NOT_IN_A_PM_SESSION";
+		break;
+	    case PMERR_INVALID_ATOM:
+		name = "PMERR_INVALID_ATOM";
+		break;
+	    case PMERR_INVALID_HATOMTBL:
+		name = "PMERR_INVALID_HATOMTMB";
+		break;
+	    case PMERR_INVALID_INTEGER_ATOM:
+		name = "PMERR_INVALID_INTEGER_ATOM";
+		break;
+	    case PMERR_INVALID_ATOM_NAME:
+		name = "PMERR_INVALID_ATOM_NAME";
+		break;
+	    case PMERR_ATOM_NAME_NOT_FOUND:
+		name = "PMERR_ATOM_NAME_NOT_FOUND";
+		break;
+	    }
+	    sprintf(s, "%s%s[No description found in OSO001.MSG]",
+		    name, (*name ? "=" : ""));
+	} 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, os2error_buf, 7)
+		    && s[7] == ':' && s[8] == ' ')
+		    /* Some messages start with SYSdddd:, some not */
+		    Move(s + 9, s, (len -= 9) + 1, char);
+	}
+	return os2error_buf;
+}
+void
+ResetWinError(void)
+{
+WinError_2_Perl_rc;
+}
+void
+CroakWinError(int die, char *name)
+{
+FillWinError;
+if (die && Perl_rc)
+croak_with_os2error(name ? name : "Win* API call");
+}
+static char *
+dllname2buffer(pTHX_ char *buf, STRLEN l)
+{
+char *o;
+STRLEN ll;
+SV *dll = NULL;
+dll = module_name(mod_name_full);
+o = SvPV(dll, ll);
+if (ll < l)
+memcpy(buf,o,ll);
+SvREFCNT_dec(dll);
+return (ll >= l ? "???" : buf);
+}
+static char *
+execname2buffer(char *buf, STRLEN l, char *oname)
+{
+char *p, *orig = oname, ok = oname != NULL;
+if (_execname(buf, l) != 0) {
+if (!oname || strlen(oname) >= l)
+return oname;
+strcpy(buf, oname);
+ok = 0;
+}
+p = buf;
+while (*p) {
+if (*p == '\\')
+	*p = '/';
+if (*p == '/') {
+	if (ok && *oname != '/' && *oname != '\\')
+	    ok = 0;
+} else if (ok && tolower(*oname) != tolower(*p))
+	ok = 0;
+p++;
+oname++;
+}
+if (ok) { /* orig matches the real name.  Use orig: */
+strcpy(buf, orig);		/* _execname() is always uppercased */
+p = buf;
+while (*p) {
+if (*p == '\\')
+*p = '/';
+p++;
+}
+}
+return buf;
+}
+char *
+os2_execname(pTHX)
+{
+char buf[300], *p = execname2buffer(buf, sizeof buf, PL_origargv[0]);
+p = savepv(p);
+SAVEFREEPV(p);
+return p;
+}
+int
+Perl_OS2_handler_install(void *handler, enum Perlos2_handler how)
+{
+char *s, b[300];
+switch (how) {
+case Perlos2_handler_mangle:
+	perllib_mangle_installed = (char *(*)(char *s, unsigned int l))handler;
+	return 1;
+case Perlos2_handler_perl_sh:
+	s = (char *)handler;
+	s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perl_sh");
+	perl_sh_installed = savepv(s);
+	return 1;
+case Perlos2_handler_perllib_from:
+	s = (char *)handler;
+	s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_from");
+	oldl = strlen(s);
+	oldp = savepv(s);
+	return 1;
+case Perlos2_handler_perllib_to:
+	s = (char *)handler;
+	s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_to");
+	newl = strlen(s);
+	newp = savepv(s);
+	strcpy(mangle_ret, newp);
+	s = mangle_ret - 1;
+	while (*++s)
+	    if (*s == '\\')
+		*s = '/';
+	return 1;
+default:
+	return 0;
+}
+}
+/* Returns a malloc()ed copy */
+char *
+dir_subst(char *s, unsigned int l, char *b, unsigned int bl, enum dir_subst_e flags, char *msg)
+{
+char *from, *to = b, *e = b; /* `to' assignment: shut down the warning */
+STRLEN froml = 0, tol = 0, rest = 0;	/* froml: likewise */
+if (l >= 2 && s[0] == '~') {
+	switch (s[1]) {
+	  case 'i': case 'I':
+	    from = "installprefix";	break;
+	  case 'd': case 'D':
+	    from = "dll";		break;
+	  case 'e': case 'E':
+	    from = "exe";		break;
+	  default:
+	    from = NULL;
+	    froml = l + 1;			/* Will not match */
+	    break;
+	}
+	if (from)
+	    froml = strlen(from) + 1;
+	if (l >= froml && strnicmp(s + 2, from + 1, froml - 2) == 0) {
+	    int strip = 1;
+	    switch (s[1]) {
+	      case 'i': case 'I':
+		strip = 0;
+		tol = strlen(INSTALL_PREFIX);
+		if (tol >= bl) {
+		    if (flags & dir_subst_fatal)
+			Perl_croak_nocontext("INSTALL_PREFIX too long: `%s'", INSTALL_PREFIX);
+		    else
+			return NULL;
+		}
+		memcpy(b, INSTALL_PREFIX, tol + 1);
+		to = b;
+		e = b + tol;
+		break;
+	      case 'd': case 'D':
+		if (flags & dir_subst_fatal) {
+		    dTHX;
+		    to = dllname2buffer(aTHX_ b, bl);
+		} else {				/* No Perl present yet */
+		    HMODULE self = find_myself();
+		    APIRET rc = DosQueryModuleName(self, bl, b);
+		    if (rc)
+			return 0;
+		    to = b - 1;
+		    while (*++to)
+			if (*to == '\\')
+			    *to = '/';
+		    to = b;
+		}
+		break;
+	      case 'e': case 'E':
+		if (flags & dir_subst_fatal) {
+		    dTHX;
+		    to = execname2buffer(b, bl, PL_origargv[0]);
+	        } else
+		    to = execname2buffer(b, bl, NULL);
+		break;
+	    }
+	    if (!to)
+		return NULL;
+	    if (strip) {
+		e = strrchr(to, '/');
+		if (!e && (flags & dir_subst_fatal))
+		    Perl_croak_nocontext("%s: Can't parse EXE/DLL name: '%s'", msg, to);
+		else if (!e)
+		    return NULL;
+		*e = 0;
+	    }
+	    s += froml; l -= froml;
+	    if (!l)
+		return to;
+	    if (!tol)
+		tol = strlen(to);
+	    while (l >= 3 && (s[0] == '/' || s[0] == '\\')
+		   && s[1] == '.' && s[2] == '.'
+		   && (l == 3 || s[3] == '/' || s[3] == '\\' || s[3] == ';')) {
+		e = strrchr(b, '/');
+		if (!e && (flags & dir_subst_fatal))
+			Perl_croak_nocontext("%s: Error stripping dirs from EXE/DLL/INSTALLDIR name", msg);
+		else if (!e)
+			return NULL;
+		*e = 0;
+		l -= 3; s += 3;
+	    }
+	    if (l && s[0] != '/' && s[0] != '\\' && s[0] != ';')
+		*e++ = '/';
+	}
+}						/* Else: copy as is */
+if (l && (flags & dir_subst_pathlike)) {
+	STRLEN i = 0;
+	while ( i < l - 2 && s[i] != ';')	/* May have ~char after `;' */
+	    i++;
+	if (i < l - 2) {			/* Found */
+	    rest = l - i - 1;
+	    l = i + 1;
+	}
+}
+if (e + l >= b + bl) {
+	if (flags & dir_subst_fatal)
+	    Perl_croak_nocontext("%s: name `%s%s' too long", msg, b, s);
+	else
+	    return NULL;
+}
+memcpy(e, s, l);
+if (rest) {
+	e = dir_subst(s + l, rest, e + l, bl - (e + l - b), flags, msg);
+	return e ? b : e;
+}
+e[l] = 0;
+return b;
+}
+char *
+perllib_mangle_with(char *s, unsigned int l, char *from, unsigned int froml, char *to, unsigned int tol)
+{
+if (!to)
+	return s;
+if (l == 0)
+	l = strlen(s);
+if (l < froml || strnicmp(from, s, froml) != 0)
+	return s;
+if (l + tol - froml > STATIC_FILE_LENGTH || tol > STATIC_FILE_LENGTH)
+	Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
+if (to && to != mangle_ret)
+	memcpy(mangle_ret, to, tol);
+strcpy(mangle_ret + tol, s + froml);
+return mangle_ret;
+}
+char *
+perllib_mangle(char *s, unsigned int l)
+{
+char *name;
+if (perllib_mangle_installed && (name = perllib_mangle_installed(s,l)))
+	return name;
+if (!newp && !notfound) {
+	newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION)
+		      STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION)
+		      "_PREFIX");
+	if (!newp)
+	    newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION)
+			  STRINGIFY(PERL_VERSION) "_PREFIX");
+	if (!newp)
+	    newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX");
+	if (!newp)
+	    newp = getenv(name = "PERLLIB_PREFIX");
+	if (newp) {
+	    char *s, b[300];
+	    oldp = newp;
+	    while (*newp && !isSPACE(*newp) && *newp != ';')
+		newp++;			/* Skip old name. */
+	    oldl = newp - oldp;
+	    s = dir_subst(oldp, oldl, b, sizeof b, dir_subst_fatal, name);
+	    oldp = savepv(s);
+	    oldl = strlen(s);
+	    while (*newp && (isSPACE(*newp) || *newp == ';'))
+		newp++;			/* Skip whitespace. */
+	    Perl_OS2_handler_install((void *)newp, Perlos2_handler_perllib_to);
+	    if (newl == 0 || oldl == 0)
+		Perl_croak_nocontext("Malformed %s", name);
+	} else
+	    notfound = 1;
+}
+if (!newp)
+	return s;
+if (l == 0)
+	l = strlen(s);
+if (l < oldl || strnicmp(oldp, s, oldl) != 0)
+	return s;
+if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH)
+	Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
+strcpy(mangle_ret + newl, s + oldl);
+return mangle_ret;
+}
+unsigned long
+Perl_hab_GET()			/* Needed if perl.h cannot be included */
+{
+return perl_hab_GET();
+}
+static void
+Create_HMQ(int serve, char *message)	/* Assumes morphing */
+{
+unsigned fpflag = _control87(0,0);
+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) {
+	dTHX;
+	SAVEINT(rmq_cnt);		/* Allow catch()ing. */
+	if (rmq_cnt++)
+	    _exit(188);		/* Panic can try to create a window. */
+	CroakWinError(1, message ? message : "Cannot create a message queue");
+}
+if (serve != -1)
+	(*PMWIN_entries.CancelShutdown)(Perl_hmq, !serve);
+/* We may have loaded some modules */
+_control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
+}
+#define REGISTERMQ_WILL_SERVE		1
+#define REGISTERMQ_IMEDIATE_UNMORPH	2
+HMQ
+Perl_Register_MQ(int serve)
+{
+if (Perl_hmq_refcnt <= 0) {
+PPIB pib;
+PTIB tib;
+Perl_hmq_refcnt = 0;		/* Be extra safe */
+DosGetInfoBlocks(&tib, &pib);
+if (!Perl_morph_refcnt) {
+	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 */
+}
+Create_HMQ(-1,			/* We do CancelShutdown ourselves */
+	       "Cannot create a message queue, or morph to a PM application");
+if ((serve & REGISTERMQ_IMEDIATE_UNMORPH)) {
+	if (!Perl_morph_refcnt && Perl_os2_initial_mode != 3)
+	    pib->pib_ultype = Perl_os2_initial_mode;
+}
+}
+if (serve & REGISTERMQ_WILL_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++;
+if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH))
+	Perl_morph_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)
+{
+if (serve & REGISTERMQ_WILL_SERVE)
+	Perl_hmq_servers--;
+if (--Perl_hmq_refcnt <= 0) {
+	unsigned fpflag = _control87(0,0);
+	init_PMWIN_entries();			/* To be extra safe */
+	(*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
+	Perl_hmq = 0;
+	/* We may have (un)loaded some modules */
+	_control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
+} else if ((serve & REGISTERMQ_WILL_SERVE) && Perl_hmq_servers <= 0)
+	(*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); /* Last server exited */
+if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH) && (--Perl_morph_refcnt <= 0)) {
+	/* Try morphing back from a PM application. */
+	PPIB pib;
+	PTIB tib;
+	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);
+}
+}
+#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)))
+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: %s", a, os2error(Perl_rc));
+	ST(0) = sv_newmortal();
+	if (DOS_harderr_state >= 0)
+	    sv_setiv(ST(0), DOS_harderr_state);
+	DOS_harderr_state = RETVAL;
+}
+XSRETURN(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: %s", drive,
+				 os2error(Perl_rc));
+	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);
+}
+int
+async_mssleep(ULONG ms, int switch_priority) {
+/* This is similar to DosSleep(), but has 8ms granularity in time-critical
+threads even on Warp3. */
+HEV     hevEvent1     = 0;			/* Event semaphore handle    */
+HTIMER  htimerEvent1  = 0;			/* Timer handle              */
+APIRET  rc            = NO_ERROR;		/* Return code               */
+int ret = 1;
+ULONG priority = 0, nesting;			/* Shut down the warnings */
+PPIB pib;
+PTIB tib;
+char *e = NULL;
+APIRET badrc;
+if (!(_emx_env & 0x200))	/* DOS */
+return !_sleep2(ms);
+os2cp_croak(DosCreateEventSem(NULL,	     /* Unnamed */
+				&hevEvent1,  /* Handle of semaphore returned */
+				DC_SEM_SHARED, /* Shared needed for DosAsyncTimer */
+				FALSE),      /* Semaphore is in RESET state  */
+	      "DosCreateEventSem");
+if (ms >= switch_priority)
+switch_priority = 0;
+if (switch_priority) {
+if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
+	switch_priority = 0;
+else {
+	/* In Warp3, to switch scheduling to 8ms step, one needs to do
+	   DosAsyncTimer() in time-critical thread.  On laters versions,
+	   more and more cases of wait-for-something are covered.
+	   It turns out that on Warp3fp42 it is the priority at the time
+	   of DosAsyncTimer() which matters.  Let's hope that this works
+	   with later versions too...		XXXX
+	 */
+	priority = (tib->tib_ptib2->tib2_ulpri);
+	if ((priority & 0xFF00) == 0x0300) /* already time-critical */
+	    switch_priority = 0;
+	/* Make us time-critical.  Just modifying TIB is not enough... */
+	/* tib->tib_ptib2->tib2_ulpri = 0x0300;*/
+	/* We do not want to run at high priority if a signal causes us
+	   to longjmp() out of this section... */
+	if (DosEnterMustComplete(&nesting))
+	    switch_priority = 0;
+	else
+	    DosSetPriority(PRTYS_THREAD, PRTYC_TIMECRITICAL, 0, 0);
+}
+}
+if ((badrc = DosAsyncTimer(ms,
+			     (HSEM) hevEvent1,	/* Semaphore to post        */
+			     &htimerEvent1)))	/* Timer handler (returned) */
+e = "DosAsyncTimer";
+if (switch_priority && tib->tib_ptib2->tib2_ulpri == 0x0300) {
+	/* Nobody switched priority while we slept...  Ignore errors... */
+	/* tib->tib_ptib2->tib2_ulpri = priority; */	/* Get back... */
+	if (!(rc = DosSetPriority(PRTYS_THREAD, (priority>>8) & 0xFF, 0, 0)))
+	    rc = DosSetPriority(PRTYS_THREAD, 0, priority & 0xFF, 0);
+}
+if (switch_priority)
+rc = DosExitMustComplete(&nesting);	/* Ignore errors */
+/* The actual blocking call is made with "normal" priority.  This way we
+should not bother with DosSleep(0) etc. to compensate for us interrupting
+higher-priority threads.  The goal is to prohibit the system spending too
+much time halt()ing, not to run us "no matter what". */
+if (!e)					/* Wait for AsyncTimer event */
+badrc = DosWaitEventSem(hevEvent1, SEM_INDEFINITE_WAIT);
+if (e) ;				/* Do nothing */
+else if (badrc == ERROR_INTERRUPT)
+ret = 0;
+else if (badrc)
+e = "DosWaitEventSem";
+if ((rc = DosCloseEventSem(hevEvent1)) && !e) { /* Get rid of semaphore */
+e = "DosCloseEventSem";
+badrc = rc;
+}
+if (e)
+os2cp_croak(badrc, e);
+return ret;
+}
+XS(XS_OS2_ms_sleep)		/* for testing only... */
+{
+dXSARGS;
+ULONG ms, lim;
+if (items > 2 || items < 1)
+	Perl_croak_nocontext("Usage: OS2::ms_sleep(wait_ms [, high_priority_limit])");
+ms = SvUV(ST(0));
+lim = items > 1 ? SvUV(ST(1)) : ms + 1;
+async_mssleep(ms, lim);
+XSRETURN_YES;
+}
+ULONG (*pDosTmrQueryFreq) (PULONG);
+ULONG (*pDosTmrQueryTime) (unsigned long long *);
+XS(XS_OS2_Timer)
+{
+dXSARGS;
+static ULONG freq;
+unsigned long long count;
+ULONG rc;
+if (items != 0)
+	Perl_croak_nocontext("Usage: OS2::Timer()");
+if (!freq) {
+	*(PFN*)&pDosTmrQueryFreq = loadByOrdinal(ORD_DosTmrQueryFreq, 0);
+	*(PFN*)&pDosTmrQueryTime = loadByOrdinal(ORD_DosTmrQueryTime, 0);
+	MUTEX_LOCK(&perlos2_state_mutex);
+	if (!freq)
+	    if (CheckOSError(pDosTmrQueryFreq(&freq)))
+		croak_with_os2error("DosTmrQueryFreq");
+	MUTEX_UNLOCK(&perlos2_state_mutex);
+}
+if (CheckOSError(pDosTmrQueryTime(&count)))
+	croak_with_os2error("DosTmrQueryTime");
+{
+	dXSTARG;
+	XSprePUSH; PUSHn(((NV)count)/freq);
+}
+XSRETURN(1);
+}
+XS(XS_OS2_msCounter)
+{
+dXSARGS;
+if (items != 0)
+	Perl_croak_nocontext("Usage: OS2::msCounter()");
+{
+	dXSTARG;
+	XSprePUSH; PUSHu(msCounter());
+}
+XSRETURN(1);
+}
+XS(XS_OS2__InfoTable)
+{
+dXSARGS;
+int is_local = 0;
+if (items > 1)
+	Perl_croak_nocontext("Usage: OS2::_infoTable([isLocal])");
+if (items == 1)
+	is_local = (int)SvIV(ST(0));
+{
+	dXSTARG;
+	XSprePUSH; PUSHu(InfoTable(is_local));
+}
+XSRETURN(1);
+}
+static const char * const dc_fields[] = {
+"FAMILY",
+"IO_CAPS",
+"TECHNOLOGY",
+"DRIVER_VERSION",
+"WIDTH",
+"HEIGHT",
+"WIDTH_IN_CHARS",
+"HEIGHT_IN_CHARS",
+"HORIZONTAL_RESOLUTION",
+"VERTICAL_RESOLUTION",
+"CHAR_WIDTH",
+"CHAR_HEIGHT",
+"SMALL_CHAR_WIDTH",
+"SMALL_CHAR_HEIGHT",
+"COLORS",
+"COLOR_PLANES",
+"COLOR_BITCOUNT",
+"COLOR_TABLE_SUPPORT",
+"MOUSE_BUTTONS",
+"FOREGROUND_MIX_SUPPORT",
+"BACKGROUND_MIX_SUPPORT",
+"VIO_LOADABLE_FONTS",
+"WINDOW_BYTE_ALIGNMENT",
+"BITMAP_FORMATS",
+"RASTER_CAPS",
+"MARKER_HEIGHT",
+"MARKER_WIDTH",
+"DEVICE_FONTS",
+"GRAPHICS_SUBSET",
+"GRAPHICS_VERSION",
+"GRAPHICS_VECTOR_SUBSET",
+"DEVICE_WINDOWING",
+"ADDITIONAL_GRAPHICS",
+"PHYS_COLORS",
+"COLOR_INDEX",
+"GRAPHICS_CHAR_WIDTH",
+"GRAPHICS_CHAR_HEIGHT",
+"HORIZONTAL_FONT_RES",
+"VERTICAL_FONT_RES",
+"DEVICE_FONT_SIM",
+"LINEWIDTH_THICK",
+"DEVICE_POLYSET_POINTS",
+};
+enum {
+DevCap_dc, DevCap_hwnd
+};
+HDC (*pWinOpenWindowDC) (HWND hwnd);
+HMF (*pDevCloseDC) (HDC hdc);
+HDC (*pDevOpenDC) (HAB hab, LONG lType, PCSZ pszToken, LONG lCount,
+PDEVOPENDATA pdopData, HDC hdcComp);
+BOOL (*pDevQueryCaps) (HDC hdc, LONG lStart, LONG lCount, PLONG alArray);
+XS(XS_OS2_DevCap)
+{
+dXSARGS;
+if (items > 2)
+	Perl_croak_nocontext("Usage: OS2::DevCap()");
+{
+	/* Device Capabilities Data Buffer (10 extra w.r.t. Warp 4.5) */
+	LONG   si[CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1];
+	int i = 0, j = 0, how = DevCap_dc;
+	HDC hScreenDC;
+	DEVOPENSTRUC doStruc= {0L, (PSZ)"DISPLAY", NULL, 0L, 0L, 0L, 0L, 0L, 0L};
+	ULONG rc1 = NO_ERROR;
+	HWND hwnd;
+	static volatile int devcap_loaded;
+	if (!devcap_loaded) {
+	    *(PFN*)&pWinOpenWindowDC = loadByOrdinal(ORD_WinOpenWindowDC, 0);
+	    *(PFN*)&pDevOpenDC = loadByOrdinal(ORD_DevOpenDC, 0);
+	    *(PFN*)&pDevCloseDC = loadByOrdinal(ORD_DevCloseDC, 0);
+	    *(PFN*)&pDevQueryCaps = loadByOrdinal(ORD_DevQueryCaps, 0);
+	    devcap_loaded = 1;
+	}
+	if (items >= 2)
+	    how = SvIV(ST(1));
+	if (!items) {			/* Get device contents from PM */
+	    hScreenDC = pDevOpenDC(perl_hab_GET(), OD_MEMORY, (PSZ)"*", 0,
+				  (PDEVOPENDATA)&doStruc, NULLHANDLE);
+	    if (CheckWinError(hScreenDC))
+		croak_with_os2error("DevOpenDC() failed");
+	} else if (how == DevCap_dc)
+	    hScreenDC = (HDC)SvIV(ST(0));
+	else {				/* DevCap_hwnd */
+	    if (!Perl_hmq)
+		Perl_croak(aTHX_ "Getting a window's device context without a message queue would lock PM");
+	    hwnd = (HWND)SvIV(ST(0));
+	    hScreenDC = pWinOpenWindowDC(hwnd); /* No need to DevCloseDC() */
+	    if (CheckWinError(hScreenDC))
+		croak_with_os2error("WinOpenWindowDC() failed");
+	}
+	if (CheckWinError(pDevQueryCaps(hScreenDC,
+					CAPS_FAMILY, /* W3 documented caps */
+					CAPS_DEVICE_POLYSET_POINTS
+					  - CAPS_FAMILY + 1,
+					si)))
+	    rc1 = Perl_rc;
+	else {
+	    EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1));
+	    while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) {
+		ST(j) = sv_newmortal();
+		sv_setpv(ST(j++), dc_fields[i]);
+		ST(j) = sv_newmortal();
+		sv_setiv(ST(j++), si[i]);
+		i++;
+	    }
+	    i = CAPS_DEVICE_POLYSET_POINTS + 1;
+	    while (i < CAPS_DEVICE_POLYSET_POINTS + 11) { /* Just in case... */
+		LONG l;
+		if (CheckWinError(pDevQueryCaps(hScreenDC, i, 1, &l)))
+		    break;
+		EXTEND(SP, j + 2);
+		ST(j) = sv_newmortal();
+		sv_setiv(ST(j++), i);
+		ST(j) = sv_newmortal();
+		sv_setiv(ST(j++), l);
+		i++;
+	    }
+	}
+	if (!items && CheckWinError(pDevCloseDC(hScreenDC)))
+	    Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc));
+	if (rc1)
+	    Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed");
+	XSRETURN(j);
+}
+}
+LONG (*pWinQuerySysValue) (HWND hwndDesktop, LONG iSysValue);
+BOOL (*pWinSetSysValue) (HWND hwndDesktop, LONG iSysValue, LONG lValue);
+const char * const sv_keys[] = {
+"SWAPBUTTON",
+"DBLCLKTIME",
+"CXDBLCLK",
+"CYDBLCLK",
+"CXSIZEBORDER",
+"CYSIZEBORDER",
+"ALARM",
+"7",
+"8",
+"CURSORRATE",
+"FIRSTSCROLLRATE",
+"SCROLLRATE",
+"NUMBEREDLISTS",
+"WARNINGFREQ",
+"NOTEFREQ",
+"ERRORFREQ",
+"WARNINGDURATION",
+"NOTEDURATION",
+"ERRORDURATION",
+"19",
+"CXSCREEN",
+"CYSCREEN",
+"CXVSCROLL",
+"CYHSCROLL",
+"CYVSCROLLARROW",
+"CXHSCROLLARROW",
+"CXBORDER",
+"CYBORDER",
+"CXDLGFRAME",
+"CYDLGFRAME",
+"CYTITLEBAR",
+"CYVSLIDER",
+"CXHSLIDER",
+"CXMINMAXBUTTON",
+"CYMINMAXBUTTON",
+"CYMENU",
+"CXFULLSCREEN",
+"CYFULLSCREEN",
+"CXICON",
+"CYICON",
+"CXPOINTER",
+"CYPOINTER",
+"DEBUG",
+"CPOINTERBUTTONS",
+"POINTERLEVEL",
+"CURSORLEVEL",
+"TRACKRECTLEVEL",
+"CTIMERS",
+"MOUSEPRESENT",
+"CXALIGN",
+"CYALIGN",
+"DESKTOPWORKAREAYTOP",
+"DESKTOPWORKAREAYBOTTOM",
+"DESKTOPWORKAREAXRIGHT",
+"DESKTOPWORKAREAXLEFT",
+"55",
+"NOTRESERVED",
+"EXTRAKEYBEEP",
+"SETLIGHTS",
+"INSERTMODE",
+"60",
+"61",
+"62",
+"63",
+"MENUROLLDOWNDELAY",
+"MENUROLLUPDELAY",
+"ALTMNEMONIC",
+"TASKLISTMOUSEACCESS",
+"CXICONTEXTWIDTH",
+"CICONTEXTLINES",
+"CHORDTIME",
+"CXCHORD",
+"CYCHORD",
+"CXMOTIONSTART",
+"CYMOTIONSTART",
+"BEGINDRAG",
+"ENDDRAG",
+"SINGLESELECT",
+"OPEN",
+"CONTEXTMENU",
+"CONTEXTHELP",
+"TEXTEDIT",
+"BEGINSELECT",
+"ENDSELECT",
+"BEGINDRAGKB",
+"ENDDRAGKB",
+"SELECTKB",
+"OPENKB",
+"CONTEXTMENUKB",
+"CONTEXTHELPKB",
+"TEXTEDITKB",
+"BEGINSELECTKB",
+"ENDSELECTKB",
+"ANIMATION",
+"ANIMATIONSPEED",
+"MONOICONS",
+"KBDALTERED",
+"PRINTSCREEN",		/* 97, the last one on one of the DDK header */
+"LOCKSTARTINPUT",
+"DYNAMICDRAG",
+"100",
+"101",
+"102",
+"103",
+"104",
+"105",
+"106",
+"107",
+/*  "CSYSVALUES",*/
+					/* In recent DDK the limit is 108 */
+};
+XS(XS_OS2_SysValues)
+{
+dXSARGS;
+if (items > 2)
+	Perl_croak_nocontext("Usage: OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP)");
+{
+	int i = 0, j = 0, which = -1;
+	HWND hwnd = HWND_DESKTOP;
+	static volatile int sv_loaded;
+	LONG RETVAL;
+	if (!sv_loaded) {
+	    *(PFN*)&pWinQuerySysValue = loadByOrdinal(ORD_WinQuerySysValue, 0);
+	    sv_loaded = 1;
+	}
+	if (items == 2)
+	    hwnd = (HWND)SvIV(ST(1));
+	if (items >= 1)
+	    which = (int)SvIV(ST(0));
+	if (which == -1) {
+	    EXTEND(SP,2*C_ARRAY_LENGTH(sv_keys));
+	    while (i < C_ARRAY_LENGTH(sv_keys)) {
+		ResetWinError();
+		RETVAL = pWinQuerySysValue(hwnd, i);
+		if ( !RETVAL
+		     && !(sv_keys[i][0] >= '0' && sv_keys[i][0] <= '9'
+			  && i <= SV_PRINTSCREEN) ) {
+		    FillWinError;
+		    if (Perl_rc) {
+			if (i > SV_PRINTSCREEN)
+			    break; /* May be not present on older systems */
+			croak_with_os2error("SysValues():");
+		    }
+		}
+		ST(j) = sv_newmortal();
+		sv_setpv(ST(j++), sv_keys[i]);
+		ST(j) = sv_newmortal();
+		sv_setiv(ST(j++), RETVAL);
+		i++;
+	    }
+	    XSRETURN(2 * i);
+	} else {
+	    dXSTARG;
+	    ResetWinError();
+	    RETVAL = pWinQuerySysValue(hwnd, which);
+	    if (!RETVAL) {
+		FillWinError;
+		if (Perl_rc)
+		    croak_with_os2error("SysValues():");
+	    }
+	    XSprePUSH; PUSHi((IV)RETVAL);
+	}
+}
+}
+XS(XS_OS2_SysValues_set)
+{
+dXSARGS;
+if (items < 2 || items > 3)
+	Perl_croak_nocontext("Usage: OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP)");
+{
+	int which = (int)SvIV(ST(0));
+	LONG val = (LONG)SvIV(ST(1));
+	HWND hwnd = HWND_DESKTOP;
+	static volatile int svs_loaded;
+	if (!svs_loaded) {
+	    *(PFN*)&pWinSetSysValue = loadByOrdinal(ORD_WinSetSysValue, 0);
+	    svs_loaded = 1;
+	}
+	if (items == 3)
+	    hwnd = (HWND)SvIV(ST(2));
+	if (CheckWinError(pWinSetSysValue(hwnd, which, val)))
+	    croak_with_os2error("SysValues_set()");
+}
+XSRETURN_YES;
+}
+#define QSV_MAX_WARP3				QSV_MAX_COMP_LENGTH
+static const char * const si_fields[] = {
+"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",			/* Warp 3 toolkit defines up to this */
+"NUMPROCESSORS",
+"MAXHPRMEM",
+"MAXHSHMEM",
+"MAXPROCESSES",
+"VIRTUALADDRESSLIMIT",
+"INT10ENABLED",			/* From $TOOLKIT-ddk\DDK\video\rel\os2c\include\base\os2\bsedos.h */
+};
+XS(XS_OS2_SysInfo)
+{
+dXSARGS;
+if (items != 0)
+	Perl_croak_nocontext("Usage: OS2::SysInfo()");
+{
+	/* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
+	ULONG   si[C_ARRAY_LENGTH(si_fields) + 10];
+	APIRET  rc	= NO_ERROR;	/* Return code            */
+	int i = 0, j = 0, last = QSV_MAX_WARP3;
+	if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */
+					 last, /* info for Warp 3 */
+					 (PVOID)si,
+					 sizeof(si))))
+	    croak_with_os2error("DosQuerySysInfo() failed");
+	while (++last <= C_ARRAY_LENGTH(si)) {
+	    if (CheckOSError(DosQuerySysInfo(last, last, /* One entry only */
+					     (PVOID)(si+last-1),
+					     sizeof(*si)))) {
+		if (Perl_rc != ERROR_INVALID_PARAMETER)
+		    croak_with_os2error("DosQuerySysInfo() failed");
+		break;
+	    }
+	}
+	last--;			/* Count of successfully processed offsets */
+	EXTEND(SP,2*last);
+	while (i < last) {
+	    ST(j) = sv_newmortal();
+	    if (i < C_ARRAY_LENGTH(si_fields))
+		sv_setpv(ST(j++),  si_fields[i]);
+	    else
+		sv_setiv(ST(j++),  i + 1);
+	    ST(j) = sv_newmortal();
+	    sv_setuv(ST(j++), si[i]);
+	    i++;
+	}
+	XSRETURN(2 * last);
+}
+}
+XS(XS_OS2_SysInfoFor)
+{
+dXSARGS;
+int count = (items == 2 ? (int)SvIV(ST(1)) : 1);
+if (items < 1 || items > 2)
+	Perl_croak_nocontext("Usage: OS2::SysInfoFor(id[,count])");
+{
+	/* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
+	ULONG   si[C_ARRAY_LENGTH(si_fields) + 10];
+	APIRET  rc	= NO_ERROR;	/* Return code            */
+	int i = 0;
+	int start = (int)SvIV(ST(0));
+	if (count > C_ARRAY_LENGTH(si) || count <= 0)
+	    Perl_croak(aTHX_ "unexpected count %d for OS2::SysInfoFor()", count);
+	if (CheckOSError(DosQuerySysInfo(start,
+					 start + count - 1,
+					 (PVOID)si,
+					 sizeof(si))))
+	    croak_with_os2error("DosQuerySysInfo() failed");
+	EXTEND(SP,count);
+	while (i < count) {
+	    ST(i) = sv_newmortal();
+	    sv_setiv(ST(i), si[i]);
+	    i++;
+	}
+}
+XSRETURN(count);
+}
+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;
+	dXSTARG;
+	if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
+					 (PVOID)si, sizeof(si))))
+	    croak_with_os2error("DosQuerySysInfo() failed");
+	c = 'a' - 1 + si[0];
+	sv_setpvn(TARG, &c, 1);
+	XSprePUSH; PUSHTARG;
+}
+XSRETURN(1);
+}
+XS(XS_OS2_Beep)
+{
+dXSARGS;
+if (items > 2)			/* Defaults as for WinAlarm(ERROR) */
+	Perl_croak_nocontext("Usage: OS2::Beep(freq = 440, ms = 100)");
+{
+	ULONG freq	= (items > 0 ? (ULONG)SvUV(ST(0)) : 440);
+	ULONG ms	= (items > 1 ? (ULONG)SvUV(ST(1)) : 100);
+	ULONG rc;
+	if (CheckOSError(DosBeep(freq, ms)))
+	    croak_with_os2error("SysValues_set()");
+}
+XSRETURN_YES;
+}
+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);
+	dXSTARG;
+	XSprePUSH; PUSHi((IV)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);
+	dXSTARG;
+	XSprePUSH; PUSHi((IV)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;
+	dXSTARG;
+	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);
+}
+	XSprePUSH; PUSHi((IV)cnt);
+}
+XSRETURN(1);
+}
+XS(XS_Cwd_current_drive)
+{
+dXSARGS;
+if (items != 0)
+	Perl_croak_nocontext("Usage: Cwd::current_drive()");
+{
+	char	RETVAL;
+	dXSTARG;
+	RETVAL = current_drive();
+	sv_setpvn(TARG, (char *)&RETVAL, 1);
+	XSprePUSH; PUSHTARG;
+}
+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;
+	/* Can't use TARG, since tainting behaves differently */
+	RETVAL = _getcwd2(p, MAXPATHLEN);
+	ST(0) = sv_newmortal();
+	sv_setpv(ST(0), RETVAL);
+	SvTAINTED_on(ST(0));
+}
+XSRETURN(1);
+}
+XS(XS_Cwd_sys_abspath)
+{
+dXSARGS;
+if (items > 2)
+	Perl_croak_nocontext("Usage: Cwd::sys_abspath(path = '.', dir = NULL)");
+{
+	STRLEN n_a;
+	char *	path = items ? (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));
+	}
+	if (!items)
+	    SvTAINTED_on(ST(0));
+}
+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, int fatal)
+{
+ULONG what;
+PFN f = loadByOrdinal(ord, fatal);	/* if fatal: load or die! */
+if (!f)				/* Impossible with fatal */
+	return Perl_rc;
+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, fatal) 					\
+(CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type), fatal)) ? NULL : (to) )
+#define extLibpath_set(p,type, fatal) 					\
+(!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type), fatal)))
+static void
+early_error(char *msg1, char *msg2, char *msg3)
+{	/* Buffer overflow detected; there is very little we can do... */
+ULONG rc;
+DosWrite(2, msg1, strlen(msg1), &rc);
+DosWrite(2, msg2, strlen(msg2), &rc);
+DosWrite(2, msg3, strlen(msg3), &rc);
+DosExit(EXIT_PROCESS, 2);
+}
+XS(XS_Cwd_extLibpath)
+{
+dXSARGS;
+if (items < 0 || items > 1)
+	Perl_croak_nocontext("Usage: OS2::extLibpath(type = 0)");
+{
+	IV	type;
+	char	to[1024];
+	U32	rc;
+	char *	RETVAL;
+	dXSTARG;
+	STRLEN l;
+	if (items < 1)
+	    type = 0;
+	else {
+	    type = SvIV(ST(0));
+	}
+	to[0] = 1; to[1] = 0;		/* Sometimes no error reported */
+	RETVAL = extLibpath(to, type, 1);	/* Make errors fatal */
+	if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
+	    Perl_croak_nocontext("panic OS2::extLibpath parameter");
+	l = strlen(to);
+	if (l >= sizeof(to))
+	    early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `",
+			to, "'\r\n");		/* Will not return */
+	sv_setpv(TARG, RETVAL);
+	XSprePUSH; PUSHTARG;
+}
+XSRETURN(1);
+}
+XS(XS_Cwd_extLibpath_set)
+{
+dXSARGS;
+if (items < 1 || items > 2)
+	Perl_croak_nocontext("Usage: OS2::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, 1);	/* Make errors fatal */
+	ST(0) = boolSV(RETVAL);
+	if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+}
+XSRETURN(1);
+}
+ULONG
+fill_extLibpath(int type, char *pre, char *post, int replace, char *msg)
+{
+char buf[2048], *to = buf, buf1[300], *s;
+STRLEN l;
+ULONG rc;
+if (!pre && !post)
+	return 0;
+if (pre) {
+	pre = dir_subst(pre, strlen(pre), buf1, sizeof buf1, dir_subst_pathlike, msg);
+	if (!pre)
+	    return ERROR_INVALID_PARAMETER;
+	l = strlen(pre);
+	if (l >= sizeof(buf)/2)
+	    return ERROR_BUFFER_OVERFLOW;
+	s = pre - 1;
+	while (*++s)
+	    if (*s == '/')
+		*s = '\\';			/* Be extra cautious */
+	memcpy(to, pre, l);
+	if (!l || to[l-1] != ';')
+	    to[l++] = ';';
+	to += l;
+}
+if (!replace) {
+to[0] = 1; to[1] = 0;		/* Sometimes no error reported */
+rc = ExtLIBPATH(ORD_DosQueryExtLibpath, to, type, 0);	/* Do not croak */
+if (rc)
+	return rc;
+if (to[0] == 1 && to[1] == 0)
+	return ERROR_INVALID_PARAMETER;
+to += strlen(to);
+if (buf + sizeof(buf) - 1 <= to)	/* Buffer overflow */
+	early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `",
+		    buf, "'\r\n");		/* Will not return */
+if (to > buf && to[-1] != ';')
+	*to++ = ';';
+}
+if (post) {
+	post = dir_subst(post, strlen(post), buf1, sizeof buf1, dir_subst_pathlike, msg);
+	if (!post)
+	    return ERROR_INVALID_PARAMETER;
+	l = strlen(post);
+	if (l + to - buf >= sizeof(buf) - 1)
+	    return ERROR_BUFFER_OVERFLOW;
+	s = post - 1;
+	while (*++s)
+	    if (*s == '/')
+		*s = '\\';			/* Be extra cautious */
+	memcpy(to, post, l);
+	if (!l || to[l-1] != ';')
+	    to[l++] = ';';
+	to += l;
+}
+*to = 0;
+rc = ExtLIBPATH(ORD_DosSetExtLibpath, buf, type, 0); /* Do not croak */
+return rc;
+}
+/* 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))
+static SV*
+module_name_at(void *pp, enum module_name_how how)
+{
+dTHX;
+char buf[MAXPATHLEN];
+char *p = buf;
+HMODULE mod;
+ULONG obj, offset, rc, addr = (ULONG)pp;
+if (how & mod_name_HMODULE) {
+	if ((how & ~mod_name_HMODULE) == mod_name_shortname)
+	    Perl_croak(aTHX_ "Can't get short module name from a handle");
+	mod = (HMODULE)pp;
+	how &= ~mod_name_HMODULE;
+} else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr))
+	return &PL_sv_undef;
+if (how == mod_name_handle)
+	return newSVuv(mod);
+/* Full name... */
+if ( how != mod_name_shortname
+	 && 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))) {
+	dTHX;
+	if (how & mod_name_C_function)
+	    return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function);
+	else if (how & mod_name_HMODULE)
+	    return module_name_at((void*)SvIV(cv), how);
+	Perl_croak(aTHX_ "Not an XSUB reference");
+}
+return module_name_at(CvXSUB(SvRV(cv)), 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);
+}
+DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo,
+			(ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum),
+			(r1, r2, buf, szbuf, fnum))
+XS(XS_OS2__headerInfo)
+{
+dXSARGS;
+if (items > 4 || items < 2)
+	Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])");
+{
+	ULONG	req = (ULONG)SvIV(ST(0));
+	STRLEN	size = (STRLEN)SvIV(ST(1)), n_a;
+	ULONG	handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0);
+	ULONG	offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0);
+	if (size <= 0)
+	    Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size);
+	ST(0) = newSVpvs("");
+	SvGROW(ST(0), size + 1);
+	sv_2mortal(ST(0));
+	if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req))
+	    Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
+		       req, size, handle, offset, os2error(Perl_rc));
+	SvCUR_set(ST(0), size);
+	*SvEND(ST(0)) = 0;
+}
+XSRETURN(1);
+}
+#define DQHI_QUERYLIBPATHSIZE      4
+#define DQHI_QUERYLIBPATH          5
+XS(XS_OS2_libPath)
+{
+dXSARGS;
+if (items != 0)
+	Perl_croak(aTHX_ "Usage: OS2::libPath()");
+{
+	ULONG	size;
+	STRLEN	n_a;
+	if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size),
+				   DQHI_QUERYLIBPATHSIZE))
+	    Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
+		       DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0,
+		       os2error(Perl_rc));
+	ST(0) = newSVpvs("");
+	SvGROW(ST(0), size + 1);
+	sv_2mortal(ST(0));
+	/* We should be careful: apparently, this entry point does not
+	   pay attention to the size argument, so may overwrite
+	   unrelated data! */
+	if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size,
+				   DQHI_QUERYLIBPATH))
+	    Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
+		       DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc));
+	SvCUR_set(ST(0), size);
+	*SvEND(ST(0)) = 0;
+}
+XSRETURN(1);
+}
+#define get_control87()		_control87(0,0)
+#define set_control87		_control87
+XS(XS_OS2__control87)
+{
+dXSARGS;
+if (items != 2)
+	Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
+{
+	unsigned	new = (unsigned)SvIV(ST(0));
+	unsigned	mask = (unsigned)SvIV(ST(1));
+	unsigned	RETVAL;
+	dXSTARG;
+	RETVAL = _control87(new, mask);
+	XSprePUSH; PUSHi((IV)RETVAL);
+}
+XSRETURN(1);
+}
+XS(XS_OS2_mytype)
+{
+dXSARGS;
+int which = 0;
+if (items < 0 || items > 1)
+	Perl_croak(aTHX_ "Usage: OS2::mytype([which])");
+if (items == 1)
+	which = (int)SvIV(ST(0));
+{
+	unsigned	RETVAL;
+	dXSTARG;
+	switch (which) {
+	case 0:
+	    RETVAL = os2_mytype;	/* Reset after fork */
+	    break;
+	case 1:
+	    RETVAL = os2_mytype_ini;	/* Before any fork */
+	    break;
+	case 2:
+	    RETVAL = Perl_os2_initial_mode;	/* Before first morphing */
+	    break;
+	case 3:
+	    RETVAL = my_type();		/* Morphed type */
+	    break;
+	default:
+	    Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which);
+	}
+	XSprePUSH; PUSHi((IV)RETVAL);
+}
+XSRETURN(1);
+}
+XS(XS_OS2_mytype_set)
+{
+dXSARGS;
+int type;
+if (items == 1)
+	type = (int)SvIV(ST(0));
+else
+	Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)");
+my_type_set(type);
+XSRETURN_YES;
+}
+XS(XS_OS2_get_control87)
+{
+dXSARGS;
+if (items != 0)
+	Perl_croak(aTHX_ "Usage: OS2::get_control87()");
+{
+	unsigned	RETVAL;
+	dXSTARG;
+	RETVAL = get_control87();
+	XSprePUSH; PUSHi((IV)RETVAL);
+}
+XSRETURN(1);
+}
+XS(XS_OS2_set_control87)
+{
+dXSARGS;
+if (items < 0 || items > 2)
+	Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
+{
+	unsigned	new;
+	unsigned	mask;
+	unsigned	RETVAL;
+	dXSTARG;
+	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);
+	XSprePUSH; PUSHi((IV)RETVAL);
+}
+XSRETURN(1);
+}
+XS(XS_OS2_incrMaxFHandles)		/* DosSetRelMaxFH */
+{
+dXSARGS;
+if (items < 0 || items > 1)
+	Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)");
+{
+	LONG	delta;
+	ULONG	RETVAL, rc;
+	dXSTARG;
+	if (items < 1)
+	    delta = 0;
+	else
+	    delta = (LONG)SvIV(ST(0));
+	if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL)))
+	    croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error");
+	XSprePUSH; PUSHu((UV)RETVAL);
+}
+XSRETURN(1);
+}
+/* wait>0: force wait, wait<0: force nowait;
+if restore, save/restore flags; otherwise flags are in oflags.
+Returns 1 if connected, 0 if not (due to nowait); croaks on error. */
+static ULONG
+connectNPipe(ULONG hpipe, int wait, ULONG restore, ULONG oflags)
+{
+ULONG ret = ERROR_INTERRUPT, rc, flags;
+if (restore && wait)
+	os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()");
+/* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */
+oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE);
+flags = (oflags & ~NP_NOWAIT) | (wait > 0 ? NP_WAIT : NP_NOWAIT);
+/* We know (o)flags unless wait == 0 && restore */
+if (wait && (flags != oflags))
+	os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()");
+while (ret == ERROR_INTERRUPT)
+	ret = DosConnectNPipe(hpipe);
+(void)CheckOSError(ret);
+if (restore && wait && (flags != oflags))
+	os2cp_croak(DosSetNPHState(hpipe, oflags), "DosSetNPHState() back");
+/* We know flags unless wait == 0 && restore */
+if ( ((wait || restore) ? (flags & NP_NOWAIT) : 1)
+	 && (ret == ERROR_PIPE_NOT_CONNECTED) )
+	return 0;			/* normal return value */
+if (ret == NO_ERROR)
+	return 1;
+croak_with_os2error("DosConnectNPipe()");
+}
+/* With a lot of manual editing:
+NO_OUTPUT ULONG
+DosCreateNPipe(PCSZ pszName, OUTLIST HPIPE hpipe, ULONG ulOpenMode, int connect = 1, int count = 1, ULONG ulInbufLength = 8192, ULONG ulOutbufLength = ulInbufLength, ULONG ulPipeMode = count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ULONG ulTimeout = 0)
+PREINIT:
+	ULONG rc;
+C_ARGS:
+	pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout
+POSTCALL:
+	if (CheckOSError(RETVAL))
+	    croak_with_os2error("OS2::mkpipe() error");
+*/
+XS(XS_OS2_pipe); /* prototype to pass -Wmissing-prototypes */
+XS(XS_OS2_pipe)
+{
+dXSARGS;
+if (items < 2 || items > 8)
+	Perl_croak(aTHX_ "Usage: OS2::pipe(pszName, ulOpenMode, connect= 1, count= 1, ulInbufLength= 8192, ulOutbufLength= ulInbufLength, ulPipeMode= count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ulTimeout= 0)");
+{
+	ULONG	RETVAL;
+	PCSZ	pszName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL );
+	HPIPE	hpipe;
+	SV	*OpenMode = ST(1);
+	ULONG	ulOpenMode;
+	int	connect = 0, count, message_r = 0, message = 0, b = 0;
+	ULONG	ulInbufLength,	ulOutbufLength,	ulPipeMode, ulTimeout, rc;
+	STRLEN	len;
+	char	*s, buf[10], *s1, *perltype = NULL;
+	PerlIO	*perlio;
+	double	timeout;
+	if (!pszName || !*pszName)
+	    Perl_croak(aTHX_ "OS2::pipe(): empty pipe name");
+	s = SvPV(OpenMode, len);
+	if (len == 4 && strEQ(s, "wait")) {	/* DosWaitNPipe() */
+	    ULONG ms = 0xFFFFFFFF, ret = ERROR_INTERRUPT; /* Indefinite */
+	    if (items == 3) {
+		timeout = (double)SvNV(ST(2));
+		ms = timeout * 1000;
+		if (timeout < 0)
+		    ms = 0xFFFFFFFF; /* Indefinite */
+		else if (timeout && !ms)
+		    ms = 1;
+	    } else if (items > 3)
+		Perl_croak(aTHX_ "OS2::pipe(): too many arguments for wait-for-connect: %ld", (long)items);
+	    while (ret == ERROR_INTERRUPT)
+		ret = DosWaitNPipe(pszName, ms);	/* XXXX Update ms? */
+	    os2cp_croak(ret, "DosWaitNPipe()");
+	    XSRETURN_YES;
+	}
+	if (len == 4 && strEQ(s, "call")) {	/* DosCallNPipe() */
+	    ULONG ms = 0xFFFFFFFF, got; /* Indefinite */
+	    STRLEN l;
+	    char *s;
+	    char buf[8192];
+	    STRLEN ll = sizeof(buf);
+	    char *b = buf;
+	    if (items < 3 || items > 5)
+		Perl_croak(aTHX_ "usage: OS2::pipe(pszName, 'call', write [, timeout= 0xFFFFFFFF, buffsize = 8192])");
+	    s = SvPV(ST(2), l);
+	    if (items >= 4) {
+		timeout = (double)SvNV(ST(3));
+		ms = timeout * 1000;
+		if (timeout < 0)
+		    ms = 0xFFFFFFFF; /* Indefinite */
+		else if (timeout && !ms)
+		    ms = 1;
+	    }
+	    if (items >= 5) {
+		STRLEN lll = SvUV(ST(4));
+		SV *sv = NEWSV(914, lll);
+		sv_2mortal(sv);
+		ll = lll;
+		b = SvPVX(sv);
+	    }
+	    os2cp_croak(DosCallNPipe(pszName, s, l, b, ll, &got, ms),
+			"DosCallNPipe()");
+	    XSRETURN_PVN(b, got);
+	}
+	s1 = buf;
+	if (len && len <= 3 && !(*s >= '0' && *s <= '9')) {
+	    int r, w, R, W;
+	    r = strchr(s, 'r') != 0;
+	    w = strchr(s, 'w') != 0;
+	    R = strchr(s, 'R') != 0;
+	    W = strchr(s, 'W') != 0;
+	    b = strchr(s, 'b') != 0;
+	    if (r + w + R + W + b != len || (r && R) || (w && W))
+		Perl_croak(aTHX_ "OS2::pipe(): unknown OpenMode argument: `%s'", s);
+	    if ((r || R) && (w || W))
+		ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_DUPLEX;
+	    else if (r || R)
+		ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_INBOUND;
+	    else
+		ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_OUTBOUND;
+	    if (R)
+		message = message_r = 1;
+	    if (W)
+		message = 1;
+	    else if (w && R)
+		Perl_croak(aTHX_ "OS2::pipe(): can't have message read mode for non-message pipes");
+	} else
+	    ulOpenMode = (ULONG)SvUV(OpenMode);	/* ST(1) */
+	if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX
+	     || (ulOpenMode & 0x3) == NP_ACCESS_INBOUND )
+	    *s1++ = 'r';
+	if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX )
+	    *s1++ = '+';
+	if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND )
+	    *s1++ = 'w';
+	if (b)
+	    *s1++ = 'b';
+	*s1 = 0;
+	if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX )
+	    perltype = "+<&";
+	else if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND )
+	    perltype = ">&";
+	else
+	    perltype = "<&";
+	if (items < 3)
+	    connect = -1;			/* no wait */
+	else if (SvTRUE(ST(2))) {
+	    s = SvPV(ST(2), len);
+	    if (len == 6 && strEQ(s, "nowait"))
+		connect = -1;			/* no wait */
+	    else if (len == 4 && strEQ(s, "wait"))
+		connect = 1;			/* wait */
+	    else
+		Perl_croak(aTHX_ "OS2::pipe(): unknown connect argument: `%s'", s);
+	}
+	if (items < 4)
+	    count = 1;
+	else
+	    count = (int)SvIV(ST(3));
+	if (items < 5)
+	    ulInbufLength = 8192;
+	else
+	    ulInbufLength = (ULONG)SvUV(ST(4));
+	if (items < 6)
+	    ulOutbufLength = ulInbufLength;
+	else
+	    ulOutbufLength = (ULONG)SvUV(ST(5));
+	if (count < -1 || count == 0 || count >= 255)
+	    Perl_croak(aTHX_ "OS2::pipe(): count should be -1 or between 1 and 254: %ld", (long)count);
+	if (count < 0 )
+	    count = 255;		/* Unlimited */
+	ulPipeMode = count;
+	if (items < 7)
+	    ulPipeMode |= (NP_WAIT
+			   | (message ? NP_TYPE_MESSAGE : NP_TYPE_BYTE)
+			   | (message_r ? NP_READMODE_MESSAGE : NP_READMODE_BYTE));
+	else
+	    ulPipeMode |= (ULONG)SvUV(ST(6));
+	if (items < 8)
+	    timeout = 0;
+	else
+	    timeout = (double)SvNV(ST(7));
+	ulTimeout = timeout * 1000;
+	if (timeout < 0)
+	    ulTimeout = 0xFFFFFFFF; /* Indefinite */
+	else if (timeout && !ulTimeout)
+	    ulTimeout = 1;
+	RETVAL = DosCreateNPipe(pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout);
+	if (CheckOSError(RETVAL))
+	    croak_with_os2error("OS2::pipe(): DosCreateNPipe() error");
+	if (connect)
+	    connectNPipe(hpipe, connect, 1, 0);	/* XXXX wait, retval */
+	hpipe = __imphandle(hpipe);
+	perlio = PerlIO_fdopen(hpipe, buf);
+	ST(0) = sv_newmortal();
+	{
+	    GV *gv = newGVgen("OS2::pipe");
+	    if ( do_open6(gv, perltype, strlen(perltype), perlio, NULL, 0) )
+		sv_setsv(ST(0), sv_bless(newRV((SV*)gv), gv_stashpv("IO::Handle",1)));
+	    else
+		ST(0) = &PL_sv_undef;
+	}
+}
+XSRETURN(1);
+}
+XS(XS_OS2_pipeCntl); /* prototype to pass -Wmissing-prototypes */
+XS(XS_OS2_pipeCntl)
+{
+dXSARGS;
+if (items < 2 || items > 3)
+	Perl_croak(aTHX_ "Usage: OS2::pipeCntl(pipe, op [, wait])");
+{
+	ULONG	rc;
+	PerlIO *perlio = IoIFP(sv_2io(ST(0)));
+	IV	fn = PerlIO_fileno(perlio);
+	HPIPE	hpipe = (HPIPE)fn;
+	STRLEN	len;
+	char	*s = SvPV(ST(1), len);
+	int	wait = 0, disconnect = 0, connect = 0, message = -1, query = 0;
+	int	peek = 0, state = 0, info = 0;
+	if (fn < 0)
+	    Perl_croak(aTHX_ "OS2::pipeCntl(): not a pipe");
+	if (items == 3)
+	    wait = (SvTRUE(ST(2)) ? 1 : -1);
+	switch (len) {
+	case 4:
+	    if (strEQ(s, "byte"))
+		message = 0;
+	    else if (strEQ(s, "peek"))
+		peek = 1;
+	    else if (strEQ(s, "info"))
+		info = 1;
+	    else
+		goto unknown;
+	    break;
+	case 5:
+	    if (strEQ(s, "reset"))
+		disconnect = connect = 1;
+	    else if (strEQ(s, "state"))
+		query = 1;
+	    else
+		goto unknown;
+	    break;
+	case 7:
+	    if (strEQ(s, "connect"))
+		connect = 1;
+	    else if (strEQ(s, "message"))
+		message = 1;
+	    else
+		goto unknown;
+	    break;
+	case 9:
+	    if (!strEQ(s, "readstate"))
+		goto unknown;
+	    state = 1;
+	    break;
+	case 10:
+	    if (!strEQ(s, "disconnect"))
+		goto unknown;
+	    disconnect = 1;
+	    break;
+	default:
+	  unknown:
+	    Perl_croak(aTHX_ "OS2::pipeCntl(): unknown argument: `%s'", s);
+	    break;
+	}
+	if (items == 3 && !connect)
+	    Perl_croak(aTHX_ "OS2::pipeCntl(): no wait argument for `%s'", s);
+	XSprePUSH;		/* Do not need arguments any more */
+	if (disconnect) {
+	    os2cp_croak(DosDisConnectNPipe(hpipe), "OS2::pipeCntl(): DosDisConnectNPipe()");
+	    PerlIO_clearerr(perlio);
+	}
+	if (connect) {
+	    if (!connectNPipe(hpipe, wait , 1, 0))
+		XSRETURN_IV(-1);
+	}
+	if (query) {
+	    ULONG flags;
+	    os2cp_croak(DosQueryNPHState(hpipe, &flags), "DosQueryNPHState()");
+	    XSRETURN_UV(flags);
+	}
+	if (peek || state || info) {
+	    ULONG BytesRead, PipeState;
+	    AVAILDATA BytesAvail;
+	    os2cp_croak( DosPeekNPipe(hpipe, NULL, 0, &BytesRead, &BytesAvail,
+				      &PipeState), "DosPeekNPipe() for state");
+	    if (state) {
+		EXTEND(SP, 3);
+		mPUSHu(PipeState);
+		/*   Bytes (available/in-message) */
+		mPUSHi(BytesAvail.cbpipe);
+		mPUSHi(BytesAvail.cbmessage);
+		XSRETURN(3);
+	    } else if (info) {
+		/* L S S C C C/Z*
+		   ID of the (remote) computer
+		   buffers (out/in)
+		   instances (max/actual)
+		 */
+		struct pipe_info_t {
+		    ULONG id;			/* char id[4]; */
+		    PIPEINFO pInfo;
+		    char buf[512];
+		} b;
+		int size;
+		os2cp_croak( DosQueryNPipeInfo(hpipe, 1, &b.pInfo, sizeof(b) - STRUCT_OFFSET(struct pipe_info_t, pInfo)),
+			     "DosQueryNPipeInfo(1)");
+		os2cp_croak( DosQueryNPipeInfo(hpipe, 2, &b.id, sizeof(b.id)),
+			     "DosQueryNPipeInfo(2)");
+		size = b.pInfo.cbName;
+		/* Trailing 0 is included in cbName - undocumented; so
+		   one should always extract with Z* */
+		if (size)		/* name length 254 or less */
+		    size--;
+		else
+		    size = strlen(b.pInfo.szName);
+		EXTEND(SP, 6);
+		mPUSHp(b.pInfo.szName, size);
+		mPUSHu(b.id);
+		mPUSHi(b.pInfo.cbOut);
+		mPUSHi(b.pInfo.cbIn);
+		mPUSHi(b.pInfo.cbMaxInst);
+		mPUSHi(b.pInfo.cbCurInst);
+		XSRETURN(6);
+	    } else if (BytesAvail.cbpipe == 0) {
+		XSRETURN_NO;
+	    } else {
+		SV *tmp = NEWSV(914, BytesAvail.cbpipe);
+		char *s = SvPVX(tmp);
+		sv_2mortal(tmp);
+		os2cp_croak( DosPeekNPipe(hpipe, s, BytesAvail.cbpipe, &BytesRead,
+					  &BytesAvail, &PipeState), "DosPeekNPipe()");
+		SvCUR_set(tmp, BytesRead);
+		*SvEND(tmp) = 0;
+		SvPOK_on(tmp);
+		XSprePUSH; PUSHs(tmp);
+		XSRETURN(1);
+	    }
+	}
+	if (message > -1) {
+	    ULONG oflags, flags;
+	    os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()");
+	    /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */
+	    oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE);
+	    flags = (oflags & NP_NOWAIT)
+		| (message ? NP_READMODE_MESSAGE : NP_READMODE_BYTE);
+	    if (flags != oflags)
+		os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()");
+	}
+}
+XSRETURN_YES;
+}
+/*
+NO_OUTPUT ULONG
+DosOpen(PCSZ pszFileName, OUTLIST HFILE hFile, OUTLIST ULONG ulAction, ULONG ulOpenFlags, ULONG ulOpenMode = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ULONG ulAttribute = FILE_NORMAL, ULONG ulFileSize = 0, PEAOP2 pEABuf = NULL);
+PREINIT:
+	ULONG rc;
+C_ARGS:
+	pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf
+POSTCALL:
+	if (CheckOSError(RETVAL))
+	    croak_with_os2error("OS2::open() error");
+*/
+XS(XS_OS2_open); /* prototype to pass -Wmissing-prototypes */
+XS(XS_OS2_open)
+{
+dXSARGS;
+if (items < 2 || items > 6)
+	Perl_croak(aTHX_ "Usage: OS2::open(pszFileName, ulOpenMode, ulOpenFlags= OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ulAttribute= FILE_NORMAL, ulFileSize= 0, pEABuf= NULL)");
+{
+#line 39 "pipe.xs"
+	ULONG rc;
+#line 113 "pipe.c"
+	ULONG	RETVAL;
+	PCSZ	pszFileName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL );
+	HFILE	hFile;
+	ULONG	ulAction;
+	ULONG	ulOpenMode = (ULONG)SvUV(ST(1));
+	ULONG	ulOpenFlags;
+	ULONG	ulAttribute;
+	ULONG	ulFileSize;
+	PEAOP2	pEABuf;
+	if (items < 3)
+	    ulOpenFlags = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW;
+	else {
+	    ulOpenFlags = (ULONG)SvUV(ST(2));
+	}
+	if (items < 4)
+	    ulAttribute = FILE_NORMAL;
+	else {
+	    ulAttribute = (ULONG)SvUV(ST(3));
+	}
+	if (items < 5)
+	    ulFileSize = 0;
+	else {
+	    ulFileSize = (ULONG)SvUV(ST(4));
+	}
+	if (items < 6)
+	    pEABuf = NULL;
+	else {
+	    pEABuf = (PEAOP2)SvUV(ST(5));
+	}
+	RETVAL = DosOpen(pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf);
+	if (CheckOSError(RETVAL))
+	    croak_with_os2error("OS2::open() error");
+	XSprePUSH;	EXTEND(SP,2);
+	PUSHs(sv_newmortal());
+	sv_setuv(ST(0), (UV)hFile);
+	PUSHs(sv_newmortal());
+	sv_setuv(ST(1), (UV)ulAction);
+}
+XSRETURN(2);
+}
+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::extLibpath", XS_Cwd_extLibpath, file);
+newXS("OS2::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);
+newXSproto("OS2::DevCap", XS_OS2_DevCap, file, ";$$");
+newXSproto("OS2::SysInfoFor", XS_OS2_SysInfoFor, 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);
+newXS("OS2::replaceModule", XS_OS2_replaceModule, file);
+newXS("OS2::perfSysCall", XS_OS2_perfSysCall, 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, ";$$");
+newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
+newXSproto("OS2::mytype", XS_OS2_mytype, file, ";$");
+newXSproto("OS2::mytype_set", XS_OS2_mytype_set, file, "$");
+newXSproto("OS2::_headerInfo", XS_OS2__headerInfo, file, "$$;$$");
+newXSproto("OS2::libPath", XS_OS2_libPath, file, "");
+newXSproto("OS2::Timer", XS_OS2_Timer, file, "");
+newXSproto("OS2::msCounter", XS_OS2_msCounter, file, "");
+newXSproto("OS2::ms_sleep", XS_OS2_ms_sleep, file, "$;$");
+newXSproto("OS2::_InfoTable", XS_OS2__InfoTable, file, ";$");
+newXSproto("OS2::incrMaxFHandles", XS_OS2_incrMaxFHandles, file, ";$");
+newXSproto("OS2::SysValues", XS_OS2_SysValues, file, ";$$");
+newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$");
+newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$");
+newXSproto("OS2::pipe", XS_OS2_pipe, file, "$$;$$$$$$");
+newXSproto("OS2::pipeCntl", XS_OS2_pipeCntl, file, "$$;$");
+newXSproto("OS2::open", XS_OS2_open, 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::is_static", 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;
+}
+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 *old_esp = 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" (old_esp)	);
+}
+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 osv_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" (osv_res)	);
+return osv_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;
+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_fake;
+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;
+if ( (char*)&s < (char*)oldstack + 4*1024
+	 || (char *)oldstackend < (char*)oldstack + 52*1024 )
+	early_error("It is a lunacy to try to run EMX Perl ",
+		    "with less than 64K of stack;\r\n",
+		    "  at least with non-EMX starter...\r\n");
+/* 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);
+}
+static void
+jmp_out_of_atexit(void)
+{
+if (longjmp_at_exit)
+	longjmp(at_exit_buf, 1);
+}
+extern void _CRT_term(void);
+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 */
+void
+check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
+{
+ULONG v_crt, v_emx, count = 0, rc = NO_ERROR, rc1, maybe_inited = 0;
+static HMTX hmtx_emx_init = NULLHANDLE;
+static int emx_init_done = 0;
+/*  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 */
+/* It is not DOS, so we may use OS/2 API now */
+/* Some data we manipulate is static; protect ourselves from
+calling the same API from a different thread. */
+DosEnterMustComplete(&count);
+rc1 = DosEnterCritSec();
+if (!hmtx_emx_init)
+	rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/
+else
+	maybe_inited = 1;
+if (rc != NO_ERROR)
+	hmtx_emx_init = NULLHANDLE;
+if (rc1 == NO_ERROR)
+	DosExitCritSec();
+DosExitMustComplete(&count);
+while (maybe_inited) { /* Other thread did or is doing the same now */
+	if (emx_init_done)
+	    return;
+	rc = DosRequestMutexSem(hmtx_emx_init,
+				(ULONG) SEM_INDEFINITE_WAIT);  /* Timeout (none) */
+	if (rc == ERROR_INTERRUPT)
+	    continue;
+	if (rc != NO_ERROR) {
+	    char buf[80];
+	    ULONG out;
+	    sprintf(buf,
+		    "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc);
+	    DosWrite(2, buf, strlen(buf), &out);
+	    return;
+	}
+	DosReleaseMutexSem(hmtx_emx_init);
+	return;
+}
+/*  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;
+	}
+	Newx(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;
+emx_init_done = 1;
+if (hmtx_emx_init)
+	DosReleaseMutexSem(hmtx_emx_init);
+}
+#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, *s;
+ULONG rc;
+_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 (perl_sh_installed) {
+	int l = strlen(perl_sh_installed);
+	Newx(PL_sh_path, l + 1, char);
+	memcpy(PL_sh_path, perl_sh_installed, l + 1);
+} else if ( (shell = getenv("PERL_SH_DRIVE")) ) {
+	Newx(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;
+	while (l && (shell[l-1] == '/' || shell[l-1] == '\\'))
+	    l--;
+	Newx(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] = '/';
+	}
+}
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
+MUTEX_INIT(&start_thread_mutex);
+MUTEX_INIT(&perlos2_state_mutex);
+#endif
+os2_mytype = my_type();		/* Do it before morphing.  Needed? */
+os2_mytype_ini = os2_mytype;
+Perl_os2_initial_mode = -1;		/* Uninit */
+s = getenv("PERL_BEGINLIBPATH");
+if (s)
+rc = fill_extLibpath(0, s, NULL, 1, "PERL_BEGINLIBPATH");
+else
+rc = fill_extLibpath(0, getenv("PERL_PRE_BEGINLIBPATH"), getenv("PERL_POST_BEGINLIBPATH"), 0, "PERL_(PRE/POST)_BEGINLIBPATH");
+if (!rc) {
+	s = getenv("PERL_ENDLIBPATH");
+	if (s)
+	    rc = fill_extLibpath(1, s, NULL, 1, "PERL_ENDLIBPATH");
+	else
+	    rc = fill_extLibpath(1, getenv("PERL_PRE_ENDLIBPATH"), getenv("PERL_POST_ENDLIBPATH"), 0, "PERL_(PRE/POST)_ENDLIBPATH");
+}
+if (rc) {
+	char buf[1024];
+	snprintf(buf, sizeof buf, "Error setting BEGIN/ENDLIBPATH: %s\n",
+		 os2error(rc));
+	DosWrite(2, buf, strlen(buf), &rc);
+	exit(2);
+}
+_emxload_env("PERL_EMXLOAD_SECS");
+/* Some DLLs reset FP flags on load.  We may have been linked with them */
+_control87(MCW_EM, MCW_EM);
+}
+int
+fd_ok(int fd)
+{
+static ULONG max_fh = 0;
+if (!(_emx_env & 0x200)) return 1;		/* not OS/2. */
+if (fd >= max_fh) {				/* Renew */
+	LONG delta = 0;
+	if (DosSetRelMaxFH(&delta, &max_fh))	/* Assume it OK??? */
+	    return 1;
+}
+return fd < max_fh;
+}
+/* Kernels up to Oct 2003 trap on (invalid) dup(max_fh); [off-by-one + double fault].  */
+int
+dup2(int from, int to)
+{
+if (fd_ok(from < to ? to : from))
+	return _dup2(from, to);
+errno = EBADF;
+return -1;
+}
+int
+dup(int from)
+{
+if (fd_ok(from))
+	return _dup(from);
+errno = EBADF;
+return -1;
+}
+#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
+/* EMX flavors do not tolerate trailing slashes.  t/op/mkdir.t has many
+trailing slashes, so we need to support this as well. */
+int
+my_rmdir (__const__ char *s)
+{
+char b[MAXPATHLEN];
+char *buf = b;
+STRLEN l = strlen(s);
+int rc;
+if (s[l-1] == '/' || s[l-1] == '\\') {	/* EMX mkdir fails... */
+	if (l >= sizeof b)
+	    Newx(buf, l + 1, char);
+	strcpy(buf,s);
+	while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
+	    l--;
+	buf[l] = 0;
+	s = buf;
+}
+rc = rmdir(s);
+if (b != buf)
+	Safefree(buf);
+return rc;
+}
+#undef mkdir
+int
+my_mkdir (__const__ char *s, long perm)
+{
+char b[MAXPATHLEN];
+char *buf = b;
+STRLEN l = strlen(s);
+int rc;
+if (s[l-1] == '/' || s[l-1] == '\\') {	/* EMX mkdir fails... */
+	if (l >= sizeof b)
+	    Newx(buf, l + 1, char);
+	strcpy(buf,s);
+	while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
+	    l--;
+	buf[l] = 0;
+	s = buf;
+}
+rc = mkdir(s, perm);
+if (b != buf)
+	Safefree(buf);
+return rc;
+}
+#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_flock = -1;
+if (use_my_flock == -1) {
+MUTEX_LOCK(&perlos2_state_mutex);
+if (use_my_flock == -1) {
+char *s = getenv("USE_PERL_FLOCK");
+if (s)
+	use_my_flock = atoi(s);
+else
+	use_my_flock = 1;
+}
+MUTEX_UNLOCK(&perlos2_state_mutex);
+}
+if (!(_emx_env & 0x200) || !use_my_flock)
+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
+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);
+}
+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)
+{
+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)
+{
+double absv = value > 0 ? value : -value;
+/* EMX implementation is lousy between 0.1 and 0.0001 (uses exponents below
+0.1), 1-digit stuff is ok below 0.001; multi-digit below 0.0001. */
+int buggy;
+absv *= 10000;
+buggy = (absv < 1000 && (absv >= 10 || (absv > 1 && floor(absv) != absv)));
+if (buggy) {
+char pat[12];
+sprintf(pat, "%%.%dg", digits);
+sprintf(buffer, pat, value);
+return buffer;
+}
+return gcvt (value, digits, buffer);
+}
+#undef fork
+int fork_with_resources()
+{
+#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
+dTHX;
+void *ctx = PERL_GET_CONTEXT;
+#endif
+unsigned fpflag = _control87(0,0);
+int rc = fork();
+if (rc == 0) {			/* child */
+#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
+ALLOC_THREAD_KEY;			/* Acquire the thread-local memory */
+PERL_SET_CONTEXT(ctx);		/* Reinit the thread-local memory */
+#endif
+{					/* Reload loaded-on-demand DLLs */
+	struct dll_handle_t *dlls = dll_handles;
+	while (dlls->modname) {
+	    char dllname[260], fail[260];
+	    ULONG rc;
+	    if (!dlls->handle) {	/* Was not loaded */
+		dlls++;
+		continue;
+	    }
+	    /* It was loaded in the parent.  We need to reload it. */
+	    rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname);
+	    if (rc) {
+		Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx",
+				    dlls->modname, (int)dlls->handle, rc, rc);
+		dlls++;
+		continue;
+	    }
+	    rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle);
+	    if (rc)
+		Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'",
+				    dllname, fail);
+	    dlls++;
+	}
+}
+{					/* Support message queue etc. */
+	os2_mytype = my_type();
+	/* Apparently, subprocesses (in particular, fork()) do not
+	   inherit the morphed state, so os2_mytype is the same as
+	   os2_mytype_ini. */
+	if (Perl_os2_initial_mode != -1
+	    && Perl_os2_initial_mode != os2_mytype) {
+					/* XXXX ??? */
+	}
+}
+if (Perl_HAB_set)
+	(void)_obtain_Perl_HAB;
+if (Perl_hmq_refcnt) {
+	if (my_type() != 3)
+	    my_type_set(3);
+	Create_HMQ(Perl_hmq_servers != 0,
+		   "Cannot create a message queue on fork");
+}
+/* We may have loaded some modules */
+_control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
+}
+return rc;
+}
+/* APIRET  APIENTRY DosGetInfoSeg(PSEL pselGlobal, PSEL pselLocal); */
+ULONG _THUNK_FUNCTION(Dos16GetInfoSeg)(USHORT *pGlobal, USHORT *pLocal);
+APIRET  APIENTRY
+myDosGetInfoSeg(PGINFOSEG *pGlobal, PLINFOSEG *pLocal)
+{
+APIRET rc;
+USHORT gSel, lSel;		/* Will not cross 64K boundary */
+rc = ((USHORT)
+(_THUNK_PROLOG (4+4);
+_THUNK_FLAT (&gSel);
+_THUNK_FLAT (&lSel);
+_THUNK_CALL (Dos16GetInfoSeg)));
+if (rc)
+	return rc;
+*pGlobal = MAKEPGINFOSEG(gSel);
+*pLocal  = MAKEPLINFOSEG(lSel);
+return rc;
+}
+static void
+GetInfoTables(void)
+{
+ULONG rc = 0;
+MUTEX_LOCK(&perlos2_state_mutex);
+if (!gTable)
+rc = myDosGetInfoSeg(&gTable, &lTable);
+MUTEX_UNLOCK(&perlos2_state_mutex);
+os2cp_croak(rc, "Dos16GetInfoSeg");
+}
+ULONG
+msCounter(void)
+{				/* XXXX Is not lTable thread-specific? */
+if (!gTable)
+GetInfoTables();
+return gTable->SIS_MsCount;
+}
+ULONG
+InfoTable(int local)
+{
+if (!gTable)
+GetInfoTables();
+return local ? (ULONG)lTable : (ULONG)gTable;
+}

Mercurial > repo

comparison perl-5.22.2/os2/os2.c @ 8045:a16537d2fe07