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

#define INCL_DOS
#define INCL_NOPM
#define INCL_DOSFILEMGR
#define INCL_DOSMEMMGR
#define INCL_DOSERRORS
#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() */
#ifndef __EMX__
	RESULTCODES res;
	int rpid;
#endif

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

#ifdef __EMX__
	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;
#else
	ihand = signal(SIGINT, SIG_IGN);
	r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
	signal(SIGINT, ihand);
	statusvalue = res.codeResult << 8 | res.codeTerminate;
	if (r)
		return -1;
	return statusvalue;
#endif
}

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 && SvNIOKp(*(mark+1)) && !SvPOKp(*(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] != '\\'
	    && !(*Argv[0] && *Argv[1] == ':' 
		 && (*Argv[2] == '/' || *Argv[2] != '\\'))
	    ) /* will swawnvp use PATH? */
	    TAINT_ENV();	/* testing IFS here is overkill, probably */
	/* We should check PERL_SH* and PERLLIB_* as well? */
	if (really && *(tmps = SvPV(really, na)))
	    rc = result(trueflag, spawnvp(flag,tmps,Argv));
	else
	    rc = result(trueflag, spawnvp(flag,Argv[0],Argv));

	if (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;
}

#define EXECF_SPAWN 0
#define EXECF_EXEC 1
#define EXECF_TRUEEXEC 2

int
do_spawn2(cmd, execf)
char *cmd;
int execf;
{
    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:
	    if (execf == EXECF_TRUEEXEC)
                return execl(shell,shell,copt,cmd,(char*)0);
	    else if (execf == EXECF_EXEC)
                return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
	    /* In the ak code internal P_NOWAIT is P_WAIT ??? */
	    rc = result(P_WAIT,
			spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
	    if (rc < 0 && dowarn)
		warn("Can't %s \"%s\": %s", 
		     (execf == EXECF_SPAWN ? "spawn" : "exec"),
		     shell, Strerror(errno));
	    if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
	    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]) {
	if (execf == EXECF_TRUEEXEC)
	    rc = execvp(Argv[0],Argv);
	else if (execf == EXECF_EXEC)
	    rc = spawnvp(P_OVERLAY,Argv[0],Argv);
        else
	    rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
	if (rc < 0 && dowarn)
	    warn("Can't %s \"%s\": %s", 
		 (execf == EXECF_SPAWN ? "spawn" : "exec"),
		 Argv[0], Strerror(errno));
	if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
    } else
    	rc = -1;
    do_execfree();
    return rc;
}

int
do_spawn(cmd)
char *cmd;
{
    return do_spawn2(cmd, EXECF_SPAWN);
}

bool
do_exec(cmd)
char *cmd;
{
    return do_spawn2(cmd, EXECF_EXEC);
}

bool
os2exec(cmd)
char *cmd;
{
    return do_spawn2(cmd, EXECF_TRUEEXEC);
}

#ifndef HAS_FORK
FILE *
my_popen(cmd,mode)
char	*cmd;
char	*mode;
{
#ifdef TRYSHELL
    return popen(cmd, mode);
#else
    char *shell = getenv("EMXSHELL");
    FILE *res;
    
    my_setenv("EMXSHELL", SH_PATH);
    res = popen(cmd, mode);
    my_setenv("EMXSHELL", shell);
    return res;
#endif 
}
#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

/*****************************************************************************/
/* my socket forwarders - EMX lib only provides static forwarders */

static HMODULE htcp = 0;

static void *
tcp0(char *name)
{
    static BYTE buf[20];
    PFN fcn;
    if (!htcp)
	DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
    if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
	return (void *) ((void * (*)(void)) fcn) ();
    return 0;
}

static void
tcp1(char *name, int arg)
{
    static BYTE buf[20];
    PFN fcn;
    if (!htcp)
	DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
    if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
	((void (*)(int)) fcn) (arg);
}

