[p5sagit/p5-mst-13.2.git] / os2 / os2.c

#define INCL_DOS
#define INCL_NOPM
#define INCL_DOSFILEMGR
#ifndef NO_SYS_ALLOC 
#  define INCL_DOSMEMMGR
#  define INCL_DOSERRORS
#endif /* ! defined NO_SYS_ALLOC */
#include <os2.h>

/*
 * Various Unix compatibility functions for OS/2
 */

#include <stdio.h>
#include <errno.h>
#include <limits.h>
#include <process.h>

#include "EXTERN.h"
#include "perl.h"

/*****************************************************************************/
/* priorities */
static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
					       self inverse. */
#define QSS_INI_BUFFER 1024

PQTOPLEVEL
get_sysinfo(ULONG pid, ULONG flags)
{
    char *pbuffer;
    ULONG rc, buf_len = QSS_INI_BUFFER;

    New(1022, pbuffer, buf_len, char);
    /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
    rc = QuerySysState(flags, pid, pbuffer, buf_len);
    while (rc == ERROR_BUFFER_OVERFLOW) {
	Renew(pbuffer, buf_len *= 2, char);
	rc = QuerySysState(QSS_PROCESS, pid, pbuffer, buf_len);
    }
    if (rc) {
	FillOSError(rc);
	Safefree(pbuffer);
	return 0;
    }
    return (PQTOPLEVEL)pbuffer;
}

#define PRIO_ERR 0x1111

static ULONG
sys_prio(pid)
{
  ULONG prio;
  PQTOPLEVEL psi;

  psi = get_sysinfo(pid, QSS_PROCESS);
  if (!psi) {
      return PRIO_ERR;
  }
  if (pid != psi->procdata->pid) {
      Safefree(psi);
      croak("panic: wrong pid in sysinfo");
  }
  prio = psi->procdata->threads->priority;
  Safefree(psi);
  return prio;
}

int 
setpriority(int which, int pid, int val)
{
  ULONG rc, prio;
  PQTOPLEVEL psi;

  prio = sys_prio(pid);

  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;
  } 
/*   else return CheckOSError(DosSetPriority((pid < 0)  */
/* 					  ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
/* 					  priors[(32 - val) >> 5] + 1,  */
/* 					  (32 - val) % 32 - (prio & 0xFF),  */
/* 					  abs(pid))) */
/*       ? -1 : 0; */
}

int 
getpriority(int which /* ignored */, int pid)
{
  TIB *tib;
  PIB *pib;
  ULONG rc, ret;

  /* DosGetInfoBlocks has old priority! */
/*   if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
/*   if (pid != pib->pib_ulpid) { */
  ret = sys_prio(pid);
  if (ret == PRIO_ERR) {
      return -1;
  }
/*   } else */
/*       ret = tib->tib_ptib2->tib2_ulpri; */
  return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
}

/*****************************************************************************/
/* spawn */

static int
result(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() */

	if (pid < 0 || flag != 0) 
		return pid;

	ihand = signal(SIGINT, SIG_IGN);
	qhand = signal(SIGQUIT, SIG_IGN);
	do {
	    r = wait4pid(pid, &status, 0);
	} while (r == -1 && errno == EINTR);
	signal(SIGINT, ihand);
	signal(SIGQUIT, qhand);

	statusvalue = (U16)status;
	if (r < 0)
		return -1;
	return status & 0xFFFF;
}

