[p5sagit/p5-mst-13.2.git] / win32 / ipproc.c

/*

	ipproc.c
	Interface for perl process functions

*/

#include <ipproc.h>
#include <stdlib.h>
#include <fcntl.h>

#define EXECF_EXEC 1
#define EXECF_SPAWN 2
#define EXECF_SPAWN_NOWAIT 3

class CPerlProc : public IPerlProc
{
public:
	CPerlProc() 
	{
		pPerl = NULL;
		w32_perlshell_tokens = NULL;
		w32_perlshell_items = -1;
		w32_platform = -1;
#ifndef __BORLANDC__
		w32_num_children = 0;
#endif
	};
	virtual void Abort(void);
	virtual void Exit(int status);
	virtual void _Exit(int status);
	virtual int Execl(const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3);
	virtual int Execv(const char *cmdname, const char *const *argv);
	virtual int Execvp(const char *cmdname, const char *const *argv);
	virtual uid_t Getuid(void);
	virtual uid_t Geteuid(void);
	virtual gid_t Getgid(void);
	virtual gid_t Getegid(void);
	virtual char *Getlogin(void);
	virtual int Kill(int pid, int sig);
	virtual int Killpg(int pid, int sig);
	virtual int PauseProc(void);
	virtual PerlIO* Popen(const char *command, const char *mode);
	virtual int Pclose(PerlIO *stream);
	virtual int Pipe(int *phandles);
	virtual int Setuid(uid_t u);
	virtual int Setgid(gid_t g);
	virtual int Sleep(unsigned int);
	virtual int Times(struct tms *timebuf);
	virtual int Wait(int *status);
	virtual Sighandler_t Signal(int sig, Sighandler_t subcode);
	virtual void GetSysMsg(char*& msg, DWORD& dwLen, DWORD dwErr);
	virtual void FreeBuf(char* msg);
	virtual BOOL DoCmd(char *cmd);
	virtual int Spawn(char*cmds);
	virtual int Spawnvp(int mode, const char *cmdname, const char *const *argv);
	virtual int ASpawn(void *vreally, void **vmark, void **vsp);

	inline void SetPerlObj(CPerlObj *p) { pPerl = p; };
protected:
	int Spawn(char *cmd, int exectype);
	void GetShell(void);
	long Tokenize(char *str, char **dest, char ***destv);

	inline int IsWin95(void)
	{
		return (os_id() == VER_PLATFORM_WIN32_WINDOWS);
	};
	inline int IsWinNT(void)
	{
		return (os_id() == VER_PLATFORM_WIN32_NT);
	};

	inline long filetime_to_clock(PFILETIME ft)
	{
		__int64 qw = ft->dwHighDateTime;
		qw <<= 32;
		qw |= ft->dwLowDateTime;
		qw /= 10000;  /* File time ticks at 0.1uS, clock at 1mS */
		return (long) qw;
	};

	DWORD os_id(void)
	{
		if((-1) == w32_platform)
		{
			OSVERSIONINFO osver;

			memset(&osver, 0, sizeof(OSVERSIONINFO));
			osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
			GetVersionEx(&osver);
			w32_platform = osver.dwPlatformId;
		}
		return (w32_platform);
	};

	DWORD w32_platform;
	char szLoginNameStr[128];
	char *w32_perlshell_tokens;
	long w32_perlshell_items;
	char **w32_perlshell_vec;
#ifndef __BORLANDC__
	long w32_num_children;
	HANDLE w32_child_pids[MAXIMUM_WAIT_OBJECTS];
#endif
	CPerlObj *pPerl;
};


static BOOL
has_redirection(char *ptr)
{
    int inquote = 0;
    char quote = '\0';

    /*
     * Scan string looking for redirection (< or >) or pipe
     * characters (|) that are not in a quoted string
     */
    while(*ptr) {
	switch(*ptr) {
	case '\'':
	case '\"':
	    if(inquote) {
		if(quote == *ptr) {
		    inquote = 0;
		    quote = '\0';
		}
	    }
	    else {
		quote = *ptr;
		inquote++;
	    }
	    break;
	case '>':
	case '<':
	case '|':
	    if(!inquote)
		return TRUE;
	default:
	    break;
	}
	++ptr;
    }
    return FALSE;
}

/* Tokenize a string.  Words are null-separated, and the list
 * ends with a doubled null.  Any character (except null and
 * including backslash) may be escaped by preceding it with a
 * backslash (the backslash will be stripped).
 * Returns number of words in result buffer.
 */