void *	gethostent()	{ return tcp0("GETHOSTENT");  }
void *	getnetent()	{ return tcp0("GETNETENT");   }
void *	getprotoent()	{ return tcp0("GETPROTOENT"); }
void *	getservent()	{ return tcp0("GETSERVENT");  }
void	sethostent(x)	{ tcp1("SETHOSTENT",  x); }
void	setnetent(x)	{ tcp1("SETNETENT",   x); }
void	setprotoent(x)	{ tcp1("SETPROTOENT", x); }
void	setservent(x)	{ tcp1("SETSERVENT",  x); }
void	endhostent()	{ tcp0("ENDHOSTENT");  }
void	endnetent()	{ tcp0("ENDNETENT");   }
void	endprotoent()	{ tcp0("ENDPROTOENT"); }
void	endservent()	{ tcp0("ENDSERVENT");  }

/*****************************************************************************/
/* not implemented in C Set++ */

#ifndef __EMX__
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

    /* 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

#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 ) die("Got an error from DosAllocMem: %li", (long)rc);
    return got;
}

#endif /* USE_PERL_SBRK */

/* 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 = 6, len, avlen;
    unsigned int sum = 0;
    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");

    avlen = av_len((AV*)sv);
    if (avlen < 0) 
      croak("Empty array reference given to mod2fname");

    s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
    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), na);
	while (*s) {
	    sum = 33 * sum + *(s++);	/* 7 is primitive mod 13. */
	}
	avlen --;
    }
    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)
	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);
	gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
	GvMULTI_on(gv);
#ifdef PERL_IS_AOUT
	sv_setiv(GvSV(gv), 1);
#endif 
    }
}

void
Perl_OS2_init()
{
    char *shell;

    settmppath();
    OS2_Perl_data.xs_init = &Xs_OS2_init;
    if ( (shell = getenv("PERL_SH_DRIVE")) ) {
	sh_path[0] = shell[0];
    } else if ( (shell = getenv("PERL_SH_DIR")) ) {
	int l = strlen(shell);
	if (shell[l-1] == '/' || shell[l-1] == '\\') {
	    l--;
	}
	if (l > STATIC_FILE_LENGTH - 7) {
	    die("PERL_SH_DIR too long");
	}
	strncpy(sh_path, shell, l);
	strcpy(sh_path + l, "/sh.exe");
    }
}

char sh_path[STATIC_FILE_LENGTH+1] = SH_PATH_INI;

char *
perllib_mangle(char *s, unsigned int l)
{
    static char *newp, *oldp;
    static int newl, oldl, notfound;
    static char ret[STATIC_FILE_LENGTH+1];
    
    if (!newp && !notfound) {
	newp = getenv("PERLLIB_PREFIX");
	if (newp) {
	    oldp = newp;
	    while (*newp && !isSPACE(*newp) && *newp != ';') {
		newp++; oldl++;		/* Skip digits. */
	    }
	    while (*newp && (isSPACE(*newp) || *newp == ';')) {
		newp++;			/* Skip whitespace. */
	    }
	    newl = strlen(newp);
	    if (newl == 0 || oldl == 0) {
		die("Malformed PERLLIB_PREFIX");
	    }
	} 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) {
	die("Malformed PERLLIB_PREFIX");
    }
    strncpy(ret, newp, newl);
    strcpy(ret + newl, s + oldl);
    return ret;
}

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
760ac839	4	#define INCL_DOSMEMMGR
760ac839	5	#define INCL_DOSERRORS
4633a7c4	6	#include <os2.h>
	7
	8	/*
	9	* Various Unix compatibility functions for OS/2
	10	*/
	11
	12	#include <stdio.h>
	13	#include <errno.h>
	14	#include <limits.h>
	15	#include <process.h>
	16
	17	#include "EXTERN.h"
	18	#include "perl.h"
	19
	20	/*****************************************************************************/
	21	/* priorities */
6f064249	22	static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
	23	self inverse. */
	24	#define QSS_INI_BUFFER 1024