int
do_aspawn(really,mark,sp)
SV *really;
register SV **mark;
register SV **sp;
{
    register char **a;
    char *tmps;
    int rc;
    int flag = P_WAIT, trueflag;

    if (sp > mark) {
	New(401,Argv, sp - mark + 1, char*);
	a = Argv;

	if (mark < sp && SvIOKp(*(mark+1))) {
		++mark;
		flag = SvIVx(*mark);
	}

	while (++mark <= sp) {
	    if (*mark)
		*a++ = SvPVx(*mark, na);
	    else
		*a++ = "";
	}
	*a = Nullch;

	trueflag = flag;
	if (flag == P_WAIT)
		flag = P_NOWAIT;

	if (*Argv[0] != '/' && *Argv[0] != '\\') /* will swawnvp use PATH? */
	    TAINT_ENV();	/* testing IFS here is overkill, probably */
	if (really && *(tmps = SvPV(really, na)))
	    rc = result(trueflag, spawnvp(flag,tmps,Argv));
	else
	    rc = result(trueflag, spawnvp(flag,Argv[0],Argv));

	if (rc < 0 && dowarn)
	    warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
	if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
    } else
    	rc = -1;
    do_execfree();
    return rc;
}

int
do_spawn(cmd)
char *cmd;
{
    register char **a;
    register char *s;
    char flags[10];
    char *shell, *copt;
    int rc;

#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 = SH_PATH;
    copt = "-c";
#endif 

    while (*cmd && isSPACE(*cmd))
	cmd++;

    /* 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]) {
		*s = '\0';
		break;
	    }
	  doshell:
	    rc = result(P_WAIT,
			  spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
	    if (rc < 0 && dowarn)
		warn("Can't spawn \"%s\": %s", shell, Strerror(errno));
	    if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
	    return rc;
	}
    }

    New(402,Argv, (s - cmd) / 2 + 2, char*);
    Cmd = savepvn(cmd, s-cmd);
    a = Argv;
    for (s = Cmd; *s;) {
	while (*s && isSPACE(*s)) s++;
	if (*s)
	    *(a++) = s;
	while (*s && !isSPACE(*s)) s++;
	if (*s)
	    *s++ = '\0';
    }
    *a = Nullch;
    if (Argv[0]) {
	rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
	if (rc < 0 && dowarn)
	    warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
	if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
    } else
    	rc = -1;
    do_execfree();
    return rc;
}

#ifndef HAS_FORK
FILE *
my_popen(cmd,mode)
char	*cmd;
char	*mode;
{
    char *shell = getenv("EMXSHELL");
    FILE *res;
    
    my_setenv("EMXSHELL", SH_PATH);
    res = popen(cmd, mode);
    my_setenv("EMXSHELL", shell);
    return res;
}
#endif

/*****************************************************************************/

#ifndef HAS_FORK
int
fork(void)
{
    die(no_func, "Unsupported function fork");
    errno = EINVAL;
    return -1;
}
#endif

/*****************************************************************************/
/* not implemented in EMX 0.9a */

void *	ctermid(x)	{ return 0; }

#ifdef MYTTYNAME /* was not in emx0.9a */
void *	ttyname(x)	{ return 0; }
#endif

void *	gethostent()	{ return 0; }
void *	getnetent()	{ return 0; }
void *	getprotoent()	{ return 0; }
void *	getservent()	{ return 0; }
void	sethostent(x)	{}
void	setnetent(x)	{}
void	setprotoent(x)	{}
void	setservent(x)	{}
void	endhostent(x)	{}
void	endnetent(x)	{}
void	endprotoent(x)	{}
void	endservent(x)	{}

/*****************************************************************************/
/* stat() hack for char/block device */

#if OS2_STAT_HACK

    /* First attempt used DosQueryFSAttach which crashed the system when
       used with 5.001. Now just look for /dev/. */

int
os2_stat(char *name, struct stat *st)
{
    static int ino = SHRT_MAX;

    if (stricmp(name, "/dev/con") != 0
     && stricmp(name, "/dev/tty") != 0)
	return stat(name, st);

    memset(st, 0, sizeof *st);
    st->st_mode = S_IFCHR|0666;
    st->st_ino = (ino-- & 0x7FFF);
    st->st_nlink = 1;
    return 0;
}

#endif

#ifndef NO_SYS_ALLOC

static char *oldchunk;
static long oldsize;

#define _32_K (1<<15)
#define _64_K (1<<16)

/* The real problem is that DosAllocMem will grant memory on 64K-chunks
 * boundaries only. Note that addressable space for application memory
 * is around 240M, thus we will run out of addressable space if we
 * allocate around 14M worth of 4K segments.
 * Thus we allocate memory in 64K chunks, and abandon the rest of the old
 * chunk if the new is bigger than that rest. Also, we just allocate
 * whatever is requested if the size is bigger that 32K. With this strategy
 * we cannot lose more than 1/2 of addressable space. */

void *
sbrk(int size)
{
    char *got;
    APIRET rc;
    int small, reqsize;

    if (!size) return 0;
    else if (size <= oldsize) {
	got = oldchunk;
	oldchunk += size;
	oldsize -= size;
	return (void *)got;
    } else if (size >= _32_K) {
	small = 0;
    } else {
	reqsize = size;
	size = _64_K;
	small = 1;
    }
    rc = DosAllocMem((void **)&got, size, PAG_COMMIT | PAG_WRITE);
    if (rc == ERROR_NOT_ENOUGH_MEMORY) {
	return (void *) -1;
    } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
    if (small) {
	/* Chunk is small, register the rest for future allocs. */
	oldchunk = got + reqsize;
	oldsize = size - reqsize;
    }
    return (void *)got;
}
#endif /* ! defined NO_SYS_ALLOC */

/* tmp path */

char *tmppath = TMPPATH1;

void
settmppath()
{
    char *p = getenv("TMP"), *tpath;
    int len;

    if (!p) p = getenv("TEMP");
    if (!p) return;
    len = strlen(p);
    tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
    strcpy(tpath, p);
    tpath[len] = '/';
    strcpy(tpath + len + 1, TMPPATH1);
    tmppath = tpath;
}

#include "XSUB.h"

XS(XS_File__Copy_syscopy)
{
    dXSARGS;
    if (items < 2 || items > 3)
	croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
    {
	char *	src = (char *)SvPV(ST(0),na);
	char *	dst = (char *)SvPV(ST(1),na);
	U32	flag;
	int	RETVAL, rc;

	if (items < 3)
	    flag = 0;
	else {
	    flag = (unsigned long)SvIV(ST(2));
	}

	RETVAL = !CheckOSError(DosCopy(src, dst, flag));
	ST(0) = sv_newmortal();
	sv_setiv(ST(0), (IV)RETVAL);
    }
    XSRETURN(1);
}

char *
mod2fname(sv)
     SV   *sv;
{
    static char fname[9];
    int pos = 7;
    int len;
    AV  *av;
    SV  *svp;
    char *s;

    if (!SvROK(sv)) croak("Not a reference given to mod2fname");
    sv = SvRV(sv);
    if (SvTYPE(sv) != SVt_PVAV) 
      croak("Not array reference given to mod2fname");
    if (av_len((AV*)sv) < 0) 
      croak("Empty array reference given to mod2fname");
    s = SvPV(*av_fetch((AV*)sv, av_len((AV*)sv), FALSE), na);
    strncpy(fname, s, 8);
    if ((len=strlen(s)) < 7) pos = len;
    fname[pos] = '_';
    fname[pos + 1] = '\0';
    return (char *)fname;
}

XS(XS_DynaLoader_mod2fname)
{
    dXSARGS;
    if (items != 1)
	croak("Usage: DynaLoader::mod2fname(sv)");
    {
	SV *	sv = ST(0);
	char *	RETVAL;

	RETVAL = mod2fname(sv);
	ST(0) = sv_newmortal();
	sv_setpv((SV*)ST(0), RETVAL);
    }
    XSRETURN(1);
}

char *
os2error(int rc)
{
	static char buf[300];
	ULONG len;

	if (rc == 0)
		return NULL;
	if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
		sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
	else
		buf[len] = '\0';
	return buf;
}

OS2_Perl_data_t OS2_Perl_data;

int
Xs_OS2_init()
{
    char *file = __FILE__;
    {
	GV *gv;
	
        newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
        newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
#ifdef PERL_IS_AOUT
	gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
	GvMULTI_on(gv);
	sv_setiv(GvSV(gv), 1);
#endif 
    }
}

void
Perl_OS2_init()
{
    char *shell;

    settmppath();
    OS2_Perl_data.xs_init = &Xs_OS2_init;
    if ( (shell = getenv("PERL_SH_DRIVE")) ) {
	sh_path[0] = shell[0];
    }
}

char sh_path[33] = BIN_SH;

extern void dlopen();
void *fakedl = &dlopen;		/* Pull in dynaloading part. */
Commit	Line	Data
4633a7c4	1	#define INCL_DOS
4633a7c4	2	#define INCL_NOPM
7a2f0d5b	3	#define INCL_DOSFILEMGR
c0c09dfd	4	#ifndef NO_SYS_ALLOC
	5	# define INCL_DOSMEMMGR
	6	# define INCL_DOSERRORS
	7	#endif /* ! defined NO_SYS_ALLOC */
4633a7c4	8	#include <os2.h>
	9
	10	/*
	11	* Various Unix compatibility functions for OS/2
	12	*/
	13
	14	#include <stdio.h>
	15	#include <errno.h>
	16	#include <limits.h>
	17	#include <process.h>
	18
	19	#include "EXTERN.h"
	20	#include "perl.h"
	21
	22	/*****************************************************************************/
	23	/* priorities */
6f064249	24	static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
	25	self inverse. */
	26	#define QSS_INI_BUFFER 1024
4633a7c4	27
6f064249	28	PQTOPLEVEL
6f064249	29	get_sysinfo(ULONG pid, ULONG flags)
4633a7c4	30	{
6f064249	31	char *pbuffer;
	32	ULONG rc, buf_len = QSS_INI_BUFFER;
	33
	34	New(1022, pbuffer, buf_len, char);
	35	/* QSS_PROCESS \| QSS_MODULE \| QSS_SEMAPHORES \| QSS_SHARED */
	36	rc = QuerySysState(flags, pid, pbuffer, buf_len);
	37	while (rc == ERROR_BUFFER_OVERFLOW) {
	38	Renew(pbuffer, buf_len *= 2, char);
	39	rc = QuerySysState(QSS_PROCESS, pid, pbuffer, buf_len);
	40	}
	41	if (rc) {
	42	FillOSError(rc);
	43	Safefree(pbuffer);
	44	return 0;
	45	}
	46	return (PQTOPLEVEL)pbuffer;
	47	}
	48
	49	#define PRIO_ERR 0x1111
	50
	51	static ULONG
	52	sys_prio(pid)
	53	{
	54	ULONG prio;
	55	PQTOPLEVEL psi;
	56
	57	psi = get_sysinfo(pid, QSS_PROCESS);
	58	if (!psi) {
	59	return PRIO_ERR;
	60	}
	61	if (pid != psi->procdata->pid) {
	62	Safefree(psi);
	63	croak("panic: wrong pid in sysinfo");
	64	}
	65	prio = psi->procdata->threads->priority;
	66	Safefree(psi);
	67	return prio;
	68	}
	69
	70	int
	71	setpriority(int which, int pid, int val)
	72	{
	73	ULONG rc, prio;
	74	PQTOPLEVEL psi;
	75
	76	prio = sys_prio(pid);
	77
	78	if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
	79	/* Do not change class. */
	80	return CheckOSError(DosSetPriority((pid < 0)
	81	? PRTYS_PROCESSTREE : PRTYS_PROCESS,
	82	0,
	83	(32 - val) % 32 - (prio & 0xFF),
	84	abs(pid)))
	85	? -1 : 0;
	86	} else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
	87	/* Documentation claims one can change both class and basevalue,
	88	* but I find it wrong. */
	89	/* Change class, but since delta == 0 denotes absolute 0, correct. */
	90	if (CheckOSError(DosSetPriority((pid < 0)
	91	? PRTYS_PROCESSTREE : PRTYS_PROCESS,
	92	priors[(32 - val) >> 5] + 1,
	93	0,
	94	abs(pid))))
95	return -1;
96	if ( ((32 - val) % 32) == 0 ) return 0;
97	return CheckOSError(DosSetPriority((pid < 0)
98	? PRTYS_PROCESSTREE : PRTYS_PROCESS,
99	0,
100	(32 - val) % 32,
101	abs(pid)))
102	? -1 : 0;
103	}
104	/* else return CheckOSError(DosSetPriority((pid < 0) */
105	/* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
106	/* priors[(32 - val) >> 5] + 1, */
107	/* (32 - val) % 32 - (prio & 0xFF), */
108	/* abs(pid))) */
109	/* ? -1 : 0; */
4633a7c4	110	}
4633a7c4	111
6f064249	112	int
6f064249	113	getpriority(int which /* ignored */, int pid)
4633a7c4	114	{
	115	TIB *tib;
	116	PIB *pib;
6f064249	117	ULONG rc, ret;
	118
	119	/* DosGetInfoBlocks has old priority! */
	120	/* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
	121	/* if (pid != pib->pib_ulpid) { */
	122	ret = sys_prio(pid);
	123	if (ret == PRIO_ERR) {
	124	return -1;
	125	}
	126	/* } else */
	127	/* ret = tib->tib_ptib2->tib2_ulpri; */
	128	return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
4633a7c4	129	}
	130
	131	/*****************************************************************************/
	132	/* spawn */
	133
	134	static int
	135	result(int flag, int pid)
	136	{
	137	int r, status;
	138	Signal_t (ihand)(); / place to save signal during system() */
	139	Signal_t (qhand)(); / place to save signal during system() */
	140
c0c09dfd	141	if (pid < 0 \|\| flag != 0)
4633a7c4	142	return pid;
	143
	144	ihand = signal(SIGINT, SIG_IGN);
	145	qhand = signal(SIGQUIT, SIG_IGN);
c0c09dfd	146	do {
	147	r = wait4pid(pid, &status, 0);
	148	} while (r == -1 && errno == EINTR);
4633a7c4	149	signal(SIGINT, ihand);
	150	signal(SIGQUIT, qhand);
	151
	152	statusvalue = (U16)status;
	153	if (r < 0)
	154	return -1;
	155	return status & 0xFFFF;
	156	}
	157
	158	int
	159	do_aspawn(really,mark,sp)
	160	SV *really;
	161	register SV **mark;
	162	register SV **sp;
	163	{
	164	register char **a;
	165	char *tmps;
	166	int rc;
	167	int flag = P_WAIT, trueflag;
	168
	169	if (sp > mark) {
	170	New(401,Argv, sp - mark + 1, char*);
	171	a = Argv;
	172
	173	if (mark < sp && SvIOKp(*(mark+1))) {
	174	++mark;
	175	flag = SvIVx(*mark);
	176	}
	177
	178	while (++mark <= sp) {
	179	if (*mark)
	180	a++ = SvPVx(mark, na);
	181	else
	182	*a++ = "";
	183	}
	184	*a = Nullch;
	185
	186	trueflag = flag;
	187	if (flag == P_WAIT)
	188	flag = P_NOWAIT;
	189
c0c09dfd	190	if (Argv[0] != '/' && Argv[0] != '\\') /* will swawnvp use PATH? */
c0c09dfd	191	TAINT_ENV(); /* testing IFS here is overkill, probably */
4633a7c4	192	if (really && *(tmps = SvPV(really, na)))
	193	rc = result(trueflag, spawnvp(flag,tmps,Argv));
	194	else
	195	rc = result(trueflag, spawnvp(flag,Argv[0],Argv));
	196
	197	if (rc < 0 && dowarn)
	198	warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
c0c09dfd	199	if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
4633a7c4	200	} else
	201	rc = -1;
	202	do_execfree();
	203	return rc;
	204	}
	205
	206	int
	207	do_spawn(cmd)
	208	char *cmd;
	209	{
	210	register char **a;
	211	register char *s;
	212	char flags[10];
	213	char shell, copt;
	214	int rc;
	215
c0c09dfd	216	#ifdef TRYSHELL
	217	if ((shell = getenv("EMXSHELL")) != NULL)
	218	copt = "-c";
	219	else if ((shell = getenv("SHELL")) != NULL)
4633a7c4	220	copt = "-c";
	221	else if ((shell = getenv("COMSPEC")) != NULL)
	222	copt = "/C";
	223	else
	224	shell = "cmd.exe";
c0c09dfd	225	#else
	226	/* Consensus on perl5-porters is that it is _very_ important to
	227	have a shell which will not change between computers with the
	228	same architecture, to avoid "action on a distance".
	229	And to have simple build, this shell should be sh. */
6f064249	230	shell = SH_PATH;
c0c09dfd	231	copt = "-c";
	232	#endif
	233
	234	while (cmd && isSPACE(cmd))
	235	cmd++;
4633a7c4	236
	237	/* save an extra exec if possible */
	238	/* see if there are shell metacharacters in it */
	239
c0c09dfd	240	if (*cmd == '.' && isSPACE(cmd[1]))
	241	goto doshell;
	242
	243	if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
	244	goto doshell;
	245
	246	for (s = cmd; s && isALPHA(s); s++) ; /* catch VAR=val gizmo */
	247	if (*s == '=')
	248	goto doshell;
	249
4633a7c4	250	for (s = cmd; *s; s++) {
c0c09dfd	251	if (s != ' ' && !isALPHA(s) && strchr("$&(){}[]'\";\\\|?<>~`\n",s)) {
4633a7c4	252	if (*s == '\n' && !s[1]) {
	253	*s = '\0';
	254	break;
	255	}
c0c09dfd	256	doshell:
	257	rc = result(P_WAIT,
	258	spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
	259	if (rc < 0 && dowarn)
	260	warn("Can't spawn \"%s\": %s", shell, Strerror(errno));
	261	if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
	262	return rc;
4633a7c4	263	}
4633a7c4	264	}
c0c09dfd	265
4633a7c4	266	New(402,Argv, (s - cmd) / 2 + 2, char*);
	267	Cmd = savepvn(cmd, s-cmd);
	268	a = Argv;
	269	for (s = Cmd; *s;) {
	270	while (s && isSPACE(s)) s++;
	271	if (*s)
	272	*(a++) = s;
	273	while (s && !isSPACE(s)) s++;
	274	if (*s)
	275	*s++ = '\0';
	276	}
	277	*a = Nullch;
	278	if (Argv[0]) {
	279	rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
	280	if (rc < 0 && dowarn)
	281	warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
c0c09dfd	282	if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
4633a7c4	283	} else
	284	rc = -1;
	285	do_execfree();
	286	return rc;
	287	}
	288
6f064249	289	#ifndef HAS_FORK
c0c09dfd	290	FILE *
	291	my_popen(cmd,mode)
	292	char *cmd;
	293	char *mode;
	294	{
	295	char *shell = getenv("EMXSHELL");
	296	FILE *res;
	297
6f064249	298	my_setenv("EMXSHELL", SH_PATH);
c0c09dfd	299	res = popen(cmd, mode);
	300	my_setenv("EMXSHELL", shell);
	301	return res;
	302	}
6f064249	303	#endif
c0c09dfd	304
4633a7c4	305	/*****************************************************************************/
	306
	307	#ifndef HAS_FORK
	308	int
	309	fork(void)
	310	{
	311	die(no_func, "Unsupported function fork");
	312	errno = EINVAL;
	313	return -1;
	314	}
	315	#endif
	316
	317	/*****************************************************************************/
	318	/* not implemented in EMX 0.9a */
	319
	320	void * ctermid(x) { return 0; }
eacfb5f1	321
eacfb5f1	322	#ifdef MYTTYNAME /* was not in emx0.9a */
4633a7c4	323	void * ttyname(x) { return 0; }
eacfb5f1	324	#endif
4633a7c4	325
	326	void * gethostent() { return 0; }
	327	void * getnetent() { return 0; }
	328	void * getprotoent() { return 0; }
	329	void * getservent() { return 0; }
	330	void sethostent(x) {}
	331	void setnetent(x) {}
	332	void setprotoent(x) {}
	333	void setservent(x) {}
	334	void endhostent(x) {}
	335	void endnetent(x) {}
	336	void endprotoent(x) {}
	337	void endservent(x) {}
	338
	339	/*****************************************************************************/
	340	/* stat() hack for char/block device */
	341
	342	#if OS2_STAT_HACK
	343
	344	/* First attempt used DosQueryFSAttach which crashed the system when
	345	used with 5.001. Now just look for /dev/. */
	346
	347	int
	348	os2_stat(char name, struct stat st)
	349	{
	350	static int ino = SHRT_MAX;
	351
	352	if (stricmp(name, "/dev/con") != 0
	353	&& stricmp(name, "/dev/tty") != 0)
	354	return stat(name, st);
	355
	356	memset(st, 0, sizeof *st);
	357	st->st_mode = S_IFCHR\|0666;
	358	st->st_ino = (ino-- & 0x7FFF);
	359	st->st_nlink = 1;
	360	return 0;
	361	}
	362
	363	#endif
c0c09dfd	364
	365	#ifndef NO_SYS_ALLOC
	366
7a2f0d5b	367	static char *oldchunk;
7a2f0d5b	368	static long oldsize;
c0c09dfd	369
7a2f0d5b	370	#define _32_K (1<<15)
7a2f0d5b	371	#define _64_K (1<<16)
c0c09dfd	372
7a2f0d5b	373	/* The real problem is that DosAllocMem will grant memory on 64K-chunks
	374	* boundaries only. Note that addressable space for application memory
	375	* is around 240M, thus we will run out of addressable space if we
	376	* allocate around 14M worth of 4K segments.
	377	* Thus we allocate memory in 64K chunks, and abandon the rest of the old
	378	* chunk if the new is bigger than that rest. Also, we just allocate
	379	* whatever is requested if the size is bigger that 32K. With this strategy
	380	* we cannot lose more than 1/2 of addressable space. */
c0c09dfd	381
	382	void *
	383	sbrk(int size)
	384	{
	385	char *got;
	386	APIRET rc;
7a2f0d5b	387	int small, reqsize;
c0c09dfd	388
c0c09dfd	389	if (!size) return 0;
7a2f0d5b	390	else if (size <= oldsize) {
	391	got = oldchunk;
	392	oldchunk += size;
	393	oldsize -= size;
	394	return (void *)got;
	395	} else if (size >= _32_K) {
	396	small = 0;
	397	} else {
	398	reqsize = size;
	399	size = _64_K;
	400	small = 1;
c0c09dfd	401	}
	402	rc = DosAllocMem((void **)&got, size, PAG_COMMIT \| PAG_WRITE);
	403	if (rc == ERROR_NOT_ENOUGH_MEMORY) {
	404	return (void *) -1;
	405	} else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
7a2f0d5b	406	if (small) {
	407	/* Chunk is small, register the rest for future allocs. */
	408	oldchunk = got + reqsize;
	409	oldsize = size - reqsize;
	410	}
c0c09dfd	411	return (void *)got;
	412	}
	413	#endif /* ! defined NO_SYS_ALLOC */
	414
	415	/* tmp path */
	416
	417	char *tmppath = TMPPATH1;
	418
	419	void
	420	settmppath()
	421	{
	422	char p = getenv("TMP"), tpath;
	423	int len;
	424
	425	if (!p) p = getenv("TEMP");
	426	if (!p) return;
	427	len = strlen(p);
	428	tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
	429	strcpy(tpath, p);
	430	tpath[len] = '/';
	431	strcpy(tpath + len + 1, TMPPATH1);
	432	tmppath = tpath;
	433	}
7a2f0d5b	434
	435	#include "XSUB.h"
	436
	437	XS(XS_File__Copy_syscopy)
	438	{
	439	dXSARGS;
	440	if (items < 2 \|\| items > 3)
	441	croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
	442	{
	443	char * src = (char *)SvPV(ST(0),na);
	444	char * dst = (char *)SvPV(ST(1),na);
	445	U32 flag;
	446	int RETVAL, rc;
	447
	448	if (items < 3)
	449	flag = 0;
	450	else {
	451	flag = (unsigned long)SvIV(ST(2));
	452	}
	453
6f064249	454	RETVAL = !CheckOSError(DosCopy(src, dst, flag));
7a2f0d5b	455	ST(0) = sv_newmortal();
	456	sv_setiv(ST(0), (IV)RETVAL);
	457	}
	458	XSRETURN(1);
	459	}
	460
6f064249	461	char *
	462	mod2fname(sv)
	463	SV *sv;
	464	{
	465	static char fname[9];
	466	int pos = 7;
	467	int len;
	468	AV *av;
	469	SV *svp;
	470	char *s;
	471
	472	if (!SvROK(sv)) croak("Not a reference given to mod2fname");
	473	sv = SvRV(sv);
	474	if (SvTYPE(sv) != SVt_PVAV)
	475	croak("Not array reference given to mod2fname");
	476	if (av_len((AV*)sv) < 0)
	477	croak("Empty array reference given to mod2fname");
	478	s = SvPV(av_fetch((AV)sv, av_len((AV*)sv), FALSE), na);
	479	strncpy(fname, s, 8);
	480	if ((len=strlen(s)) < 7) pos = len;
	481	fname[pos] = '_';
	482	fname[pos + 1] = '\0';
	483	return (char *)fname;
	484	}
	485
	486	XS(XS_DynaLoader_mod2fname)
	487	{
	488	dXSARGS;
	489	if (items != 1)
	490	croak("Usage: DynaLoader::mod2fname(sv)");
	491	{
	492	SV * sv = ST(0);
	493	char * RETVAL;
	494
	495	RETVAL = mod2fname(sv);
	496	ST(0) = sv_newmortal();
	497	sv_setpv((SV*)ST(0), RETVAL);
	498	}
	499	XSRETURN(1);
	500	}
	501
	502	char *
	503	os2error(int rc)
	504	{
	505	static char buf[300];
	506	ULONG len;
	507
	508	if (rc == 0)
	509	return NULL;
	510	if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
	511	sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
	512	else
	513	buf[len] = '\0';
	514	return buf;
	515	}
	516
7a2f0d5b	517	OS2_Perl_data_t OS2_Perl_data;
	518
	519	int
	520	Xs_OS2_init()
	521	{
	522	char *file = __FILE__;
	523	{
6f064249	524	GV *gv;
6f064249	525
7a2f0d5b	526	newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
6f064249	527	newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
	528	#ifdef PERL_IS_AOUT
	529	gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
	530	GvMULTI_on(gv);
	531	sv_setiv(GvSV(gv), 1);
	532	#endif
7a2f0d5b	533	}
	534	}
	535
	536	void
	537	Perl_OS2_init()
	538	{
6f064249	539	char *shell;
6f064249	540
7a2f0d5b	541	settmppath();
7a2f0d5b	542	OS2_Perl_data.xs_init = &Xs_OS2_init;
6f064249	543	if ( (shell = getenv("PERL_SH_DRIVE")) ) {
	544	sh_path[0] = shell[0];
	545	}
7a2f0d5b	546	}
6f064249	547
	548	char sh_path[33] = BIN_SH;
	549
	550	extern void dlopen();
	551	void fakedl = &dlopen; / Pull in dynaloading part. */