xref: /openbsd-src/gnu/usr.bin/perl/os2/os2.c (revision a28daedfc357b214be5c701aa8ba8adb29a7f1c2)

#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 = Nullsv;

      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] = Nullch;
			    }
			} else if (!buf[0] && inicmd) { /* No file */
			    /* Start with the original cmdline. */
			    /* XXXX This is good only until we refuse
			            quoted arguments... */

			    PL_Argv[0] = inicmd;
			    PL_Argv[1] = Nullch;
			    nargs = 2;	/* shell -c */
			}

			while (a[1])		/* Get to the end */
			    a++;
			a++;			/* Copy finil NULL too */
			while (a >= PL_Argv) {
			    *(a + nargs) = *a;	/* PL_Argv was preallocated to be
						   long enough. */
			    a--;
			}
			while (--nargs >= 0) /* 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)
{
    register char **a;
    register 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 = Nullch;
    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, register SV **args, I32 cnt, int execing)
{
    register SV **argp = (SV **)args;
    register SV **last = argp + cnt;
    register 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 = Nullch;

	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, register SV **vmark, register 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];
    register I32 this, that, newfd;
    register 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 (PL_tainting) {
	taint_env();
	taint_proper("Insecure %s%s", "EXEC");
    }
    if (pipe(p) < 0)
	return Nullfp;
    /* Now we need to spawn the child. */
    if (p[this] == (*mode == 'r')) {	/* if fh 0/1 was initially closed. */
	int new = dup(p[this]);

	if (new == -1)
	    goto closepipes;
	close(p[this]);
	p[this] = new;
    }
    newfd = dup(*mode == 'r');		/* Preserve std* */
    if (newfd == -1) {
	/* This cannot happen due to fh being bad after pipe(), since
	   pipe() should have created fh 0 and 1 even if they were
	   initially closed.  But we closed p[this] before.  */
	if (errno != EBADF) {
	  closepipes:
	    close(p[0]);
	    close(p[1]);
	    return Nullfp;
	}
    } else
	fh_fl = fcntl(*mode == 'r', F_GETFD);
    if (p[that] != (*mode == 'r')) {	/* if fh 0/1 was initially closed. */
	dup2(p[that], *mode == 'r');
	close(p[that]);
    }
    /* Where is `this' and newfd now? */
    fcntl(p[this], F_SETFD, FD_CLOEXEC);
    if (newfd != -1)
	fcntl(newfd, F_SETFD, FD_CLOEXEC);
    if (cnt) {	/* Args: "Real cmd", before first arg, the last, execing */
	pid = os2_aspawn_4(aTHX_ Nullsv, 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 Nullfp;
    }
    if (p[that] < p[this]) {		/* Make fh as small as possible */
	dup2(p[this], p[that]);
	close(p[this]);
	p[this] = p[that];
    }
    sv = *av_fetch(PL_fdpid,p[this],TRUE);
    (void)SvUPGRADE(sv,SVt_IV);
    SvIVX(sv) = pid;
    PL_forkprocess = pid;
    return PerlIO_fdopen(p[this], mode);

#else  /* USE_POPEN */

    PerlIO *res;
    SV *sv;

    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) ? Nullch : (char *)SvPV_nolen(ST(1));
	char *	backup = (items < 3) ? Nullch : (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_len((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", TRUE));

        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 = Nullsv;

    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);
#ifndef INCOMPLETE_TAINTS
	SvTAINTED_on(ST(0));
#endif
    }
    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));
	}
#ifndef INCOMPLETE_TAINTS
	if (!items)
	    SvTAINTED_on(ST(0));
#endif
    }
    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 causious */
	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 causious */
	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) = newSVpvn("",0);
	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) = newSVpvn("",0);
	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(ST(0),PL_na) : 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 = Nullch;
	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_open(gv, perltype, strlen(perltype), FALSE, 0, 0, perlio) )
		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);
		PUSHs(newSVuv(PipeState));
		/*   Bytes (available/in-message) */
		PUSHs(newSViv(BytesAvail.cbpipe));
		PUSHs(newSViv(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);
		PUSHs(newSVpvn(b.pInfo.szName, size));
		PUSHs(newSVuv(b.id));
		PUSHs(newSViv(b.pInfo.cbOut));
		PUSHs(newSViv(b.pInfo.cbIn));
		PUSHs(newSViv(b.pInfo.cbMaxInst));
		PUSHs(newSViv(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(ST(0),PL_na) : 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;
}