long
CPerlProc::Tokenize(char *str, char **dest, char ***destv)
{
    char *retstart = Nullch;
    char **retvstart = 0;
    int items = -1;
    if (str) {
	int slen = strlen(str);
	register char *ret;
	register char **retv;
	New(1307, ret, slen+2, char);
	New(1308, retv, (slen+3)/2, char*);

	retstart = ret;
	retvstart = retv;
	*retv = ret;
	items = 0;
	while (*str) {
	    *ret = *str++;
	    if (*ret == '\\' && *str)
		*ret = *str++;
	    else if (*ret == ' ') {
		while (*str == ' ')
		    str++;
		if (ret == retstart)
		    ret--;
		else {
		    *ret = '\0';
		    ++items;
		    if (*str)
			*++retv = ret+1;
		}
	    }
	    else if (!*str)
		++items;
	    ret++;
	}
	retvstart[items] = Nullch;
	*ret++ = '\0';
	*ret = '\0';
    }
    *dest = retstart;
    *destv = retvstart;
    return items;
}


void
CPerlProc::GetShell(void)
{
    if (!w32_perlshell_tokens) {
	/* we don't use COMSPEC here for two reasons:
	 *  1. the same reason perl on UNIX doesn't use SHELL--rampant and
	 *     uncontrolled unportability of the ensuing scripts.
	 *  2. PERL5SHELL could be set to a shell that may not be fit for
	 *     interactive use (which is what most programs look in COMSPEC
	 *     for).
	 */
	char* defaultshell = (IsWinNT() ? "cmd.exe /x/c" : "command.com /c");
	char* usershell = getenv("PERL5SHELL");
	w32_perlshell_items = Tokenize(usershell ? usershell : defaultshell,
				       &w32_perlshell_tokens,
				       &w32_perlshell_vec);
    }
}

int
CPerlProc::ASpawn(void *vreally, void **vmark, void **vsp)
{
    SV *really = (SV*)vreally;
    SV **mark = (SV**)vmark;
    SV **sp = (SV**)vsp;
    char **argv;
    char *str;
    int status;
    int flag = P_WAIT;
    int index = 0;

    if (sp <= mark)
	return -1;

    GetShell();
    New(1306, argv, (sp - mark) + w32_perlshell_items + 2, char*);

    if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
	++mark;
	flag = SvIVx(*mark);
    }

    while(++mark <= sp) {
	if (*mark && (str = SvPV(*mark, na)))
	    argv[index++] = str;
	else
	    argv[index++] = "";
    }
    argv[index++] = 0;
   
    status = Spawnvp(flag,
			   (really ? SvPV(really,na) : argv[0]),
			   (const char* const*)argv);

    if (status < 0 && errno == ENOEXEC) {
	/* possible shell-builtin, invoke with shell */
	int sh_items;
	sh_items = w32_perlshell_items;
	while (--index >= 0)
	    argv[index+sh_items] = argv[index];
	while (--sh_items >= 0)
	    argv[sh_items] = w32_perlshell_vec[sh_items];
   
	status = Spawnvp(flag,
			       (really ? SvPV(really,na) : argv[0]),
			       (const char* const*)argv);
    }

    if (status < 0) {
	if (pPerl->Perl_dowarn)
	    warn("Can't spawn \"%s\": %s", argv[0], strerror(errno));
	status = 255 * 256;
    }
    else if (flag != P_NOWAIT)
	status *= 256;
    Safefree(argv);
    return (pPerl->Perl_statusvalue = status);
}