4633a7c4	25
6f064249	26	PQTOPLEVEL
6f064249	27	get_sysinfo(ULONG pid, ULONG flags)
4633a7c4	28	{
6f064249	29	char *pbuffer;
	30	ULONG rc, buf_len = QSS_INI_BUFFER;
	31
	32	New(1022, pbuffer, buf_len, char);
	33	/* QSS_PROCESS \| QSS_MODULE \| QSS_SEMAPHORES \| QSS_SHARED */
	34	rc = QuerySysState(flags, pid, pbuffer, buf_len);
	35	while (rc == ERROR_BUFFER_OVERFLOW) {
	36	Renew(pbuffer, buf_len *= 2, char);
	37	rc = QuerySysState(QSS_PROCESS, pid, pbuffer, buf_len);
	38	}
	39	if (rc) {
	40	FillOSError(rc);
	41	Safefree(pbuffer);
	42	return 0;
	43	}
	44	return (PQTOPLEVEL)pbuffer;
	45	}
	46
	47	#define PRIO_ERR 0x1111
	48
	49	static ULONG
	50	sys_prio(pid)
	51	{
	52	ULONG prio;
	53	PQTOPLEVEL psi;
	54
	55	psi = get_sysinfo(pid, QSS_PROCESS);
	56	if (!psi) {
	57	return PRIO_ERR;
	58	}
	59	if (pid != psi->procdata->pid) {
	60	Safefree(psi);
	61	croak("panic: wrong pid in sysinfo");
	62	}
	63	prio = psi->procdata->threads->priority;
	64	Safefree(psi);
	65	return prio;
	66	}
	67
	68	int
	69	setpriority(int which, int pid, int val)
	70	{
	71	ULONG rc, prio;
	72	PQTOPLEVEL psi;
	73
	74	prio = sys_prio(pid);
	75
	76	if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
	77	/* Do not change class. */
	78	return CheckOSError(DosSetPriority((pid < 0)
	79	? PRTYS_PROCESSTREE : PRTYS_PROCESS,
	80	0,
	81	(32 - val) % 32 - (prio & 0xFF),
	82	abs(pid)))
	83	? -1 : 0;
	84	} else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
	85	/* Documentation claims one can change both class and basevalue,
	86	* but I find it wrong. */
	87	/* Change class, but since delta == 0 denotes absolute 0, correct. */
	88	if (CheckOSError(DosSetPriority((pid < 0)
	89	? PRTYS_PROCESSTREE : PRTYS_PROCESS,
	90	priors[(32 - val) >> 5] + 1,
	91	0,
	92	abs(pid))))
