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

int setpriority(int which, int pid, int val)
{
  return DosSetPriority((pid < 0) ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
			val >> 8, val & 0xFF, abs(pid));
}

int getpriority(int which /* ignored */, int pid)
{
  TIB *tib;
  PIB *pib;
  DosGetInfoBlocks(&tib, &pib);
  return tib->tib_ptib2->tib2_ulpri;
}

/*****************************************************************************/
/* 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.exe";
    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;
}

FILE *
my_popen(cmd,mode)
char	*cmd;
char	*mode;
{
    char *shell = getenv("EMXSHELL");
    FILE *res;
    
    my_setenv("EMXSHELL", "sh.exe");
    res = popen(cmd, mode);
    my_setenv("EMXSHELL", shell);
    return res;
}

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

#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));
	}

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

OS2_Perl_data_t OS2_Perl_data;

int
Xs_OS2_init()
{
    char *file = __FILE__;
    {
        newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
    }
}

void
Perl_OS2_init()
{
    settmppath();
    OS2_Perl_data.xs_init = &Xs_OS2_init;
}
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 */
	24
	25	int setpriority(int which, int pid, int val)
	26	{
	27	return DosSetPriority((pid < 0) ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
	28	val >> 8, val & 0xFF, abs(pid));
	29	}
	30
	31	int getpriority(int which /* ignored */, int pid)
	32	{
	33	TIB *tib;
	34	PIB *pib;
	35	DosGetInfoBlocks(&tib, &pib);
	36	return tib->tib_ptib2->tib2_ulpri;
	37	}
	38
	39	/*****************************************************************************/
	40	/* spawn */
	41
	42	static int
	43	result(int flag, int pid)
	44	{
	45	int r, status;
	46	Signal_t (ihand)(); / place to save signal during system() */
	47	Signal_t (qhand)(); / place to save signal during system() */
	48
c0c09dfd	49	if (pid < 0 \|\| flag != 0)
4633a7c4	50	return pid;
	51
	52	ihand = signal(SIGINT, SIG_IGN);
	53	qhand = signal(SIGQUIT, SIG_IGN);
c0c09dfd	54	do {
	55	r = wait4pid(pid, &status, 0);
	56	} while (r == -1 && errno == EINTR);
4633a7c4	57	signal(SIGINT, ihand);
	58	signal(SIGQUIT, qhand);
	59
	60	statusvalue = (U16)status;
	61	if (r < 0)
	62	return -1;
	63	return status & 0xFFFF;
	64	}
	65
	66	int
	67	do_aspawn(really,mark,sp)
	68	SV *really;
	69	register SV **mark;
	70	register SV **sp;
	71	{
	72	register char **a;
	73	char *tmps;
	74	int rc;
	75	int flag = P_WAIT, trueflag;
	76
	77	if (sp > mark) {
	78	New(401,Argv, sp - mark + 1, char*);
	79	a = Argv;
	80
	81	if (mark < sp && SvIOKp(*(mark+1))) {
	82	++mark;
	83	flag = SvIVx(*mark);
	84	}
	85
	86	while (++mark <= sp) {
	87	if (*mark)
	88	a++ = SvPVx(mark, na);
	89	else
	90	*a++ = "";
	91	}
	92	*a = Nullch;
	93
	94	trueflag = flag;
	95	if (flag == P_WAIT)
	96	flag = P_NOWAIT;
	97
c0c09dfd	98	if (Argv[0] != '/' && Argv[0] != '\\') /* will swawnvp use PATH? */
c0c09dfd	99	TAINT_ENV(); /* testing IFS here is overkill, probably */
4633a7c4	100	if (really && *(tmps = SvPV(really, na)))
	101	rc = result(trueflag, spawnvp(flag,tmps,Argv));
	102	else
	103	rc = result(trueflag, spawnvp(flag,Argv[0],Argv));
	104
	105	if (rc < 0 && dowarn)
	106	warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
c0c09dfd	107	if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
4633a7c4	108	} else
	109	rc = -1;
	110	do_execfree();
	111	return rc;
	112	}
	113
	114	int
	115	do_spawn(cmd)
	116	char *cmd;
	117	{
	118	register char **a;
	119	register char *s;
	120	char flags[10];
	121	char shell, copt;
	122	int rc;
	123
c0c09dfd	124	#ifdef TRYSHELL
	125	if ((shell = getenv("EMXSHELL")) != NULL)
	126	copt = "-c";
	127	else if ((shell = getenv("SHELL")) != NULL)
4633a7c4	128	copt = "-c";
	129	else if ((shell = getenv("COMSPEC")) != NULL)
	130	copt = "/C";
	131	else
	132	shell = "cmd.exe";
c0c09dfd	133	#else
	134	/* Consensus on perl5-porters is that it is _very_ important to
	135	have a shell which will not change between computers with the
	136	same architecture, to avoid "action on a distance".
	137	And to have simple build, this shell should be sh. */
	138	shell = "sh.exe";
	139	copt = "-c";
	140	#endif
	141
	142	while (cmd && isSPACE(cmd))
	143	cmd++;
4633a7c4	144
	145	/* save an extra exec if possible */
	146	/* see if there are shell metacharacters in it */
	147
c0c09dfd	148	if (*cmd == '.' && isSPACE(cmd[1]))
	149	goto doshell;
	150
	151	if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
	152	goto doshell;
	153
	154	for (s = cmd; s && isALPHA(s); s++) ; /* catch VAR=val gizmo */
	155	if (*s == '=')
	156	goto doshell;
	157
4633a7c4	158	for (s = cmd; *s; s++) {
c0c09dfd	159	if (s != ' ' && !isALPHA(s) && strchr("$&(){}[]'\";\\\|?<>~`\n",s)) {
4633a7c4	160	if (*s == '\n' && !s[1]) {
	161	*s = '\0';
	162	break;
	163	}
c0c09dfd	164	doshell:
	165	rc = result(P_WAIT,
	166	spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
	167	if (rc < 0 && dowarn)
	168	warn("Can't spawn \"%s\": %s", shell, Strerror(errno));
	169	if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
	170	return rc;
4633a7c4	171	}
4633a7c4	172	}
c0c09dfd	173
4633a7c4	174	New(402,Argv, (s - cmd) / 2 + 2, char*);
	175	Cmd = savepvn(cmd, s-cmd);
	176	a = Argv;
	177	for (s = Cmd; *s;) {
	178	while (s && isSPACE(s)) s++;
	179	if (*s)
	180	*(a++) = s;
	181	while (s && !isSPACE(s)) s++;
	182	if (*s)
	183	*s++ = '\0';
	184	}
	185	*a = Nullch;
	186	if (Argv[0]) {
	187	rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
	188	if (rc < 0 && dowarn)
	189	warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
c0c09dfd	190	if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
4633a7c4	191	} else
	192	rc = -1;
	193	do_execfree();
	194	return rc;
	195	}
	196
c0c09dfd	197	FILE *
	198	my_popen(cmd,mode)
	199	char *cmd;
	200	char *mode;
	201	{
	202	char *shell = getenv("EMXSHELL");
	203	FILE *res;
	204
	205	my_setenv("EMXSHELL", "sh.exe");
	206	res = popen(cmd, mode);
	207	my_setenv("EMXSHELL", shell);
	208	return res;
	209	}
	210
4633a7c4	211	/*****************************************************************************/
	212
	213	#ifndef HAS_FORK
	214	int
	215	fork(void)
	216	{
	217	die(no_func, "Unsupported function fork");
	218	errno = EINVAL;
	219	return -1;
	220	}
	221	#endif
	222
	223	/*****************************************************************************/
	224	/* not implemented in EMX 0.9a */
	225
	226	void * ctermid(x) { return 0; }
eacfb5f1	227
eacfb5f1	228	#ifdef MYTTYNAME /* was not in emx0.9a */
4633a7c4	229	void * ttyname(x) { return 0; }
eacfb5f1	230	#endif
4633a7c4	231
	232	void * gethostent() { return 0; }
	233	void * getnetent() { return 0; }
	234	void * getprotoent() { return 0; }
	235	void * getservent() { return 0; }
	236	void sethostent(x) {}
	237	void setnetent(x) {}
	238	void setprotoent(x) {}
	239	void setservent(x) {}
	240	void endhostent(x) {}
	241	void endnetent(x) {}
	242	void endprotoent(x) {}
	243	void endservent(x) {}
	244
	245	/*****************************************************************************/
	246	/* stat() hack for char/block device */
	247
	248	#if OS2_STAT_HACK
	249
	250	/* First attempt used DosQueryFSAttach which crashed the system when
	251	used with 5.001. Now just look for /dev/. */
	252
	253	int
	254	os2_stat(char name, struct stat st)
	255	{
	256	static int ino = SHRT_MAX;
	257
	258	if (stricmp(name, "/dev/con") != 0
	259	&& stricmp(name, "/dev/tty") != 0)
	260	return stat(name, st);
	261
	262	memset(st, 0, sizeof *st);
	263	st->st_mode = S_IFCHR\|0666;
	264	st->st_ino = (ino-- & 0x7FFF);
	265	st->st_nlink = 1;
	266	return 0;
	267	}
	268
	269	#endif
c0c09dfd	270
	271	#ifndef NO_SYS_ALLOC
	272
7a2f0d5b	273	static char *oldchunk;
7a2f0d5b	274	static long oldsize;
c0c09dfd	275
7a2f0d5b	276	#define _32_K (1<<15)
7a2f0d5b	277	#define _64_K (1<<16)
c0c09dfd	278
7a2f0d5b	279	/* The real problem is that DosAllocMem will grant memory on 64K-chunks
	280	* boundaries only. Note that addressable space for application memory
	281	* is around 240M, thus we will run out of addressable space if we
	282	* allocate around 14M worth of 4K segments.
	283	* Thus we allocate memory in 64K chunks, and abandon the rest of the old
	284	* chunk if the new is bigger than that rest. Also, we just allocate
	285	* whatever is requested if the size is bigger that 32K. With this strategy
	286	* we cannot lose more than 1/2 of addressable space. */
c0c09dfd	287
	288	void *
	289	sbrk(int size)
	290	{
	291	char *got;
	292	APIRET rc;
7a2f0d5b	293	int small, reqsize;
c0c09dfd	294
c0c09dfd	295	if (!size) return 0;
7a2f0d5b	296	else if (size <= oldsize) {
	297	got = oldchunk;
	298	oldchunk += size;
	299	oldsize -= size;
	300	return (void *)got;
	301	} else if (size >= _32_K) {
	302	small = 0;
	303	} else {
	304	reqsize = size;
	305	size = _64_K;
	306	small = 1;
c0c09dfd	307	}
	308	rc = DosAllocMem((void **)&got, size, PAG_COMMIT \| PAG_WRITE);
	309	if (rc == ERROR_NOT_ENOUGH_MEMORY) {
	310	return (void *) -1;
	311	} else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
7a2f0d5b	312	if (small) {
	313	/* Chunk is small, register the rest for future allocs. */
	314	oldchunk = got + reqsize;
	315	oldsize = size - reqsize;
	316	}
c0c09dfd	317	return (void *)got;
	318	}
	319	#endif /* ! defined NO_SYS_ALLOC */
	320
	321	/* tmp path */
	322
	323	char *tmppath = TMPPATH1;
	324
	325	void
	326	settmppath()
	327	{
	328	char p = getenv("TMP"), tpath;
	329	int len;
	330
	331	if (!p) p = getenv("TEMP");
	332	if (!p) return;
	333	len = strlen(p);
	334	tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
	335	strcpy(tpath, p);
	336	tpath[len] = '/';
	337	strcpy(tpath + len + 1, TMPPATH1);
	338	tmppath = tpath;
	339	}
7a2f0d5b	340
	341	#include "XSUB.h"
	342
	343	XS(XS_File__Copy_syscopy)
	344	{
	345	dXSARGS;
	346	if (items < 2 \|\| items > 3)
	347	croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
	348	{
	349	char * src = (char *)SvPV(ST(0),na);
	350	char * dst = (char *)SvPV(ST(1),na);
	351	U32 flag;
	352	int RETVAL, rc;
	353
	354	if (items < 3)
	355	flag = 0;
	356	else {
	357	flag = (unsigned long)SvIV(ST(2));
	358	}
	359
	360	errno = DosCopy(src, dst, flag);
	361	RETVAL = !errno;
	362	ST(0) = sv_newmortal();
	363	sv_setiv(ST(0), (IV)RETVAL);
	364	}
	365	XSRETURN(1);
	366	}
	367
	368	OS2_Perl_data_t OS2_Perl_data;
	369
	370	int
	371	Xs_OS2_init()
	372	{
	373	char *file = __FILE__;
	374	{
	375	newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
	376	}
	377	}
	378
	379	void
	380	Perl_OS2_init()
	381	{
	382	settmppath();
	383	OS2_Perl_data.xs_init = &Xs_OS2_init;
	384	}