int
CPerlProc::Spawn(char *cmd, int exectype)
{
    char **a;
    char *s;
    char **argv;
    int status = -1;
    BOOL needToTry = TRUE;
    char *cmd2;

    /* Save an extra exec if possible. See if there are shell
     * metacharacters in it */
    if(!has_redirection(cmd)) {
	New(1301,argv, strlen(cmd) / 2 + 2, char*);
	New(1302,cmd2, strlen(cmd) + 1, char);
	strcpy(cmd2, cmd);
	a = argv;
	for (s = cmd2; *s;) {
	    while (*s && isspace(*s))
		s++;
	    if (*s)
		*(a++) = s;
	    while(*s && !isspace(*s))
		s++;
	    if(*s)
		*s++ = '\0';
	}
	*a = Nullch;
	if (argv[0]) {
	    switch (exectype) {
	    case EXECF_SPAWN:
		status = Spawnvp(P_WAIT, argv[0],
				       (const char* const*)argv);
		break;
	    case EXECF_SPAWN_NOWAIT:
		status = Spawnvp(P_NOWAIT, argv[0],
				       (const char* const*)argv);
		break;
	    case EXECF_EXEC:
		status = Execvp(argv[0], (const char* const*)argv);
		break;
	    }
	    if (status != -1 || errno == 0)
		needToTry = FALSE;
	}
	Safefree(argv);
	Safefree(cmd2);
    }
    if (needToTry) {
	char **argv;
	int i = -1;
	GetShell();
	New(1306, argv, w32_perlshell_items + 2, char*);
	while (++i < w32_perlshell_items)
	    argv[i] = w32_perlshell_vec[i];
	argv[i++] = cmd;
	argv[i] = Nullch;
	switch (exectype) {
	case EXECF_SPAWN:
	    status = Spawnvp(P_WAIT, argv[0],
				   (const char* const*)argv);
	    break;
	case EXECF_SPAWN_NOWAIT:
	    status = Spawnvp(P_NOWAIT, argv[0],
				   (const char* const*)argv);
	    break;
	case EXECF_EXEC:
	    status = Execvp(argv[0], (const char* const*)argv);
	    break;
	}
	cmd = argv[0];
	Safefree(argv);
    }
    if (status < 0) {
	if (pPerl->Perl_dowarn)
	    warn("Can't %s \"%s\": %s",
		 (exectype == EXECF_EXEC ? "exec" : "spawn"),
		 cmd, strerror(errno));
	status = 255 * 256;
    }
    else if (exectype != EXECF_SPAWN_NOWAIT)
	status *= 256;
    return (pPerl->Perl_statusvalue = status);
}


void CPerlProc::Abort(void)
{
	abort();
}

void CPerlProc::Exit(int status)
{
	exit(status);
}

void CPerlProc::_Exit(int status)
{
	_exit(status);
}

int CPerlProc::Execl(const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3)
{
	return execl(cmdname, arg0, arg1, arg2, arg3);
}

int CPerlProc::Execv(const char *cmdname, const char *const *argv)
{
	return execv(cmdname, argv);
}

int CPerlProc::Execvp(const char *cmdname, const char *const *argv)
{
	return execvp(cmdname, argv);
}

#define ROOT_UID    ((uid_t)0)
#define ROOT_GID    ((gid_t)0)

uid_t CPerlProc::Getuid(void)
{
    return ROOT_UID;
}

uid_t CPerlProc::Geteuid(void)
{
    return ROOT_UID;
}

gid_t CPerlProc::Getgid(void)
{
    return ROOT_GID;
}

gid_t CPerlProc::Getegid(void)
{
    return ROOT_GID;
}


char *CPerlProc::Getlogin(void)
{
	char unknown[] = "<Unknown>";
	unsigned long len;

	len = sizeof(szLoginNameStr);
	if(!GetUserName(szLoginNameStr, &len)) 
	{
		strcpy(szLoginNameStr, unknown);
	}
	return szLoginNameStr;
}

int CPerlProc::Kill(int pid, int sig)
{
	HANDLE hProcess;

	hProcess = OpenProcess(PROCESS_ALL_ACCESS, FALSE, (DWORD)pid);
	if(hProcess == NULL)
		croak("kill process failed!\n");

	if(TerminateProcess(hProcess, 0) == FALSE)
		croak("kill process failed!\n");

	CloseHandle(hProcess);
	return 0;
}

int CPerlProc::Killpg(int pid, int sig)
{
	croak("killpg not implemented!\n");
	return 0;
}

int CPerlProc::PauseProc(void)
{
    Sleep((unsigned int)((32767L << 16) + 32767));
    return 0;
}

PerlIO* CPerlProc::Popen(const char *command, const char *mode)
{
	return (PerlIO*)_popen(command, mode);
}

int CPerlProc::Pclose(PerlIO *pf)
{
	return _pclose((FILE*)pf);
}

int CPerlProc::Pipe(int *phandles)
{
	return _pipe(phandles, 512, O_BINARY);
}

int CPerlProc::Sleep(unsigned int s)
{
    ::Sleep(s*1000);
    return 0;
}

int CPerlProc::Times(struct tms *timebuf)
{
    FILETIME user;
    FILETIME kernel;
    FILETIME dummy;
    if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy, 
                        &kernel,&user)) {
	timebuf->tms_utime = filetime_to_clock(&user);
	timebuf->tms_stime = filetime_to_clock(&kernel);
	timebuf->tms_cutime = 0;
	timebuf->tms_cstime = 0;
        
    } else { 
        /* That failed - e.g. Win95 fallback to clock() */
        clock_t t = clock();
	timebuf->tms_utime = t;
	timebuf->tms_stime = 0;
	timebuf->tms_cutime = 0;
	timebuf->tms_cstime = 0;
    }
    return 0;
}