93	return -1;
94	if ( ((32 - val) % 32) == 0 ) return 0;
95	return CheckOSError(DosSetPriority((pid < 0)
96	? PRTYS_PROCESSTREE : PRTYS_PROCESS,
97	0,
98	(32 - val) % 32,
99	abs(pid)))
100	? -1 : 0;
101	}
102	/* else return CheckOSError(DosSetPriority((pid < 0) */
103	/* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
104	/* priors[(32 - val) >> 5] + 1, */
105	/* (32 - val) % 32 - (prio & 0xFF), */
106	/* abs(pid))) */
107	/* ? -1 : 0; */
4633a7c4	108	}
4633a7c4	109
6f064249	110	int
6f064249	111	getpriority(int which /* ignored */, int pid)
4633a7c4	112	{
	113	TIB *tib;
	114	PIB *pib;
6f064249	115	ULONG rc, ret;
	116
	117	/* DosGetInfoBlocks has old priority! */
	118	/* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
	119	/* if (pid != pib->pib_ulpid) { */
	120	ret = sys_prio(pid);
	121	if (ret == PRIO_ERR) {
	122	return -1;
	123	}
	124	/* } else */
	125	/* ret = tib->tib_ptib2->tib2_ulpri; */
	126	return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
4633a7c4	127	}
	128
	129	/*****************************************************************************/
	130	/* spawn */
	131
	132	static int
	133	result(int flag, int pid)
	134	{
	135	int r, status;
	136	Signal_t (ihand)(); / place to save signal during system() */
	137	Signal_t (qhand)(); / place to save signal during system() */
760ac839	138	#ifndef __EMX__
	139	RESULTCODES res;
	140	int rpid;
	141	#endif
4633a7c4	142
760ac839	143	if (pid < 0 \|\| flag != 0)
4633a7c4	144	return pid;
4633a7c4	145
760ac839	146	#ifdef __EMX__
4633a7c4	147	ihand = signal(SIGINT, SIG_IGN);
4633a7c4	148	qhand = signal(SIGQUIT, SIG_IGN);
c0c09dfd	149	do {
	150	r = wait4pid(pid, &status, 0);
	151	} while (r == -1 && errno == EINTR);
4633a7c4	152	signal(SIGINT, ihand);
	153	signal(SIGQUIT, qhand);
	154
	155	statusvalue = (U16)status;
	156	if (r < 0)
	157	return -1;
	158	return status & 0xFFFF;
760ac839	159	#else
	160	ihand = signal(SIGINT, SIG_IGN);
	161	r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
	162	signal(SIGINT, ihand);
	163	statusvalue = res.codeResult << 8 \| res.codeTerminate;
	164	if (r)
	165	return -1;
	166	return statusvalue;
	167	#endif
4633a7c4	168	}
	169
	170	int
	171	do_aspawn(really,mark,sp)
	172	SV *really;
	173	register SV **mark;
	174	register SV **sp;
	175	{
	176	register char **a;
	177	char *tmps;
	178	int rc;
	179	int flag = P_WAIT, trueflag;
	180
	181	if (sp > mark) {
	182	New(401,Argv, sp - mark + 1, char*);
	183	a = Argv;
	184
760ac839	185	if (mark < sp && SvNIOKp((mark+1)) && !SvPOKp((mark+1))) {
4633a7c4	186	++mark;
	187	flag = SvIVx(*mark);
	188	}
	189
	190	while (++mark <= sp) {
	191	if (*mark)
	192	a++ = SvPVx(mark, na);
	193	else
	194	*a++ = "";
	195	}
	196	*a = Nullch;
	197
	198	trueflag = flag;
	199	if (flag == P_WAIT)
	200	flag = P_NOWAIT;
	201
760ac839	202	if (Argv[0] != '/' && Argv[0] != '\\'
	203	&& !(Argv[0] && Argv[1] == ':'
	204	&& (Argv[2] == '/' \|\| Argv[2] != '\\'))
	205	) /* will swawnvp use PATH? */
c0c09dfd	206	TAINT_ENV(); /* testing IFS here is overkill, probably */
760ac839	207	/* We should check PERL_SH* and PERLLIB_* as well? */
4633a7c4	208	if (really && *(tmps = SvPV(really, na)))
	209	rc = result(trueflag, spawnvp(flag,tmps,Argv));
	210	else
	211	rc = result(trueflag, spawnvp(flag,Argv[0],Argv));
	212
	213	if (rc < 0 && dowarn)
	214	warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
c0c09dfd	215	if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
4633a7c4	216	} else
	217	rc = -1;
	218	do_execfree();
	219	return rc;
	220	}
	221
760ac839	222	#define EXECF_SPAWN 0
	223	#define EXECF_EXEC 1
	224	#define EXECF_TRUEEXEC 2
	225