int CPerlProc::Wait(int *status)
{
#ifdef __BORLANDC__
    return wait(status);
#else
    /* XXX this wait emulation only knows about processes
     * spawned via win32_spawnvp(P_NOWAIT, ...).
     */
    int i, retval;
    DWORD exitcode, waitcode;

    if (!w32_num_children) {
	errno = ECHILD;
	return -1;
    }

    /* if a child exists, wait for it to die */
    waitcode = WaitForMultipleObjects(w32_num_children,
				      w32_child_pids,
				      FALSE,
				      INFINITE);
    if (waitcode != WAIT_FAILED) {
	if (waitcode >= WAIT_ABANDONED_0
	    && waitcode < WAIT_ABANDONED_0 + w32_num_children)
	    i = waitcode - WAIT_ABANDONED_0;
	else
	    i = waitcode - WAIT_OBJECT_0;
	if (GetExitCodeProcess(w32_child_pids[i], &exitcode) ) {
	    CloseHandle(w32_child_pids[i]);
	    *status = (int)((exitcode & 0xff) << 8);
	    retval = (int)w32_child_pids[i];
	    Copy(&w32_child_pids[i+1], &w32_child_pids[i],
		 (w32_num_children-i-1), HANDLE);
	    w32_num_children--;
	    return retval;
	}
    }

FAILED:
    errno = GetLastError();
    return -1;

#endif
}

int CPerlProc::Setuid(uid_t u)
{
    return (u == ROOT_UID ? 0 : -1);
}

int CPerlProc::Setgid(gid_t g)
{
    return (g == ROOT_GID ? 0 : -1);
}

Sighandler_t CPerlProc::Signal(int sig, Sighandler_t subcode)
{
	return 0;
}

void CPerlProc::GetSysMsg(char*& sMsg, DWORD& dwLen, DWORD dwErr)
{
	dwLen = FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER
			  |FORMAT_MESSAGE_IGNORE_INSERTS
			  |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
			   dwErr, 0, (char *)&sMsg, 1, NULL);
    if (0 < dwLen) {
	while (0 < dwLen  &&  isspace(sMsg[--dwLen]))
	    ;
	if ('.' != sMsg[dwLen])
	    dwLen++;
	sMsg[dwLen]= '\0';
    }
    if (0 == dwLen) {
	sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
	dwLen = sprintf(sMsg,
			"Unknown error #0x%lX (lookup 0x%lX)",
			dwErr, GetLastError());
    }
}

void CPerlProc::FreeBuf(char* sMsg)
{
    LocalFree(sMsg);
}

BOOL CPerlProc::DoCmd(char *cmd)
{
    Spawn(cmd, EXECF_EXEC);
    return FALSE;
}

int CPerlProc::Spawn(char* cmd)
{
    return Spawn(cmd, EXECF_SPAWN);
}

int CPerlProc::Spawnvp(int mode, const char *cmdname, const char *const *argv)
{
    int status;

    status = spawnvp(mode, cmdname, (char * const *)argv);
#ifndef __BORLANDC__
    /* XXX For the P_NOWAIT case, Borland RTL returns pinfo.dwProcessId
     * while VC RTL returns pinfo.hProcess. For purposes of the custom
     * implementation of win32_wait(), we assume the latter.
     */
    if (mode == P_NOWAIT && status >= 0)
	w32_child_pids[w32_num_children++] = (HANDLE)status;
#endif
    return status;
}
Commit	Line	Data
76e3520e	1	/*
	2
	3	ipproc.c
	4	Interface for perl process functions
	5
	6	*/
	7
	8	#include <ipproc.h>
	9	#include <stdlib.h>
	10	#include <fcntl.h>
	11
	12	#define EXECF_EXEC 1
	13	#define EXECF_SPAWN 2
	14	#define EXECF_SPAWN_NOWAIT 3
	15
	16	class CPerlProc : public IPerlProc
	17	{
	18	public:
	19	CPerlProc()
	20	{
	21	pPerl = NULL;
	22	w32_perlshell_tokens = NULL;
	23	w32_perlshell_items = -1;
	24	w32_platform = -1;
	25	#ifndef __BORLANDC__
	26	w32_num_children = 0;
	27	#endif
	28	};
	29	virtual void Abort(void);
	30	virtual void Exit(int status);
	31	virtual void _Exit(int status);
	32	virtual int Execl(const char cmdname, const char arg0, const char arg1, const char arg2, const char *arg3);
	33	virtual int Execv(const char cmdname, const char const *argv);
	34	virtual int Execvp(const char cmdname, const char const *argv);
	35	virtual uid_t Getuid(void);
	36	virtual uid_t Geteuid(void);
	37	virtual gid_t Getgid(void);
	38	virtual gid_t Getegid(void);
	39	virtual char *Getlogin(void);
	40	virtual int Kill(int pid, int sig);
	41	virtual int Killpg(int pid, int sig);
	42	virtual int PauseProc(void);
	43	virtual PerlIO* Popen(const char command, const char mode);
	44	virtual int Pclose(PerlIO *stream);
	45	virtual int Pipe(int *phandles);
	46	virtual int Setuid(uid_t u);
	47	virtual int Setgid(gid_t g);
	48	virtual int Sleep(unsigned int);
	49	virtual int Times(struct tms *timebuf);
	50	virtual int Wait(int *status);
	51	virtual Sighandler_t Signal(int sig, Sighandler_t subcode);
	52	virtual void GetSysMsg(char*& msg, DWORD& dwLen, DWORD dwErr);
	53	virtual void FreeBuf(char* msg);
	54	virtual BOOL DoCmd(char *cmd);
	55	virtual int Spawn(char*cmds);
	56	virtual int Spawnvp(int mode, const char cmdname, const char const *argv);
	57	virtual int ASpawn(void vreally, void vmark, void *vsp);
	58
	59	inline void SetPerlObj(CPerlObj *p) { pPerl = p; };
	60	protected:
	61	int Spawn(char *cmd, int exectype);
	62	void GetShell(void);
	63	long Tokenize(char str, char dest, char **destv);
	64
65	inline int IsWin95(void)
66	{
67	return (os_id() == VER_PLATFORM_WIN32_WINDOWS);
68	};
69	inline int IsWinNT(void)
70	{
71	return (os_id() == VER_PLATFORM_WIN32_NT);
72	};
73
74	inline long filetime_to_clock(PFILETIME ft)
75	{
76	__int64 qw = ft->dwHighDateTime;
77	qw <<= 32;
78	qw \|= ft->dwLowDateTime;
79	qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
80	return (long) qw;
81	};
82
83	DWORD os_id(void)
84	{
85	if((-1) == w32_platform)
86	{
87	OSVERSIONINFO osver;
88
89	memset(&osver, 0, sizeof(OSVERSIONINFO));
90	osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
91	GetVersionEx(&osver);
92	w32_platform = osver.dwPlatformId;
93	}
94	return (w32_platform);
95	};
96
97	DWORD w32_platform;
98	char szLoginNameStr[128];
99	char *w32_perlshell_tokens;
100	long w32_perlshell_items;
101	char **w32_perlshell_vec;
102	#ifndef __BORLANDC__
103	long w32_num_children;
104	HANDLE w32_child_pids[MAXIMUM_WAIT_OBJECTS];
105	#endif
106	CPerlObj *pPerl;
107	};
108
109
110	static BOOL
111	has_redirection(char *ptr)
112	{
113	int inquote = 0;
114	char quote = '\0';
115
116	/*
117	* Scan string looking for redirection (< or >) or pipe
118	* characters (\|) that are not in a quoted string
119	*/
120	while(*ptr) {
121	switch(*ptr) {
122	case '\'':
123	case '\"':
124	if(inquote) {
125	if(quote == *ptr) {
126	inquote = 0;
127	quote = '\0';
128	}
129	}
130	else {
131	quote = *ptr;
132	inquote++;
133	}
134	break;
135	case '>':
136	case '<':
137	case '\|':
138	if(!inquote)
139	return TRUE;
140	default:
141	break;
142	}
143	++ptr;
144	}
145	return FALSE;
146	}
147
148	/* Tokenize a string. Words are null-separated, and the list
149	* ends with a doubled null. Any character (except null and
150	* including backslash) may be escaped by preceding it with a
151	* backslash (the backslash will be stripped).
152	* Returns number of words in result buffer.
153	*/
154	long
155	CPerlProc::Tokenize(char str, char dest, char **destv)
156	{
157	char *retstart = Nullch;
158	char **retvstart = 0;
159	int items = -1;
160	if (str) {
161	int slen = strlen(str);
162	register char *ret;
163	register char **retv;
164	New(1307, ret, slen+2, char);
165	New(1308, retv, (slen+3)/2, char*);
166
167	retstart = ret;
168	retvstart = retv;
169	*retv = ret;
170	items = 0;
171	while (*str) {
172	ret = str++;
173	if (ret == '\\' && str)
174	ret = str++;
175	else if (*ret == ' ') {
176	while (*str == ' ')
177	str++;
178	if (ret == retstart)
179	ret--;
180	else {
181	*ret = '\0';
182	++items;
183	if (*str)
184	*++retv = ret+1;
185	}
186	}
187	else if (!*str)
188	++items;
189	ret++;
190	}
191	retvstart[items] = Nullch;
192	*ret++ = '\0';
193	*ret = '\0';
194	}
195	*dest = retstart;
196	*destv = retvstart;
197	return items;
198	}
199
200
201	void
202	CPerlProc::GetShell(void)
203	{
204	if (!w32_perlshell_tokens) {
205	/* we don't use COMSPEC here for two reasons:
206	* 1. the same reason perl on UNIX doesn't use SHELL--rampant and
207	* uncontrolled unportability of the ensuing scripts.
208	* 2. PERL5SHELL could be set to a shell that may not be fit for
209	* interactive use (which is what most programs look in COMSPEC
210	* for).
211	*/
212	char* defaultshell = (IsWinNT() ? "cmd.exe /x/c" : "command.com /c");
213	char* usershell = getenv("PERL5SHELL");
214	w32_perlshell_items = Tokenize(usershell ? usershell : defaultshell,
215	&w32_perlshell_tokens,
216	&w32_perlshell_vec);
217	}
218	}
219
220	int
221	CPerlProc::ASpawn(void vreally, void vmark, void *vsp)
222	{
223	SV really = (SV)vreally;
224	SV mark = (SV)vmark;
225	SV sp = (SV)vsp;
226	char **argv;
227	char *str;
228	int status;
229	int flag = P_WAIT;
230	int index = 0;
231
232	if (sp <= mark)
233	return -1;
234
235	GetShell();
236	New(1306, argv, (sp - mark) + w32_perlshell_items + 2, char*);
237
238	if (SvNIOKp((mark+1)) && !SvPOKp((mark+1))) {
239	++mark;
240	flag = SvIVx(*mark);
241	}
242
243	while(++mark <= sp) {
244	if (mark && (str = SvPV(mark, na)))
245	argv[index++] = str;
246	else
247	argv[index++] = "";
248	}
249	argv[index++] = 0;
250
251	status = Spawnvp(flag,
252	(really ? SvPV(really,na) : argv[0]),
253	(const char* const*)argv);
254
255	if (status < 0 && errno == ENOEXEC) {
256	/* possible shell-builtin, invoke with shell */
257	int sh_items;
258	sh_items = w32_perlshell_items;
259	while (--index >= 0)
260	argv[index+sh_items] = argv[index];
261	while (--sh_items >= 0)
262	argv[sh_items] = w32_perlshell_vec[sh_items];
263
264	status = Spawnvp(flag,
265	(really ? SvPV(really,na) : argv[0]),
266	(const char* const*)argv);
267	}
268
269	if (status < 0) {
270	if (pPerl->Perl_dowarn)
271	warn("Can't spawn \"%s\": %s", argv[0], strerror(errno));
272	status = 255 * 256;
273	}
274	else if (flag != P_NOWAIT)
275	status *= 256;
276	Safefree(argv);
277	return (pPerl->Perl_statusvalue = status);
278	}
279
280
281	int
282	CPerlProc::Spawn(char *cmd, int exectype)
283	{
284	char **a;
285	char *s;
286	char **argv;
287	int status = -1;
288	BOOL needToTry = TRUE;
289	char *cmd2;
290
291	/* Save an extra exec if possible. See if there are shell
292	* metacharacters in it */
293	if(!has_redirection(cmd)) {
294	New(1301,argv, strlen(cmd) / 2 + 2, char*);
295	New(1302,cmd2, strlen(cmd) + 1, char);
296	strcpy(cmd2, cmd);
297	a = argv;
298	for (s = cmd2; *s;) {
299	while (s && isspace(s))
300	s++;
301	if (*s)
302	*(a++) = s;
303	while(s && !isspace(s))
304	s++;
305	if(*s)
306	*s++ = '\0';
307	}
308	*a = Nullch;
309	if (argv[0]) {
310	switch (exectype) {
311	case EXECF_SPAWN:
312	status = Spawnvp(P_WAIT, argv[0],
313	(const char* const*)argv);
314	break;
315	case EXECF_SPAWN_NOWAIT:
316	status = Spawnvp(P_NOWAIT, argv[0],
317	(const char* const*)argv);
318	break;
319	case EXECF_EXEC:
320	status = Execvp(argv[0], (const char* const*)argv);
321	break;
322	}
323	if (status != -1 \|\| errno == 0)
324	needToTry = FALSE;
325	}
326	Safefree(argv);
327	Safefree(cmd2);
328	}
329	if (needToTry) {
330	char **argv;
331	int i = -1;
332	GetShell();
333	New(1306, argv, w32_perlshell_items + 2, char*);
334	while (++i < w32_perlshell_items)
335	argv[i] = w32_perlshell_vec[i];
336	argv[i++] = cmd;
337	argv[i] = Nullch;
338	switch (exectype) {
339	case EXECF_SPAWN:
340	status = Spawnvp(P_WAIT, argv[0],
341	(const char* const*)argv);
342	break;
343	case EXECF_SPAWN_NOWAIT:
344	status = Spawnvp(P_NOWAIT, argv[0],
345	(const char* const*)argv);
346	break;
347	case EXECF_EXEC:
348	status = Execvp(argv[0], (const char* const*)argv);
349	break;
350	}
351	cmd = argv[0];
352	Safefree(argv);
353	}
354	if (status < 0) {
355	if (pPerl->Perl_dowarn)
356	warn("Can't %s \"%s\": %s",
357	(exectype == EXECF_EXEC ? "exec" : "spawn"),
358	cmd, strerror(errno));
359	status = 255 * 256;
360	}
361	else if (exectype != EXECF_SPAWN_NOWAIT)
362	status *= 256;
363	return (pPerl->Perl_statusvalue = status);
364	}
365
366
367	void CPerlProc::Abort(void)
368	{
369	abort();
370	}
371
372	void CPerlProc::Exit(int status)
373	{
374	exit(status);
375	}
376
377	void CPerlProc::_Exit(int status)
378	{
379	_exit(status);
380	}
381
382	int CPerlProc::Execl(const char cmdname, const char arg0, const char arg1, const char arg2, const char *arg3)
383	{
384	return execl(cmdname, arg0, arg1, arg2, arg3);
385	}
386
387	int CPerlProc::Execv(const char cmdname, const char const *argv)
388	{
389	return execv(cmdname, argv);
390	}
391
392	int CPerlProc::Execvp(const char cmdname, const char const *argv)
393	{
394	return execvp(cmdname, argv);
395	}
396
397	#define ROOT_UID ((uid_t)0)
398	#define ROOT_GID ((gid_t)0)
399
400	uid_t CPerlProc::Getuid(void)
401	{
402	return ROOT_UID;
403	}
404
405	uid_t CPerlProc::Geteuid(void)
406	{
407	return ROOT_UID;
408	}
409
410	gid_t CPerlProc::Getgid(void)
411	{
412	return ROOT_GID;
413	}
414
415	gid_t CPerlProc::Getegid(void)
416	{
417	return ROOT_GID;
418	}
419
420
421	char *CPerlProc::Getlogin(void)
422	{
423	char unknown[] = "<Unknown>";
424	unsigned long len;
425
426	len = sizeof(szLoginNameStr);
427	if(!GetUserName(szLoginNameStr, &len))
428	{
429	strcpy(szLoginNameStr, unknown);
430	}
431	return szLoginNameStr;
432	}
433
434	int CPerlProc::Kill(int pid, int sig)
435	{
436	HANDLE hProcess;
437
438	hProcess = OpenProcess(PROCESS_ALL_ACCESS, FALSE, (DWORD)pid);
439	if(hProcess == NULL)
440	croak("kill process failed!\n");
441
442	if(TerminateProcess(hProcess, 0) == FALSE)
443	croak("kill process failed!\n");
444
445	CloseHandle(hProcess);
446	return 0;
447	}
448
449	int CPerlProc::Killpg(int pid, int sig)
450	{
451	croak("killpg not implemented!\n");
452	return 0;
453	}
454
455	int CPerlProc::PauseProc(void)
456	{
457	Sleep((unsigned int)((32767L << 16) + 32767));
458	return 0;
459	}
460
461	PerlIO* CPerlProc::Popen(const char command, const char mode)
462	{
463	return (PerlIO*)_popen(command, mode);
464	}
465
466	int CPerlProc::Pclose(PerlIO *pf)
467	{
468	return _pclose((FILE*)pf);
469	}
470
471	int CPerlProc::Pipe(int *phandles)
472	{
473	return _pipe(phandles, 512, O_BINARY);
474	}
475
476	int CPerlProc::Sleep(unsigned int s)
477	{
478	::Sleep(s*1000);
479	return 0;
480	}
481
482	int CPerlProc::Times(struct tms *timebuf)
483	{
484	FILETIME user;
485	FILETIME kernel;
486	FILETIME dummy;
487	if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
488	&kernel,&user)) {
489	timebuf->tms_utime = filetime_to_clock(&user);
490	timebuf->tms_stime = filetime_to_clock(&kernel);
491	timebuf->tms_cutime = 0;
492	timebuf->tms_cstime = 0;
493
494	} else {
495	/* That failed - e.g. Win95 fallback to clock() */
496	clock_t t = clock();
497	timebuf->tms_utime = t;
498	timebuf->tms_stime = 0;
499	timebuf->tms_cutime = 0;
500	timebuf->tms_cstime = 0;
501	}
502	return 0;
503	}
504
505	int CPerlProc::Wait(int *status)
506	{
507	#ifdef __BORLANDC__
508	return wait(status);
509	#else
510	/* XXX this wait emulation only knows about processes
511	* spawned via win32_spawnvp(P_NOWAIT, ...).
512	*/
513	int i, retval;
514	DWORD exitcode, waitcode;
515
516	if (!w32_num_children) {
517	errno = ECHILD;
518	return -1;
519	}
520
521	/* if a child exists, wait for it to die */
522	waitcode = WaitForMultipleObjects(w32_num_children,
523	w32_child_pids,
524	FALSE,
525	INFINITE);
526	if (waitcode != WAIT_FAILED) {
527	if (waitcode >= WAIT_ABANDONED_0
528	&& waitcode < WAIT_ABANDONED_0 + w32_num_children)
529	i = waitcode - WAIT_ABANDONED_0;
530	else
531	i = waitcode - WAIT_OBJECT_0;
532	if (GetExitCodeProcess(w32_child_pids[i], &exitcode) ) {
533	CloseHandle(w32_child_pids[i]);
534	*status = (int)((exitcode & 0xff) << 8);
535	retval = (int)w32_child_pids[i];
536	Copy(&w32_child_pids[i+1], &w32_child_pids[i],
537	(w32_num_children-i-1), HANDLE);
538	w32_num_children--;
539	return retval;
540	}
541	}
542
543	FAILED:
544	errno = GetLastError();
545	return -1;
546
547	#endif
548	}
549
550	int CPerlProc::Setuid(uid_t u)
551	{
552	return (u == ROOT_UID ? 0 : -1);
553	}
554
555	int CPerlProc::Setgid(gid_t g)
556	{
557	return (g == ROOT_GID ? 0 : -1);
558	}
559
560	Sighandler_t CPerlProc::Signal(int sig, Sighandler_t subcode)
561	{
562	return 0;
563	}
564
565	void CPerlProc::GetSysMsg(char*& sMsg, DWORD& dwLen, DWORD dwErr)
566	{
567	dwLen = FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER
568	\|FORMAT_MESSAGE_IGNORE_INSERTS
569	\|FORMAT_MESSAGE_FROM_SYSTEM, NULL,
570	dwErr, 0, (char *)&sMsg, 1, NULL);
571	if (0 < dwLen) {
572	while (0 < dwLen && isspace(sMsg[--dwLen]))
573	;
574	if ('.' != sMsg[dwLen])
575	dwLen++;
576	sMsg[dwLen]= '\0';
577	}
578	if (0 == dwLen) {
579	sMsg = (char)LocalAlloc(0, 64/sizeof(TCHAR)/);
580	dwLen = sprintf(sMsg,
581	"Unknown error #0x%lX (lookup 0x%lX)",
582	dwErr, GetLastError());
583	}
584	}
585
586	void CPerlProc::FreeBuf(char* sMsg)
587	{
588	LocalFree(sMsg);
589	}
590
591	BOOL CPerlProc::DoCmd(char *cmd)
592	{
593	Spawn(cmd, EXECF_EXEC);
594	return FALSE;
595	}
596
597	int CPerlProc::Spawn(char* cmd)
598	{
599	return Spawn(cmd, EXECF_SPAWN);
600	}
601
602	int CPerlProc::Spawnvp(int mode, const char cmdname, const char const *argv)
603	{
604	int status;
605
606	status = spawnvp(mode, cmdname, (char * const *)argv);
607	#ifndef __BORLANDC__
608	/* XXX For the P_NOWAIT case, Borland RTL returns pinfo.dwProcessId
609	* while VC RTL returns pinfo.hProcess. For purposes of the custom
610	* implementation of win32_wait(), we assume the latter.
611	*/
612	if (mode == P_NOWAIT && status >= 0)
613	w32_child_pids[w32_num_children++] = (HANDLE)status;
614	#endif
615	return status;
616	}
617
618
619
620