4633a7c4	226	int
760ac839	227	do_spawn2(cmd, execf)
4633a7c4	228	char *cmd;
760ac839	229	int execf;
4633a7c4	230	{
	231	register char **a;
	232	register char *s;
	233	char flags[10];
	234	char shell, copt;
	235	int rc;
	236
c0c09dfd	237	#ifdef TRYSHELL
	238	if ((shell = getenv("EMXSHELL")) != NULL)
	239	copt = "-c";
	240	else if ((shell = getenv("SHELL")) != NULL)
4633a7c4	241	copt = "-c";
	242	else if ((shell = getenv("COMSPEC")) != NULL)
	243	copt = "/C";
	244	else
	245	shell = "cmd.exe";
c0c09dfd	246	#else
	247	/* Consensus on perl5-porters is that it is _very_ important to
	248	have a shell which will not change between computers with the
	249	same architecture, to avoid "action on a distance".
	250	And to have simple build, this shell should be sh. */
6f064249	251	shell = SH_PATH;
c0c09dfd	252	copt = "-c";
	253	#endif
	254
	255	while (cmd && isSPACE(cmd))
	256	cmd++;
4633a7c4	257
	258	/* save an extra exec if possible */
	259	/* see if there are shell metacharacters in it */
	260
c0c09dfd	261	if (*cmd == '.' && isSPACE(cmd[1]))
	262	goto doshell;
	263
	264	if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
	265	goto doshell;
	266
	267	for (s = cmd; s && isALPHA(s); s++) ; /* catch VAR=val gizmo */
	268	if (*s == '=')
	269	goto doshell;
	270
4633a7c4	271	for (s = cmd; *s; s++) {
c0c09dfd	272	if (s != ' ' && !isALPHA(s) && strchr("$&(){}[]'\";\\\|?<>~`\n",s)) {
4633a7c4	273	if (*s == '\n' && !s[1]) {
	274	*s = '\0';
	275	break;
	276	}
c0c09dfd	277	doshell:
760ac839	278	if (execf == EXECF_TRUEEXEC)
	279	return execl(shell,shell,copt,cmd,(char*)0);
	280	else if (execf == EXECF_EXEC)
	281	return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
	282	/* In the ak code internal P_NOWAIT is P_WAIT ??? */
c0c09dfd	283	rc = result(P_WAIT,
760ac839	284	spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
c0c09dfd	285	if (rc < 0 && dowarn)
760ac839	286	warn("Can't %s \"%s\": %s",
	287	(execf == EXECF_SPAWN ? "spawn" : "exec"),
	288	shell, Strerror(errno));
c0c09dfd	289	if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
c0c09dfd	290	return rc;
4633a7c4	291	}
4633a7c4	292	}
c0c09dfd	293
4633a7c4	294	New(402,Argv, (s - cmd) / 2 + 2, char*);
	295	Cmd = savepvn(cmd, s-cmd);
	296	a = Argv;
	297	for (s = Cmd; *s;) {
	298	while (s && isSPACE(s)) s++;
	299	if (*s)
	300	*(a++) = s;
	301	while (s && !isSPACE(s)) s++;
	302	if (*s)
	303	*s++ = '\0';
	304	}
	305	*a = Nullch;
	306	if (Argv[0]) {
760ac839	307	if (execf == EXECF_TRUEEXEC)
	308	rc = execvp(Argv[0],Argv);
	309	else if (execf == EXECF_EXEC)
	310	rc = spawnvp(P_OVERLAY,Argv[0],Argv);
	311	else
	312	rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
4633a7c4	313	if (rc < 0 && dowarn)
760ac839	314	warn("Can't %s \"%s\": %s",
	315	(execf == EXECF_SPAWN ? "spawn" : "exec"),
	316	Argv[0], Strerror(errno));
c0c09dfd	317	if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
4633a7c4	318	} else
	319	rc = -1;
	320	do_execfree();
	321	return rc;
	322	}
	323
760ac839	324	int
	325	do_spawn(cmd)
	326	char *cmd;
	327	{
	328	return do_spawn2(cmd, EXECF_SPAWN);
	329	}
	330
	331	bool
	332	do_exec(cmd)
	333	char *cmd;
	334	{
	335	return do_spawn2(cmd, EXECF_EXEC);
	336	}
	337
	338	bool
	339	os2exec(cmd)
	340	char *cmd;
	341	{
	342	return do_spawn2(cmd, EXECF_TRUEEXEC);
	343	}
	344
6f064249	345	#ifndef HAS_FORK
c0c09dfd	346	FILE *
	347	my_popen(cmd,mode)
	348	char *cmd;
	349	char *mode;
	350	{
760ac839	351	#ifdef TRYSHELL
	352	return popen(cmd, mode);
	353	#else
c0c09dfd	354	char *shell = getenv("EMXSHELL");
	355	FILE *res;
	356
6f064249	357	my_setenv("EMXSHELL", SH_PATH);
c0c09dfd	358	res = popen(cmd, mode);
	359	my_setenv("EMXSHELL", shell);
	360	return res;
760ac839	361	#endif
c0c09dfd	362	}
6f064249	363	#endif
c0c09dfd	364
4633a7c4	365	/*****************************************************************************/
	366
	367	#ifndef HAS_FORK
	368	int
	369	fork(void)
	370	{
	371	die(no_func, "Unsupported function fork");
	372	errno = EINVAL;
	373	return -1;
	374	}
	375	#endif
	376
	377	/*****************************************************************************/
	378	/* not implemented in EMX 0.9a */
	379
	380	void * ctermid(x) { return 0; }
eacfb5f1	381
eacfb5f1	382	#ifdef MYTTYNAME /* was not in emx0.9a */
4633a7c4	383	void * ttyname(x) { return 0; }
eacfb5f1	384	#endif
4633a7c4	385
760ac839	386	/*****************************************************************************/
	387	/* my socket forwarders - EMX lib only provides static forwarders */
	388
	389	static HMODULE htcp = 0;
	390
	391	static void *
	392	tcp0(char *name)
	393	{
	394	static BYTE buf[20];
	395	PFN fcn;
	396	if (!htcp)
	397	DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
	398	if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
	399	return (void ) ((void (*)(void)) fcn) ();
	400	return 0;
	401	}
	402
	403	static void
	404	tcp1(char *name, int arg)
	405	{
	406	static BYTE buf[20];
	407	PFN fcn;
	408	if (!htcp)
	409	DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
	410	if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
	411	((void (*)(int)) fcn) (arg);
	412	}
	413
	414	void * gethostent() { return tcp0("GETHOSTENT"); }
	415	void * getnetent() { return tcp0("GETNETENT"); }
	416	void * getprotoent() { return tcp0("GETPROTOENT"); }
	417	void * getservent() { return tcp0("GETSERVENT"); }
	418	void sethostent(x) { tcp1("SETHOSTENT", x); }
	419	void setnetent(x) { tcp1("SETNETENT", x); }
	420	void setprotoent(x) { tcp1("SETPROTOENT", x); }
	421	void setservent(x) { tcp1("SETSERVENT", x); }
	422	void endhostent() { tcp0("ENDHOSTENT"); }
	423	void endnetent() { tcp0("ENDNETENT"); }
	424	void endprotoent() { tcp0("ENDPROTOENT"); }
	425	void endservent() { tcp0("ENDSERVENT"); }
	426
	427	/*****************************************************************************/
	428	/* not implemented in C Set++ */
	429
	430	#ifndef __EMX__
	431	int setuid(x) { errno = EINVAL; return -1; }
	432	int setgid(x) { errno = EINVAL; return -1; }
	433	#endif
4633a7c4	434
	435	/*****************************************************************************/
	436	/* stat() hack for char/block device */
	437
	438	#if OS2_STAT_HACK
	439
	440	/* First attempt used DosQueryFSAttach which crashed the system when
	441	used with 5.001. Now just look for /dev/. */
	442
	443	int
	444	os2_stat(char name, struct stat st)
	445	{
	446	static int ino = SHRT_MAX;
	447
	448	if (stricmp(name, "/dev/con") != 0
	449	&& stricmp(name, "/dev/tty") != 0)
	450	return stat(name, st);
	451
	452	memset(st, 0, sizeof *st);
	453	st->st_mode = S_IFCHR\|0666;
	454	st->st_ino = (ino-- & 0x7FFF);
	455	st->st_nlink = 1;
	456	return 0;
	457	}
	458
	459	#endif
c0c09dfd	460
760ac839	461	#ifdef USE_PERL_SBRK
c0c09dfd	462
760ac839	463	/* SBRK() emulation, mostly moved to malloc.c. */
c0c09dfd	464
c0c09dfd	465	void *
760ac839	466	sys_alloc(int size) {
	467	void *got;
	468	APIRET rc = DosAllocMem(&got, size, PAG_COMMIT \| PAG_WRITE);
	469
c0c09dfd	470	if (rc == ERROR_NOT_ENOUGH_MEMORY) {
	471	return (void *) -1;
	472	} else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
760ac839	473	return got;
c0c09dfd	474	}
760ac839	475
760ac839	476	#endif /* USE_PERL_SBRK */
c0c09dfd	477
	478	/* tmp path */
	479
	480	char *tmppath = TMPPATH1;
	481
	482	void
	483	settmppath()
	484	{
	485	char p = getenv("TMP"), tpath;
	486	int len;
	487
	488	if (!p) p = getenv("TEMP");
	489	if (!p) return;
	490	len = strlen(p);
	491	tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
	492	strcpy(tpath, p);
	493	tpath[len] = '/';
	494	strcpy(tpath + len + 1, TMPPATH1);
	495	tmppath = tpath;
	496	}
7a2f0d5b	497
	498	#include "XSUB.h"
	499
	500	XS(XS_File__Copy_syscopy)
	501	{
	502	dXSARGS;
	503	if (items < 2 \|\| items > 3)
	504	croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
	505	{
	506	char * src = (char *)SvPV(ST(0),na);
	507	char * dst = (char *)SvPV(ST(1),na);
	508	U32 flag;
	509	int RETVAL, rc;
	510
	511	if (items < 3)
	512	flag = 0;
	513	else {
	514	flag = (unsigned long)SvIV(ST(2));
	515	}
	516
6f064249	517	RETVAL = !CheckOSError(DosCopy(src, dst, flag));
7a2f0d5b	518	ST(0) = sv_newmortal();
	519	sv_setiv(ST(0), (IV)RETVAL);
	520	}
	521	XSRETURN(1);
	522	}
	523
6f064249	524	char *
	525	mod2fname(sv)
	526	SV *sv;
	527	{
	528	static char fname[9];
760ac839	529	int pos = 6, len, avlen;
760ac839	530	unsigned int sum = 0;
6f064249	531	AV *av;
	532	SV *svp;
	533	char *s;
	534
	535	if (!SvROK(sv)) croak("Not a reference given to mod2fname");
	536	sv = SvRV(sv);
	537	if (SvTYPE(sv) != SVt_PVAV)
	538	croak("Not array reference given to mod2fname");
760ac839	539
	540	avlen = av_len((AV*)sv);
	541	if (avlen < 0)
6f064249	542	croak("Empty array reference given to mod2fname");
760ac839	543
760ac839	544	s = SvPV(av_fetch((AV)sv, avlen, FALSE), na);
6f064249	545	strncpy(fname, s, 8);
760ac839	546	len = strlen(s);
	547	if (len < 6) pos = len;
	548	while (*s) {
	549	sum = 33 * sum + (s++); / Checksumming first chars to
	550	* get the capitalization into c.s. */
	551	}
	552	avlen --;
	553	while (avlen >= 0) {
	554	s = SvPV(av_fetch((AV)sv, avlen, FALSE), na);
	555	while (*s) {
	556	sum = 33 * sum + (s++); / 7 is primitive mod 13. */
	557	}
	558	avlen --;
	559	}
	560	fname[pos] = 'A' + (sum % 26);
	561	fname[pos + 1] = 'A' + (sum / 26 % 26);
	562	fname[pos + 2] = '\0';
6f064249	563	return (char *)fname;
	564	}
	565
	566	XS(XS_DynaLoader_mod2fname)
	567	{
	568	dXSARGS;
	569	if (items != 1)
	570	croak("Usage: DynaLoader::mod2fname(sv)");
	571	{
	572	SV * sv = ST(0);
	573	char * RETVAL;
	574
	575	RETVAL = mod2fname(sv);
	576	ST(0) = sv_newmortal();
	577	sv_setpv((SV*)ST(0), RETVAL);
	578	}
	579	XSRETURN(1);
	580	}
	581
	582	char *
	583	os2error(int rc)
	584	{
	585	static char buf[300];
	586	ULONG len;
	587
	588	if (rc == 0)
	589	return NULL;
	590	if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
	591	sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
	592	else
	593	buf[len] = '\0';
	594	return buf;
	595	}
	596
7a2f0d5b	597	OS2_Perl_data_t OS2_Perl_data;
	598
	599	int
	600	Xs_OS2_init()
	601	{
	602	char *file = __FILE__;
	603	{
6f064249	604	GV *gv;
6f064249	605
7a2f0d5b	606	newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
6f064249	607	newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
6f064249	608	gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
6f064249	609	GvMULTI_on(gv);
760ac839	610	#ifdef PERL_IS_AOUT
6f064249	611	sv_setiv(GvSV(gv), 1);
6f064249	612	#endif
7a2f0d5b	613	}
	614	}
	615
	616	void
	617	Perl_OS2_init()
	618	{
6f064249	619	char *shell;
6f064249	620
7a2f0d5b	621	settmppath();
7a2f0d5b	622	OS2_Perl_data.xs_init = &Xs_OS2_init;
6f064249	623	if ( (shell = getenv("PERL_SH_DRIVE")) ) {
6f064249	624	sh_path[0] = shell[0];
760ac839	625	} else if ( (shell = getenv("PERL_SH_DIR")) ) {
	626	int l = strlen(shell);
	627	if (shell[l-1] == '/' \|\| shell[l-1] == '\\') {
	628	l--;
	629	}
	630	if (l > STATIC_FILE_LENGTH - 7) {
	631	die("PERL_SH_DIR too long");
	632	}
	633	strncpy(sh_path, shell, l);
	634	strcpy(sh_path + l, "/sh.exe");
6f064249	635	}
7a2f0d5b	636	}
6f064249	637
89078e0f	638	char sh_path[STATIC_FILE_LENGTH+1] = SH_PATH_INI;
760ac839	639
	640	char *
	641	perllib_mangle(char *s, unsigned int l)
	642	{
	643	static char newp, oldp;
	644	static int newl, oldl, notfound;
	645	static char ret[STATIC_FILE_LENGTH+1];
	646
	647	if (!newp && !notfound) {
	648	newp = getenv("PERLLIB_PREFIX");
	649	if (newp) {
	650	oldp = newp;
89078e0f	651	while (newp && !isSPACE(newp) && *newp != ';') {
760ac839	652	newp++; oldl++; /* Skip digits. */
	653	}
	654	while (newp && (isSPACE(newp) \|\| *newp == ';')) {
	655	newp++; /* Skip whitespace. */
	656	}
	657	newl = strlen(newp);
	658	if (newl == 0 \|\| oldl == 0) {
	659	die("Malformed PERLLIB_PREFIX");
	660	}
	661	} else {
	662	notfound = 1;
	663	}
	664	}
	665	if (!newp) {
	666	return s;
	667	}
	668	if (l == 0) {
	669	l = strlen(s);
	670	}
	671	if (l <= oldl \|\| strnicmp(oldp, s, oldl) != 0) {
	672	return s;
	673	}
	674	if (l + newl - oldl > STATIC_FILE_LENGTH \|\| newl > STATIC_FILE_LENGTH) {
	675	die("Malformed PERLLIB_PREFIX");
	676	}
	677	strncpy(ret, newp, newl);
89078e0f	678	strcpy(ret + newl, s + oldl);
760ac839	679	return ret;
760ac839	680	}
6f064249	681
	682	extern void dlopen();
	683	void fakedl = &dlopen; / Pull in dynaloading part. */